2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[MachCode]{Generating machine code}
6 This is a big module, but, if you pay attention to
7 (a) the sectioning, (b) the type signatures, and
8 (c) the \tr{#if blah_TARGET_ARCH} things, the
9 structure should not be too overwhelming.
12 module MachCode ( stmtsToInstrs, InstrBlock ) where
14 #include "HsVersions.h"
15 #include "nativeGen/NCG.h"
17 import 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, labelDynamic )
24 import Maybes ( maybeToBool, expectJust )
25 import PrimRep ( isFloatingRep, PrimRep(..) )
26 import PrimOp ( PrimOp(..) )
27 import CallConv ( cCallConv, stdCallConv )
28 import Stix ( getNatLabelNCG, StixTree(..),
29 StixReg(..), CodeSegment(..),
30 DestInfo, hasDestInfo,
32 NatM, thenNat, returnNat, mapNat,
33 mapAndUnzipNat, mapAccumLNat,
34 getDeltaNat, setDeltaNat
37 import CmdLineOpts ( opt_Static )
43 @InstrBlock@s are the insn sequences generated by the insn selectors.
44 They are really trees of insns to facilitate fast appending, where a
45 left-to-right traversal (pre-order?) yields the insns in the correct
50 type InstrBlock = OrdList Instr
56 Code extractor for an entire stix tree---stix statement level.
59 stmtsToInstrs :: [StixTree] -> NatM InstrBlock
61 = liftStrings stmts [] [] `thenNat` \ lifted ->
62 mapNat stmtToInstrs lifted `thenNat` \ instrss ->
63 returnNat (concatOL instrss)
66 -- Lift StStrings out of top-level StDatas, putting them at the end of
67 -- the block, and replacing them with StCLbls which refer to the lifted-out strings.
68 {- Motivation for this hackery provided by the following bug:
72 (Data P_ Addr.A#_static_info)
73 (Data StgAddr (Str `alalal'))
78 .global Bogon_ping_closure
80 .long Addr_Azh_static_info
91 ie, the Str is planted in-line, when what we really meant was to place
92 a _reference_ to the string there. liftStrings will lift out all such
93 strings in top-level data and place them at the end of the block.
95 This is still a rather half-baked solution -- to do the job entirely right
96 would mean a complete traversal of all the Stixes, but there's currently no
97 real need for it, and it would be slow. Also, potentially there could be
98 literal types other than strings which need lifting out?
101 liftStrings :: [StixTree] -- originals
102 -> [StixTree] -- (reverse) originals with strings lifted out
103 -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels
106 -- First, examine the original trees and lift out strings in top-level StDatas.
107 liftStrings (st:sts) acc_stix acc_strs
110 -> lift datas acc_strs `thenNat` \ (datas_done, acc_strs1) ->
111 liftStrings sts ((StData sz datas_done):acc_stix) acc_strs1
113 -> liftStrings sts (other:acc_stix) acc_strs
115 -- Handle a top-level StData
116 lift [] acc_strs = returnNat ([], acc_strs)
118 = lift ds acc_strs `thenNat` \ (ds_done, acc_strs1) ->
121 -> getNatLabelNCG `thenNat` \ lbl ->
122 returnNat ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
124 -> returnNat (other:ds_done, acc_strs1)
126 -- When we've run out of original trees, emit the lifted strings.
127 liftStrings [] acc_stix acc_strs
128 = returnNat (reverse acc_stix ++ concatMap f acc_strs)
130 f (lbl,str) = [StSegment RoDataSegment,
133 StSegment TextSegment]
136 stmtToInstrs :: StixTree {- a stix statement -} -> NatM InstrBlock
137 stmtToInstrs stmt = case stmt of
138 StComment s -> returnNat (unitOL (COMMENT s))
139 StSegment seg -> returnNat (unitOL (SEGMENT seg))
141 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
143 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
146 StLabel lab -> returnNat (unitOL (LABEL lab))
148 StJump dsts arg -> genJump dsts (derefDLL arg)
149 StCondJump lab arg -> genCondJump lab (derefDLL arg)
151 -- A call returning void, ie one done for its side-effects
152 StCall fn cconv VoidRep args -> genCCall fn
153 cconv VoidRep (map derefDLL args)
156 | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
157 | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
160 -- When falling through on the Alpha, we still have to load pv
161 -- with the address of the next routine, so that it can load gp.
162 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
166 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
167 returnNat (DATA (primRepToSize kind) imms
168 `consOL` concatOL codes)
170 getData :: StixTree -> NatM (InstrBlock, Imm)
171 getData (StInt i) = returnNat (nilOL, ImmInteger i)
172 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
173 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
174 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
175 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
176 -- the linker can handle simple arithmetic...
177 getData (StIndex rep (StCLbl lbl) (StInt off)) =
179 ImmIndex lbl (fromInteger (off * sizeOf rep)))
181 -- Top-level lifted-out string. The segment will already have been set
182 -- (see liftStrings above).
184 -> returnNat (unitOL (ASCII True (_UNPK_ str)))
187 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
188 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
189 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
191 derefDLL :: StixTree -> StixTree
193 | opt_Static -- short out the entire deal if not doing DLLs
200 StCLbl lbl -> if labelDynamic lbl
201 then StInd PtrRep (StCLbl lbl)
203 -- all the rest are boring
204 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
205 StPrim pk args -> StPrim pk (map qq args)
206 StInd pk addr -> StInd pk (qq addr)
207 StCall who cc pk args -> StCall who cc pk (map qq args)
214 _ -> pprPanic "derefDLL: unhandled case"
218 %************************************************************************
220 \subsection{General things for putting together code sequences}
222 %************************************************************************
225 mangleIndexTree :: StixTree -> StixTree
227 mangleIndexTree (StIndex pk base (StInt i))
228 = StPrim IntAddOp [base, off]
230 off = StInt (i * sizeOf pk)
232 mangleIndexTree (StIndex pk base off)
236 in if s == 0 then off else StPrim SllOp [off, StInt (toInteger s)]
239 shift :: PrimRep -> Int
240 shift rep = case (fromInteger (sizeOf rep) :: Int) of
245 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
250 maybeImm :: StixTree -> Maybe Imm
254 maybeImm (StIndex rep (StCLbl l) (StInt off))
255 = Just (ImmIndex l (fromInteger (off * sizeOf rep)))
257 | i >= toInteger minInt && i <= toInteger maxInt
258 = Just (ImmInt (fromInteger i))
260 = Just (ImmInteger i)
265 %************************************************************************
267 \subsection{The @Register@ type}
269 %************************************************************************
271 @Register@s passed up the tree. If the stix code forces the register
272 to live in a pre-decided machine register, it comes out as @Fixed@;
273 otherwise, it comes out as @Any@, and the parent can decide which
274 register to put it in.
278 = Fixed PrimRep Reg InstrBlock
279 | Any PrimRep (Reg -> InstrBlock)
281 registerCode :: Register -> Reg -> InstrBlock
282 registerCode (Fixed _ _ code) reg = code
283 registerCode (Any _ code) reg = code reg
285 registerCodeF (Fixed _ _ code) = code
286 registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
288 registerCodeA (Any _ code) = code
289 registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
291 registerName :: Register -> Reg -> Reg
292 registerName (Fixed _ reg _) _ = reg
293 registerName (Any _ _) reg = reg
295 registerNameF (Fixed _ reg _) = reg
296 registerNameF (Any _ _) = pprPanic "registerNameF" empty
298 registerRep :: Register -> PrimRep
299 registerRep (Fixed pk _ _) = pk
300 registerRep (Any pk _) = pk
302 {-# INLINE registerCode #-}
303 {-# INLINE registerCodeF #-}
304 {-# INLINE registerName #-}
305 {-# INLINE registerNameF #-}
306 {-# INLINE registerRep #-}
307 {-# INLINE isFixed #-}
310 isFixed, isAny :: Register -> Bool
311 isFixed (Fixed _ _ _) = True
312 isFixed (Any _ _) = False
314 isAny = not . isFixed
317 Generate code to get a subtree into a @Register@:
319 getRegister :: StixTree -> NatM Register
321 getRegister (StReg (StixMagicId stgreg))
322 = case (magicIdRegMaybe stgreg) of
323 Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
326 getRegister (StReg (StixTemp u pk))
327 = returnNat (Fixed pk (mkVReg u pk) nilOL)
329 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
331 getRegister (StCall fn cconv kind args)
332 = genCCall fn cconv kind args `thenNat` \ call ->
333 returnNat (Fixed kind reg call)
335 reg = if isFloatingRep kind
336 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
337 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
339 getRegister (StString s)
340 = getNatLabelNCG `thenNat` \ lbl ->
342 imm_lbl = ImmCLbl lbl
345 SEGMENT RoDataSegment,
347 ASCII True (_UNPK_ s),
349 #if alpha_TARGET_ARCH
350 LDA dst (AddrImm imm_lbl)
353 MOV L (OpImm imm_lbl) (OpReg dst)
355 #if sparc_TARGET_ARCH
356 SETHI (HI imm_lbl) dst,
357 OR False dst (RIImm (LO imm_lbl)) dst
361 returnNat (Any PtrRep code)
365 -- end of machine-"independent" bit; here we go on the rest...
367 #if alpha_TARGET_ARCH
369 getRegister (StDouble d)
370 = getNatLabelNCG `thenNat` \ lbl ->
371 getNewRegNCG PtrRep `thenNat` \ tmp ->
372 let code dst = mkSeqInstrs [
375 DATA TF [ImmLab (rational d)],
377 LDA tmp (AddrImm (ImmCLbl lbl)),
378 LD TF dst (AddrReg tmp)]
380 returnNat (Any DoubleRep code)
382 getRegister (StPrim primop [x]) -- unary PrimOps
384 IntNegOp -> trivialUCode (NEG Q False) x
386 NotOp -> trivialUCode NOT x
388 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
389 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
391 OrdOp -> coerceIntCode IntRep x
394 Float2IntOp -> coerceFP2Int x
395 Int2FloatOp -> coerceInt2FP pr x
396 Double2IntOp -> coerceFP2Int x
397 Int2DoubleOp -> coerceInt2FP pr x
399 Double2FloatOp -> coerceFltCode x
400 Float2DoubleOp -> coerceFltCode x
402 other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
404 fn = case other_op of
405 FloatExpOp -> SLIT("exp")
406 FloatLogOp -> SLIT("log")
407 FloatSqrtOp -> SLIT("sqrt")
408 FloatSinOp -> SLIT("sin")
409 FloatCosOp -> SLIT("cos")
410 FloatTanOp -> SLIT("tan")
411 FloatAsinOp -> SLIT("asin")
412 FloatAcosOp -> SLIT("acos")
413 FloatAtanOp -> SLIT("atan")
414 FloatSinhOp -> SLIT("sinh")
415 FloatCoshOp -> SLIT("cosh")
416 FloatTanhOp -> SLIT("tanh")
417 DoubleExpOp -> SLIT("exp")
418 DoubleLogOp -> SLIT("log")
419 DoubleSqrtOp -> SLIT("sqrt")
420 DoubleSinOp -> SLIT("sin")
421 DoubleCosOp -> SLIT("cos")
422 DoubleTanOp -> SLIT("tan")
423 DoubleAsinOp -> SLIT("asin")
424 DoubleAcosOp -> SLIT("acos")
425 DoubleAtanOp -> SLIT("atan")
426 DoubleSinhOp -> SLIT("sinh")
427 DoubleCoshOp -> SLIT("cosh")
428 DoubleTanhOp -> SLIT("tanh")
430 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
432 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
434 CharGtOp -> trivialCode (CMP LTT) y x
435 CharGeOp -> trivialCode (CMP LE) y x
436 CharEqOp -> trivialCode (CMP EQQ) x y
437 CharNeOp -> int_NE_code x y
438 CharLtOp -> trivialCode (CMP LTT) x y
439 CharLeOp -> trivialCode (CMP LE) x y
441 IntGtOp -> trivialCode (CMP LTT) y x
442 IntGeOp -> trivialCode (CMP LE) y x
443 IntEqOp -> trivialCode (CMP EQQ) x y
444 IntNeOp -> int_NE_code x y
445 IntLtOp -> trivialCode (CMP LTT) x y
446 IntLeOp -> trivialCode (CMP LE) x y
448 WordGtOp -> trivialCode (CMP ULT) y x
449 WordGeOp -> trivialCode (CMP ULE) x y
450 WordEqOp -> trivialCode (CMP EQQ) x y
451 WordNeOp -> int_NE_code x y
452 WordLtOp -> trivialCode (CMP ULT) x y
453 WordLeOp -> trivialCode (CMP ULE) x y
455 AddrGtOp -> trivialCode (CMP ULT) y x
456 AddrGeOp -> trivialCode (CMP ULE) y x
457 AddrEqOp -> trivialCode (CMP EQQ) x y
458 AddrNeOp -> int_NE_code x y
459 AddrLtOp -> trivialCode (CMP ULT) x y
460 AddrLeOp -> trivialCode (CMP ULE) x y
462 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
463 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
464 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
465 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
466 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
467 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
469 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
470 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
471 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
472 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
473 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
474 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
476 IntAddOp -> trivialCode (ADD Q False) x y
477 IntSubOp -> trivialCode (SUB Q False) x y
478 IntMulOp -> trivialCode (MUL Q False) x y
479 IntQuotOp -> trivialCode (DIV Q False) x y
480 IntRemOp -> trivialCode (REM Q False) x y
482 WordQuotOp -> trivialCode (DIV Q True) x y
483 WordRemOp -> trivialCode (REM Q True) x y
485 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
486 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
487 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
488 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
490 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
491 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
492 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
493 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
495 AndOp -> trivialCode AND x y
496 OrOp -> trivialCode OR x y
497 XorOp -> trivialCode XOR x y
498 SllOp -> trivialCode SLL x y
499 SrlOp -> trivialCode SRL x y
501 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
502 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
503 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
505 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
506 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
508 {- ------------------------------------------------------------
509 Some bizarre special code for getting condition codes into
510 registers. Integer non-equality is a test for equality
511 followed by an XOR with 1. (Integer comparisons always set
512 the result register to 0 or 1.) Floating point comparisons of
513 any kind leave the result in a floating point register, so we
514 need to wrangle an integer register out of things.
516 int_NE_code :: StixTree -> StixTree -> NatM Register
519 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
520 getNewRegNCG IntRep `thenNat` \ tmp ->
522 code = registerCode register tmp
523 src = registerName register tmp
524 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
526 returnNat (Any IntRep code__2)
528 {- ------------------------------------------------------------
529 Comments for int_NE_code also apply to cmpF_code
532 :: (Reg -> Reg -> Reg -> Instr)
534 -> StixTree -> StixTree
537 cmpF_code instr cond x y
538 = trivialFCode pr instr x y `thenNat` \ register ->
539 getNewRegNCG DoubleRep `thenNat` \ tmp ->
540 getNatLabelNCG `thenNat` \ lbl ->
542 code = registerCode register tmp
543 result = registerName register tmp
545 code__2 dst = code . mkSeqInstrs [
546 OR zeroh (RIImm (ImmInt 1)) dst,
547 BF cond result (ImmCLbl lbl),
548 OR zeroh (RIReg zeroh) dst,
551 returnNat (Any IntRep code__2)
553 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
554 ------------------------------------------------------------
556 getRegister (StInd pk mem)
557 = getAmode mem `thenNat` \ amode ->
559 code = amodeCode amode
560 src = amodeAddr amode
561 size = primRepToSize pk
562 code__2 dst = code . mkSeqInstr (LD size dst src)
564 returnNat (Any pk code__2)
566 getRegister (StInt i)
569 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
571 returnNat (Any IntRep code)
574 code dst = mkSeqInstr (LDI Q dst src)
576 returnNat (Any IntRep code)
578 src = ImmInt (fromInteger i)
583 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
585 returnNat (Any PtrRep code)
588 imm__2 = case imm of Just x -> x
590 #endif {- alpha_TARGET_ARCH -}
591 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
594 getRegister (StFloat f)
595 = getNatLabelNCG `thenNat` \ lbl ->
596 let code dst = toOL [
601 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
604 returnNat (Any FloatRep code)
607 getRegister (StDouble d)
610 = let code dst = unitOL (GLDZ dst)
611 in returnNat (Any DoubleRep code)
614 = let code dst = unitOL (GLD1 dst)
615 in returnNat (Any DoubleRep code)
618 = getNatLabelNCG `thenNat` \ lbl ->
619 let code dst = toOL [
622 DATA DF [ImmDouble d],
624 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
627 returnNat (Any DoubleRep code)
629 -- Calculate the offset for (i+1) words above the _initial_
630 -- %esp value by first determining the current offset of it.
631 getRegister (StScratchWord i)
633 = getDeltaNat `thenNat` \ current_stack_offset ->
634 let j = i+1 - (current_stack_offset `div` 4)
636 = unitOL (LEA L (OpAddr (spRel j)) (OpReg dst))
638 returnNat (Any PtrRep code)
640 getRegister (StPrim primop [x]) -- unary PrimOps
642 IntNegOp -> trivialUCode (NEGI L) x
643 NotOp -> trivialUCode (NOT L) x
645 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
646 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
648 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
649 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
651 FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
652 DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
654 FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
655 DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
657 FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
658 DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
660 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
661 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
663 OrdOp -> coerceIntCode IntRep x
666 Float2IntOp -> coerceFP2Int x
667 Int2FloatOp -> coerceInt2FP FloatRep x
668 Double2IntOp -> coerceFP2Int x
669 Int2DoubleOp -> coerceInt2FP DoubleRep x
672 getRegister (StCall fn cCallConv DoubleRep [x])
676 FloatExpOp -> (True, SLIT("exp"))
677 FloatLogOp -> (True, SLIT("log"))
679 FloatAsinOp -> (True, SLIT("asin"))
680 FloatAcosOp -> (True, SLIT("acos"))
681 FloatAtanOp -> (True, SLIT("atan"))
683 FloatSinhOp -> (True, SLIT("sinh"))
684 FloatCoshOp -> (True, SLIT("cosh"))
685 FloatTanhOp -> (True, SLIT("tanh"))
687 DoubleExpOp -> (False, SLIT("exp"))
688 DoubleLogOp -> (False, SLIT("log"))
690 DoubleAsinOp -> (False, SLIT("asin"))
691 DoubleAcosOp -> (False, SLIT("acos"))
692 DoubleAtanOp -> (False, SLIT("atan"))
694 DoubleSinhOp -> (False, SLIT("sinh"))
695 DoubleCoshOp -> (False, SLIT("cosh"))
696 DoubleTanhOp -> (False, SLIT("tanh"))
699 -> pprPanic "getRegister(x86,unary primop)"
700 (pprStixTree (StPrim primop [x]))
702 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
704 CharGtOp -> condIntReg GTT x y
705 CharGeOp -> condIntReg GE x y
706 CharEqOp -> condIntReg EQQ x y
707 CharNeOp -> condIntReg NE x y
708 CharLtOp -> condIntReg LTT x y
709 CharLeOp -> condIntReg LE x y
711 IntGtOp -> condIntReg GTT x y
712 IntGeOp -> condIntReg GE x y
713 IntEqOp -> condIntReg EQQ x y
714 IntNeOp -> condIntReg NE x y
715 IntLtOp -> condIntReg LTT x y
716 IntLeOp -> condIntReg LE x y
718 WordGtOp -> condIntReg GU x y
719 WordGeOp -> condIntReg GEU x y
720 WordEqOp -> condIntReg EQQ x y
721 WordNeOp -> condIntReg NE x y
722 WordLtOp -> condIntReg LU x y
723 WordLeOp -> condIntReg LEU x y
725 AddrGtOp -> condIntReg GU x y
726 AddrGeOp -> condIntReg GEU x y
727 AddrEqOp -> condIntReg EQQ x y
728 AddrNeOp -> condIntReg NE x y
729 AddrLtOp -> condIntReg LU x y
730 AddrLeOp -> condIntReg LEU x y
732 FloatGtOp -> condFltReg GTT x y
733 FloatGeOp -> condFltReg GE x y
734 FloatEqOp -> condFltReg EQQ x y
735 FloatNeOp -> condFltReg NE x y
736 FloatLtOp -> condFltReg LTT x y
737 FloatLeOp -> condFltReg LE x y
739 DoubleGtOp -> condFltReg GTT x y
740 DoubleGeOp -> condFltReg GE x y
741 DoubleEqOp -> condFltReg EQQ x y
742 DoubleNeOp -> condFltReg NE x y
743 DoubleLtOp -> condFltReg LTT x y
744 DoubleLeOp -> condFltReg LE x y
746 IntAddOp -> add_code L x y
747 IntSubOp -> sub_code L x y
748 IntQuotOp -> trivialCode (IQUOT L) Nothing x y
749 IntRemOp -> trivialCode (IREM L) Nothing x y
750 IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
752 FloatAddOp -> trivialFCode FloatRep GADD x y
753 FloatSubOp -> trivialFCode FloatRep GSUB x y
754 FloatMulOp -> trivialFCode FloatRep GMUL x y
755 FloatDivOp -> trivialFCode FloatRep GDIV x y
757 DoubleAddOp -> trivialFCode DoubleRep GADD x y
758 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
759 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
760 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
762 AndOp -> let op = AND L in trivialCode op (Just op) x y
763 OrOp -> let op = OR L in trivialCode op (Just op) x y
764 XorOp -> let op = XOR L in trivialCode op (Just op) x y
766 {- Shift ops on x86s have constraints on their source, it
767 either has to be Imm, CL or 1
768 => trivialCode's is not restrictive enough (sigh.)
771 SllOp -> shift_code (SHL L) x y {-False-}
772 SrlOp -> shift_code (SHR L) x y {-False-}
773 ISllOp -> shift_code (SHL L) x y {-False-}
774 ISraOp -> shift_code (SAR L) x y {-False-}
775 ISrlOp -> shift_code (SHR L) x y {-False-}
777 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
778 [promote x, promote y])
779 where promote x = StPrim Float2DoubleOp [x]
780 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
783 -> pprPanic "getRegister(x86,dyadic primop)"
784 (pprStixTree (StPrim primop [x, y]))
788 shift_code :: (Imm -> Operand -> Instr)
793 {- Case1: shift length as immediate -}
794 -- Code is the same as the first eq. for trivialCode -- sigh.
795 shift_code instr x y{-amount-}
797 = getRegister x `thenNat` \ regx ->
800 then registerCodeA regx dst `bind` \ code_x ->
802 instr imm__2 (OpReg dst)
803 else registerCodeF regx `bind` \ code_x ->
804 registerNameF regx `bind` \ r_x ->
806 MOV L (OpReg r_x) (OpReg dst) `snocOL`
807 instr imm__2 (OpReg dst)
809 returnNat (Any IntRep mkcode)
812 imm__2 = case imm of Just x -> x
814 {- Case2: shift length is complex (non-immediate) -}
815 -- Since ECX is always used as a spill temporary, we can't
816 -- use it here to do non-immediate shifts. No big deal --
817 -- they are only very rare, and we can use an equivalent
818 -- test-and-jump sequence which doesn't use ECX.
819 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
820 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
821 shift_code instr x y{-amount-}
822 = getRegister x `thenNat` \ register1 ->
823 getRegister y `thenNat` \ register2 ->
824 getNatLabelNCG `thenNat` \ lbl_test3 ->
825 getNatLabelNCG `thenNat` \ lbl_test2 ->
826 getNatLabelNCG `thenNat` \ lbl_test1 ->
827 getNatLabelNCG `thenNat` \ lbl_test0 ->
828 getNatLabelNCG `thenNat` \ lbl_after ->
829 getNewRegNCG IntRep `thenNat` \ tmp ->
831 = let src_val = registerName register1 dst
832 code_val = registerCode register1 dst
833 src_amt = registerName register2 tmp
834 code_amt = registerCode register2 tmp
839 MOV L (OpReg src_amt) r_tmp `appOL`
841 MOV L (OpReg src_val) r_dst `appOL`
843 COMMENT (_PK_ "begin shift sequence"),
844 MOV L (OpReg src_val) r_dst,
845 MOV L (OpReg src_amt) r_tmp,
847 BT L (ImmInt 4) r_tmp,
849 instr (ImmInt 16) r_dst,
852 BT L (ImmInt 3) r_tmp,
854 instr (ImmInt 8) r_dst,
857 BT L (ImmInt 2) r_tmp,
859 instr (ImmInt 4) r_dst,
862 BT L (ImmInt 1) r_tmp,
864 instr (ImmInt 2) r_dst,
867 BT L (ImmInt 0) r_tmp,
869 instr (ImmInt 1) r_dst,
872 COMMENT (_PK_ "end shift sequence")
875 returnNat (Any IntRep code__2)
878 add_code :: Size -> StixTree -> StixTree -> NatM Register
880 add_code sz x (StInt y)
881 = getRegister x `thenNat` \ register ->
882 getNewRegNCG IntRep `thenNat` \ tmp ->
884 code = registerCode register tmp
885 src1 = registerName register tmp
886 src2 = ImmInt (fromInteger y)
889 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
892 returnNat (Any IntRep code__2)
894 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
897 sub_code :: Size -> StixTree -> StixTree -> NatM Register
899 sub_code sz x (StInt y)
900 = getRegister x `thenNat` \ register ->
901 getNewRegNCG IntRep `thenNat` \ tmp ->
903 code = registerCode register tmp
904 src1 = registerName register tmp
905 src2 = ImmInt (-(fromInteger y))
908 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
911 returnNat (Any IntRep code__2)
913 sub_code sz x y = trivialCode (SUB sz) Nothing x y
916 getRegister (StInd pk mem)
917 = getAmode mem `thenNat` \ amode ->
919 code = amodeCode amode
920 src = amodeAddr amode
921 size = primRepToSize pk
922 code__2 dst = code `snocOL`
923 if pk == DoubleRep || pk == FloatRep
924 then GLD size src dst
926 L -> MOV L (OpAddr src) (OpReg dst)
927 BU -> MOVZxL BU (OpAddr src) (OpReg dst)
929 returnNat (Any pk code__2)
931 getRegister (StInt i)
933 src = ImmInt (fromInteger i)
936 = unitOL (XOR L (OpReg dst) (OpReg dst))
938 = unitOL (MOV L (OpImm src) (OpReg dst))
940 returnNat (Any IntRep code)
944 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
946 returnNat (Any PtrRep code)
948 = pprPanic "getRegister(x86)" (pprStixTree leaf)
951 imm__2 = case imm of Just x -> x
953 #endif {- i386_TARGET_ARCH -}
954 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
955 #if sparc_TARGET_ARCH
957 getRegister (StFloat d)
958 = getNatLabelNCG `thenNat` \ lbl ->
959 getNewRegNCG PtrRep `thenNat` \ tmp ->
960 let code dst = toOL [
965 SETHI (HI (ImmCLbl lbl)) tmp,
966 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
968 returnNat (Any FloatRep code)
970 getRegister (StDouble d)
971 = getNatLabelNCG `thenNat` \ lbl ->
972 getNewRegNCG PtrRep `thenNat` \ tmp ->
973 let code dst = toOL [
976 DATA DF [ImmDouble d],
978 SETHI (HI (ImmCLbl lbl)) tmp,
979 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
981 returnNat (Any DoubleRep code)
983 -- The 6-word scratch area is immediately below the frame pointer.
984 -- Below that is the spill area.
985 getRegister (StScratchWord i)
988 code dst = unitOL (fpRelEA (i-6) dst)
990 returnNat (Any PtrRep code)
993 getRegister (StPrim primop [x]) -- unary PrimOps
995 IntNegOp -> trivialUCode (SUB False False g0) x
996 NotOp -> trivialUCode (XNOR False g0) x
998 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
999 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
1001 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
1002 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
1004 OrdOp -> coerceIntCode IntRep x
1007 Float2IntOp -> coerceFP2Int x
1008 Int2FloatOp -> coerceInt2FP FloatRep x
1009 Double2IntOp -> coerceFP2Int x
1010 Int2DoubleOp -> coerceInt2FP DoubleRep x
1014 fixed_x = if is_float_op -- promote to double
1015 then StPrim Float2DoubleOp [x]
1018 getRegister (StCall fn cCallConv DoubleRep [fixed_x])
1022 FloatExpOp -> (True, SLIT("exp"))
1023 FloatLogOp -> (True, SLIT("log"))
1024 FloatSqrtOp -> (True, SLIT("sqrt"))
1026 FloatSinOp -> (True, SLIT("sin"))
1027 FloatCosOp -> (True, SLIT("cos"))
1028 FloatTanOp -> (True, SLIT("tan"))
1030 FloatAsinOp -> (True, SLIT("asin"))
1031 FloatAcosOp -> (True, SLIT("acos"))
1032 FloatAtanOp -> (True, SLIT("atan"))
1034 FloatSinhOp -> (True, SLIT("sinh"))
1035 FloatCoshOp -> (True, SLIT("cosh"))
1036 FloatTanhOp -> (True, SLIT("tanh"))
1038 DoubleExpOp -> (False, SLIT("exp"))
1039 DoubleLogOp -> (False, SLIT("log"))
1040 DoubleSqrtOp -> (False, SLIT("sqrt"))
1042 DoubleSinOp -> (False, SLIT("sin"))
1043 DoubleCosOp -> (False, SLIT("cos"))
1044 DoubleTanOp -> (False, SLIT("tan"))
1046 DoubleAsinOp -> (False, SLIT("asin"))
1047 DoubleAcosOp -> (False, SLIT("acos"))
1048 DoubleAtanOp -> (False, SLIT("atan"))
1050 DoubleSinhOp -> (False, SLIT("sinh"))
1051 DoubleCoshOp -> (False, SLIT("cosh"))
1052 DoubleTanhOp -> (False, SLIT("tanh"))
1055 -> pprPanic "getRegister(sparc,monadicprimop)"
1056 (pprStixTree (StPrim primop [x]))
1058 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
1060 CharGtOp -> condIntReg GTT x y
1061 CharGeOp -> condIntReg GE x y
1062 CharEqOp -> condIntReg EQQ x y
1063 CharNeOp -> condIntReg NE x y
1064 CharLtOp -> condIntReg LTT x y
1065 CharLeOp -> condIntReg LE x y
1067 IntGtOp -> condIntReg GTT x y
1068 IntGeOp -> condIntReg GE x y
1069 IntEqOp -> condIntReg EQQ x y
1070 IntNeOp -> condIntReg NE x y
1071 IntLtOp -> condIntReg LTT x y
1072 IntLeOp -> condIntReg LE x y
1074 WordGtOp -> condIntReg GU x y
1075 WordGeOp -> condIntReg GEU x y
1076 WordEqOp -> condIntReg EQQ x y
1077 WordNeOp -> condIntReg NE x y
1078 WordLtOp -> condIntReg LU x y
1079 WordLeOp -> condIntReg LEU x y
1081 AddrGtOp -> condIntReg GU x y
1082 AddrGeOp -> condIntReg GEU x y
1083 AddrEqOp -> condIntReg EQQ x y
1084 AddrNeOp -> condIntReg NE x y
1085 AddrLtOp -> condIntReg LU x y
1086 AddrLeOp -> condIntReg LEU x y
1088 FloatGtOp -> condFltReg GTT x y
1089 FloatGeOp -> condFltReg GE x y
1090 FloatEqOp -> condFltReg EQQ x y
1091 FloatNeOp -> condFltReg NE x y
1092 FloatLtOp -> condFltReg LTT x y
1093 FloatLeOp -> condFltReg LE x y
1095 DoubleGtOp -> condFltReg GTT x y
1096 DoubleGeOp -> condFltReg GE x y
1097 DoubleEqOp -> condFltReg EQQ x y
1098 DoubleNeOp -> condFltReg NE x y
1099 DoubleLtOp -> condFltReg LTT x y
1100 DoubleLeOp -> condFltReg LE x y
1102 IntAddOp -> trivialCode (ADD False False) x y
1103 IntSubOp -> trivialCode (SUB False False) x y
1105 -- ToDo: teach about V8+ SPARC mul/div instructions
1106 IntMulOp -> imul_div SLIT(".umul") x y
1107 IntQuotOp -> imul_div SLIT(".div") x y
1108 IntRemOp -> imul_div SLIT(".rem") x y
1110 FloatAddOp -> trivialFCode FloatRep FADD x y
1111 FloatSubOp -> trivialFCode FloatRep FSUB x y
1112 FloatMulOp -> trivialFCode FloatRep FMUL x y
1113 FloatDivOp -> trivialFCode FloatRep FDIV x y
1115 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1116 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1117 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1118 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1120 AndOp -> trivialCode (AND False) x y
1121 OrOp -> trivialCode (OR False) x y
1122 XorOp -> trivialCode (XOR False) x y
1123 SllOp -> trivialCode SLL x y
1124 SrlOp -> trivialCode SRL x y
1126 ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
1127 ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
1128 ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
1130 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1131 [promote x, promote y])
1132 where promote x = StPrim Float2DoubleOp [x]
1133 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1137 -> pprPanic "getRegister(sparc,dyadic primop)"
1138 (pprStixTree (StPrim primop [x, y]))
1141 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1143 getRegister (StInd pk mem)
1144 = getAmode mem `thenNat` \ amode ->
1146 code = amodeCode amode
1147 src = amodeAddr amode
1148 size = primRepToSize pk
1149 code__2 dst = code `snocOL` LD size src dst
1151 returnNat (Any pk code__2)
1153 getRegister (StInt i)
1156 src = ImmInt (fromInteger i)
1157 code dst = unitOL (OR False g0 (RIImm src) dst)
1159 returnNat (Any IntRep code)
1165 SETHI (HI imm__2) dst,
1166 OR False dst (RIImm (LO imm__2)) dst]
1168 returnNat (Any PtrRep code)
1170 = pprPanic "getRegister(sparc)" (pprStixTree leaf)
1173 imm__2 = case imm of Just x -> x
1175 #endif {- sparc_TARGET_ARCH -}
1178 %************************************************************************
1180 \subsection{The @Amode@ type}
1182 %************************************************************************
1184 @Amode@s: Memory addressing modes passed up the tree.
1186 data Amode = Amode MachRegsAddr InstrBlock
1188 amodeAddr (Amode addr _) = addr
1189 amodeCode (Amode _ code) = code
1192 Now, given a tree (the argument to an StInd) that references memory,
1193 produce a suitable addressing mode.
1195 A Rule of the Game (tm) for Amodes: use of the addr bit must
1196 immediately follow use of the code part, since the code part puts
1197 values in registers which the addr then refers to. So you can't put
1198 anything in between, lest it overwrite some of those registers. If
1199 you need to do some other computation between the code part and use of
1200 the addr bit, first store the effective address from the amode in a
1201 temporary, then do the other computation, and then use the temporary:
1205 ... other computation ...
1209 getAmode :: StixTree -> NatM Amode
1211 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1213 #if alpha_TARGET_ARCH
1215 getAmode (StPrim IntSubOp [x, StInt i])
1216 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1217 getRegister x `thenNat` \ register ->
1219 code = registerCode register tmp
1220 reg = registerName register tmp
1221 off = ImmInt (-(fromInteger i))
1223 returnNat (Amode (AddrRegImm reg off) code)
1225 getAmode (StPrim IntAddOp [x, StInt i])
1226 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1227 getRegister x `thenNat` \ register ->
1229 code = registerCode register tmp
1230 reg = registerName register tmp
1231 off = ImmInt (fromInteger i)
1233 returnNat (Amode (AddrRegImm reg off) code)
1237 = returnNat (Amode (AddrImm imm__2) id)
1240 imm__2 = case imm of Just x -> x
1243 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1244 getRegister other `thenNat` \ register ->
1246 code = registerCode register tmp
1247 reg = registerName register tmp
1249 returnNat (Amode (AddrReg reg) code)
1251 #endif {- alpha_TARGET_ARCH -}
1252 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1253 #if i386_TARGET_ARCH
1255 getAmode (StPrim IntSubOp [x, StInt i])
1256 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1257 getRegister x `thenNat` \ register ->
1259 code = registerCode register tmp
1260 reg = registerName register tmp
1261 off = ImmInt (-(fromInteger i))
1263 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1265 getAmode (StPrim IntAddOp [x, StInt i])
1267 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1270 imm__2 = case imm of Just x -> x
1272 getAmode (StPrim IntAddOp [x, StInt i])
1273 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1274 getRegister x `thenNat` \ register ->
1276 code = registerCode register tmp
1277 reg = registerName register tmp
1278 off = ImmInt (fromInteger i)
1280 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1282 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1283 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1284 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1285 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1286 getRegister x `thenNat` \ register1 ->
1287 getRegister y `thenNat` \ register2 ->
1289 code1 = registerCode register1 tmp1
1290 reg1 = registerName register1 tmp1
1291 code2 = registerCode register2 tmp2
1292 reg2 = registerName register2 tmp2
1293 code__2 = code1 `appOL` code2
1294 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1296 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1301 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1304 imm__2 = case imm of Just x -> x
1307 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1308 getRegister other `thenNat` \ register ->
1310 code = registerCode register tmp
1311 reg = registerName register tmp
1313 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1315 #endif {- i386_TARGET_ARCH -}
1316 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1317 #if sparc_TARGET_ARCH
1319 getAmode (StPrim IntSubOp [x, StInt i])
1321 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1322 getRegister x `thenNat` \ register ->
1324 code = registerCode register tmp
1325 reg = registerName register tmp
1326 off = ImmInt (-(fromInteger i))
1328 returnNat (Amode (AddrRegImm reg off) code)
1331 getAmode (StPrim IntAddOp [x, StInt i])
1333 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1334 getRegister x `thenNat` \ register ->
1336 code = registerCode register tmp
1337 reg = registerName register tmp
1338 off = ImmInt (fromInteger i)
1340 returnNat (Amode (AddrRegImm reg off) code)
1342 getAmode (StPrim IntAddOp [x, y])
1343 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1344 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1345 getRegister x `thenNat` \ register1 ->
1346 getRegister y `thenNat` \ register2 ->
1348 code1 = registerCode register1 tmp1
1349 reg1 = registerName register1 tmp1
1350 code2 = registerCode register2 tmp2
1351 reg2 = registerName register2 tmp2
1352 code__2 = code1 `appOL` code2
1354 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1358 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1360 code = unitOL (SETHI (HI imm__2) tmp)
1362 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1365 imm__2 = case imm of Just x -> x
1368 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1369 getRegister other `thenNat` \ register ->
1371 code = registerCode register tmp
1372 reg = registerName register tmp
1375 returnNat (Amode (AddrRegImm reg off) code)
1377 #endif {- sparc_TARGET_ARCH -}
1380 %************************************************************************
1382 \subsection{The @CondCode@ type}
1384 %************************************************************************
1386 Condition codes passed up the tree.
1388 data CondCode = CondCode Bool Cond InstrBlock
1390 condName (CondCode _ cond _) = cond
1391 condFloat (CondCode is_float _ _) = is_float
1392 condCode (CondCode _ _ code) = code
1395 Set up a condition code for a conditional branch.
1398 getCondCode :: StixTree -> NatM CondCode
1400 #if alpha_TARGET_ARCH
1401 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1402 #endif {- alpha_TARGET_ARCH -}
1403 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1405 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1406 -- yes, they really do seem to want exactly the same!
1408 getCondCode (StPrim primop [x, y])
1410 CharGtOp -> condIntCode GTT x y
1411 CharGeOp -> condIntCode GE x y
1412 CharEqOp -> condIntCode EQQ x y
1413 CharNeOp -> condIntCode NE x y
1414 CharLtOp -> condIntCode LTT x y
1415 CharLeOp -> condIntCode LE x y
1417 IntGtOp -> condIntCode GTT x y
1418 IntGeOp -> condIntCode GE x y
1419 IntEqOp -> condIntCode EQQ x y
1420 IntNeOp -> condIntCode NE x y
1421 IntLtOp -> condIntCode LTT x y
1422 IntLeOp -> condIntCode LE x y
1424 WordGtOp -> condIntCode GU x y
1425 WordGeOp -> condIntCode GEU x y
1426 WordEqOp -> condIntCode EQQ x y
1427 WordNeOp -> condIntCode NE x y
1428 WordLtOp -> condIntCode LU x y
1429 WordLeOp -> condIntCode LEU x y
1431 AddrGtOp -> condIntCode GU x y
1432 AddrGeOp -> condIntCode GEU x y
1433 AddrEqOp -> condIntCode EQQ x y
1434 AddrNeOp -> condIntCode NE x y
1435 AddrLtOp -> condIntCode LU x y
1436 AddrLeOp -> condIntCode LEU x y
1438 FloatGtOp -> condFltCode GTT x y
1439 FloatGeOp -> condFltCode GE x y
1440 FloatEqOp -> condFltCode EQQ x y
1441 FloatNeOp -> condFltCode NE x y
1442 FloatLtOp -> condFltCode LTT x y
1443 FloatLeOp -> condFltCode LE x y
1445 DoubleGtOp -> condFltCode GTT x y
1446 DoubleGeOp -> condFltCode GE x y
1447 DoubleEqOp -> condFltCode EQQ x y
1448 DoubleNeOp -> condFltCode NE x y
1449 DoubleLtOp -> condFltCode LTT x y
1450 DoubleLeOp -> condFltCode LE x y
1452 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1457 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1458 passed back up the tree.
1461 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1463 #if alpha_TARGET_ARCH
1464 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1465 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1466 #endif {- alpha_TARGET_ARCH -}
1468 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1469 #if i386_TARGET_ARCH
1471 -- memory vs immediate
1472 condIntCode cond (StInd pk x) y
1474 = getAmode x `thenNat` \ amode ->
1476 code1 = amodeCode amode
1477 x__2 = amodeAddr amode
1478 sz = primRepToSize pk
1479 code__2 = code1 `snocOL`
1480 CMP sz (OpImm imm__2) (OpAddr x__2)
1482 returnNat (CondCode False cond code__2)
1485 imm__2 = case imm of Just x -> x
1488 condIntCode cond x (StInt 0)
1489 = getRegister x `thenNat` \ register1 ->
1490 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1492 code1 = registerCode register1 tmp1
1493 src1 = registerName register1 tmp1
1494 code__2 = code1 `snocOL`
1495 TEST L (OpReg src1) (OpReg src1)
1497 returnNat (CondCode False cond code__2)
1499 -- anything vs immediate
1500 condIntCode cond x y
1502 = getRegister x `thenNat` \ register1 ->
1503 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1505 code1 = registerCode register1 tmp1
1506 src1 = registerName register1 tmp1
1507 code__2 = code1 `snocOL`
1508 CMP L (OpImm imm__2) (OpReg src1)
1510 returnNat (CondCode False cond code__2)
1513 imm__2 = case imm of Just x -> x
1515 -- memory vs anything
1516 condIntCode cond (StInd pk x) y
1517 = getAmode x `thenNat` \ amode_x ->
1518 getRegister y `thenNat` \ reg_y ->
1519 getNewRegNCG IntRep `thenNat` \ tmp ->
1521 c_x = amodeCode amode_x
1522 am_x = amodeAddr amode_x
1523 c_y = registerCode reg_y tmp
1524 r_y = registerName reg_y tmp
1525 sz = primRepToSize pk
1527 -- optimisation: if there's no code for x, just an amode,
1528 -- use whatever reg y winds up in. Assumes that c_y doesn't
1529 -- clobber any regs in the amode am_x, which I'm not sure is
1530 -- justified. The otherwise clause makes the same assumption.
1531 code__2 | isNilOL c_x
1533 CMP sz (OpReg r_y) (OpAddr am_x)
1537 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1539 CMP sz (OpReg tmp) (OpAddr am_x)
1541 returnNat (CondCode False cond code__2)
1543 -- anything vs memory
1545 condIntCode cond y (StInd pk x)
1546 = getAmode x `thenNat` \ amode_x ->
1547 getRegister y `thenNat` \ reg_y ->
1548 getNewRegNCG IntRep `thenNat` \ tmp ->
1550 c_x = amodeCode amode_x
1551 am_x = amodeAddr amode_x
1552 c_y = registerCode reg_y tmp
1553 r_y = registerName reg_y tmp
1554 sz = primRepToSize pk
1555 -- same optimisation and nagging doubts as previous clause
1556 code__2 | isNilOL c_x
1558 CMP sz (OpAddr am_x) (OpReg r_y)
1562 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1564 CMP sz (OpAddr am_x) (OpReg tmp)
1566 returnNat (CondCode False cond code__2)
1568 -- anything vs anything
1569 condIntCode cond x y
1570 = getRegister x `thenNat` \ register1 ->
1571 getRegister y `thenNat` \ register2 ->
1572 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1573 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1575 code1 = registerCode register1 tmp1
1576 src1 = registerName register1 tmp1
1577 code2 = registerCode register2 tmp2
1578 src2 = registerName register2 tmp2
1579 code__2 = code1 `snocOL`
1580 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1582 CMP L (OpReg src2) (OpReg tmp1)
1584 returnNat (CondCode False cond code__2)
1587 condFltCode cond x y
1588 = getRegister x `thenNat` \ register1 ->
1589 getRegister y `thenNat` \ register2 ->
1590 getNewRegNCG (registerRep register1)
1592 getNewRegNCG (registerRep register2)
1594 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1596 pk1 = registerRep register1
1597 code1 = registerCode register1 tmp1
1598 src1 = registerName register1 tmp1
1600 code2 = registerCode register2 tmp2
1601 src2 = registerName register2 tmp2
1603 code__2 | isAny register1
1604 = code1 `appOL` -- result in tmp1
1606 GCMP (primRepToSize pk1) tmp1 src2
1610 GMOV src1 tmp1 `appOL`
1612 GCMP (primRepToSize pk1) tmp1 src2
1614 {- On the 486, the flags set by FP compare are the unsigned ones!
1615 (This looks like a HACK to me. WDP 96/03)
1617 fix_FP_cond :: Cond -> Cond
1619 fix_FP_cond GE = GEU
1620 fix_FP_cond GTT = GU
1621 fix_FP_cond LTT = LU
1622 fix_FP_cond LE = LEU
1623 fix_FP_cond any = any
1625 returnNat (CondCode True (fix_FP_cond cond) code__2)
1629 #endif {- i386_TARGET_ARCH -}
1630 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1631 #if sparc_TARGET_ARCH
1633 condIntCode cond x (StInt y)
1635 = getRegister x `thenNat` \ register ->
1636 getNewRegNCG IntRep `thenNat` \ tmp ->
1638 code = registerCode register tmp
1639 src1 = registerName register tmp
1640 src2 = ImmInt (fromInteger y)
1641 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1643 returnNat (CondCode False cond code__2)
1645 condIntCode cond x y
1646 = getRegister x `thenNat` \ register1 ->
1647 getRegister y `thenNat` \ register2 ->
1648 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1649 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1651 code1 = registerCode register1 tmp1
1652 src1 = registerName register1 tmp1
1653 code2 = registerCode register2 tmp2
1654 src2 = registerName register2 tmp2
1655 code__2 = code1 `appOL` code2 `snocOL`
1656 SUB False True src1 (RIReg src2) g0
1658 returnNat (CondCode False cond code__2)
1661 condFltCode cond x y
1662 = getRegister x `thenNat` \ register1 ->
1663 getRegister y `thenNat` \ register2 ->
1664 getNewRegNCG (registerRep register1)
1666 getNewRegNCG (registerRep register2)
1668 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1670 promote x = FxTOy F DF x tmp
1672 pk1 = registerRep register1
1673 code1 = registerCode register1 tmp1
1674 src1 = registerName register1 tmp1
1676 pk2 = registerRep register2
1677 code2 = registerCode register2 tmp2
1678 src2 = registerName register2 tmp2
1682 code1 `appOL` code2 `snocOL`
1683 FCMP True (primRepToSize pk1) src1 src2
1684 else if pk1 == FloatRep then
1685 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1686 FCMP True DF tmp src2
1688 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1689 FCMP True DF src1 tmp
1691 returnNat (CondCode True cond code__2)
1693 #endif {- sparc_TARGET_ARCH -}
1696 %************************************************************************
1698 \subsection{Generating assignments}
1700 %************************************************************************
1702 Assignments are really at the heart of the whole code generation
1703 business. Almost all top-level nodes of any real importance are
1704 assignments, which correspond to loads, stores, or register transfers.
1705 If we're really lucky, some of the register transfers will go away,
1706 because we can use the destination register to complete the code
1707 generation for the right hand side. This only fails when the right
1708 hand side is forced into a fixed register (e.g. the result of a call).
1711 assignIntCode, assignFltCode
1712 :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1714 #if alpha_TARGET_ARCH
1716 assignIntCode pk (StInd _ dst) src
1717 = getNewRegNCG IntRep `thenNat` \ tmp ->
1718 getAmode dst `thenNat` \ amode ->
1719 getRegister src `thenNat` \ register ->
1721 code1 = amodeCode amode []
1722 dst__2 = amodeAddr amode
1723 code2 = registerCode register tmp []
1724 src__2 = registerName register tmp
1725 sz = primRepToSize pk
1726 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1730 assignIntCode pk dst src
1731 = getRegister dst `thenNat` \ register1 ->
1732 getRegister src `thenNat` \ register2 ->
1734 dst__2 = registerName register1 zeroh
1735 code = registerCode register2 dst__2
1736 src__2 = registerName register2 dst__2
1737 code__2 = if isFixed register2
1738 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1743 #endif {- alpha_TARGET_ARCH -}
1744 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1745 #if i386_TARGET_ARCH
1747 -- Destination of an assignment can only be reg or mem.
1748 -- This is the mem case.
1749 assignIntCode pk (StInd _ dst) src
1750 = getAmode dst `thenNat` \ amode ->
1751 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
1752 getNewRegNCG PtrRep `thenNat` \ tmp ->
1754 -- In general, if the address computation for dst may require
1755 -- some insns preceding the addressing mode itself. So there's
1756 -- no guarantee that the code for dst and the code for src won't
1757 -- write the same register. This means either the address or
1758 -- the value needs to be copied into a temporary. We detect the
1759 -- common case where the amode has no code, and elide the copy.
1760 codea = amodeCode amode
1761 dst__a = amodeAddr amode
1763 code | isNilOL codea
1765 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1769 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1771 MOV (primRepToSize pk) opsrc
1772 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1778 -> NatM (InstrBlock,Operand) -- code, operator
1782 = returnNat (nilOL, OpImm imm_op)
1785 imm_op = case imm of Just x -> x
1788 = getRegister op `thenNat` \ register ->
1789 getNewRegNCG (registerRep register)
1791 let code = registerCode register tmp
1792 reg = registerName register tmp
1794 returnNat (code, OpReg reg)
1796 -- Assign; dst is a reg, rhs is mem
1797 assignIntCode pk dst (StInd pks src)
1798 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1799 getAmode src `thenNat` \ amode ->
1800 getRegister dst `thenNat` \ reg_dst ->
1802 c_addr = amodeCode amode
1803 am_addr = amodeAddr amode
1805 c_dst = registerCode reg_dst tmp -- should be empty
1806 r_dst = registerName reg_dst tmp
1807 szs = primRepToSize pks
1808 opc = case szs of L -> MOV L ; BU -> MOVZxL BU
1810 code | isNilOL c_dst
1812 opc (OpAddr am_addr) (OpReg r_dst)
1814 = pprPanic "assignIntCode(x86): bad dst(2)" empty
1818 -- dst is a reg, but src could be anything
1819 assignIntCode pk dst src
1820 = getRegister dst `thenNat` \ registerd ->
1821 getRegister src `thenNat` \ registers ->
1822 getNewRegNCG IntRep `thenNat` \ tmp ->
1824 r_dst = registerName registerd tmp
1825 c_dst = registerCode registerd tmp -- should be empty
1826 r_src = registerName registers r_dst
1827 c_src = registerCode registers r_dst
1829 code | isNilOL c_dst
1831 MOV L (OpReg r_src) (OpReg r_dst)
1833 = pprPanic "assignIntCode(x86): bad dst(3)" empty
1837 #endif {- i386_TARGET_ARCH -}
1838 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1839 #if sparc_TARGET_ARCH
1841 assignIntCode pk (StInd _ dst) src
1842 = getNewRegNCG IntRep `thenNat` \ tmp ->
1843 getAmode dst `thenNat` \ amode ->
1844 getRegister src `thenNat` \ register ->
1846 code1 = amodeCode amode
1847 dst__2 = amodeAddr amode
1848 code2 = registerCode register tmp
1849 src__2 = registerName register tmp
1850 sz = primRepToSize pk
1851 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
1855 assignIntCode pk dst src
1856 = getRegister dst `thenNat` \ register1 ->
1857 getRegister src `thenNat` \ register2 ->
1859 dst__2 = registerName register1 g0
1860 code = registerCode register2 dst__2
1861 src__2 = registerName register2 dst__2
1862 code__2 = if isFixed register2
1863 then code `snocOL` OR False g0 (RIReg src__2) dst__2
1868 #endif {- sparc_TARGET_ARCH -}
1871 % --------------------------------
1872 Floating-point assignments:
1873 % --------------------------------
1875 #if alpha_TARGET_ARCH
1877 assignFltCode pk (StInd _ dst) src
1878 = getNewRegNCG pk `thenNat` \ tmp ->
1879 getAmode dst `thenNat` \ amode ->
1880 getRegister src `thenNat` \ register ->
1882 code1 = amodeCode amode []
1883 dst__2 = amodeAddr amode
1884 code2 = registerCode register tmp []
1885 src__2 = registerName register tmp
1886 sz = primRepToSize pk
1887 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1891 assignFltCode pk dst src
1892 = getRegister dst `thenNat` \ register1 ->
1893 getRegister src `thenNat` \ register2 ->
1895 dst__2 = registerName register1 zeroh
1896 code = registerCode register2 dst__2
1897 src__2 = registerName register2 dst__2
1898 code__2 = if isFixed register2
1899 then code . mkSeqInstr (FMOV src__2 dst__2)
1904 #endif {- alpha_TARGET_ARCH -}
1905 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1906 #if i386_TARGET_ARCH
1909 assignFltCode pk (StInd pk_dst addr) src
1911 = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
1913 = getRegister src `thenNat` \ reg_src ->
1914 getRegister addr `thenNat` \ reg_addr ->
1915 getNewRegNCG pk `thenNat` \ tmp_src ->
1916 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
1917 let r_src = registerName reg_src tmp_src
1918 c_src = registerCode reg_src tmp_src
1919 r_addr = registerName reg_addr tmp_addr
1920 c_addr = registerCode reg_addr tmp_addr
1921 sz = primRepToSize pk
1923 code = c_src `appOL`
1924 -- no need to preserve r_src across the addr computation,
1925 -- since r_src must be a float reg
1926 -- whilst r_addr is an int reg
1929 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1933 -- dst must be a (FP) register
1934 assignFltCode pk dst src
1935 = getRegister dst `thenNat` \ reg_dst ->
1936 getRegister src `thenNat` \ reg_src ->
1937 getNewRegNCG pk `thenNat` \ tmp ->
1939 r_dst = registerName reg_dst tmp
1940 c_dst = registerCode reg_dst tmp -- should be empty
1942 r_src = registerName reg_src r_dst
1943 c_src = registerCode reg_src r_dst
1945 code | isNilOL c_dst
1946 = if isFixed reg_src
1947 then c_src `snocOL` GMOV r_src r_dst
1950 = pprPanic "assignFltCode(x86): lhs is not mem or reg"
1956 #endif {- i386_TARGET_ARCH -}
1957 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1958 #if sparc_TARGET_ARCH
1960 assignFltCode pk (StInd _ dst) src
1961 = getNewRegNCG pk `thenNat` \ tmp1 ->
1962 getAmode dst `thenNat` \ amode ->
1963 getRegister src `thenNat` \ register ->
1965 sz = primRepToSize pk
1966 dst__2 = amodeAddr amode
1968 code1 = amodeCode amode
1969 code2 = registerCode register tmp1
1971 src__2 = registerName register tmp1
1972 pk__2 = registerRep register
1973 sz__2 = primRepToSize pk__2
1975 code__2 = code1 `appOL` code2 `appOL`
1977 then unitOL (ST sz src__2 dst__2)
1978 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1982 assignFltCode pk dst src
1983 = getRegister dst `thenNat` \ register1 ->
1984 getRegister src `thenNat` \ register2 ->
1986 pk__2 = registerRep register2
1987 sz__2 = primRepToSize pk__2
1989 getNewRegNCG pk__2 `thenNat` \ tmp ->
1991 sz = primRepToSize pk
1992 dst__2 = registerName register1 g0 -- must be Fixed
1995 reg__2 = if pk /= pk__2 then tmp else dst__2
1997 code = registerCode register2 reg__2
1999 src__2 = registerName register2 reg__2
2003 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2004 else if isFixed register2 then
2005 code `snocOL` FMOV sz src__2 dst__2
2011 #endif {- sparc_TARGET_ARCH -}
2014 %************************************************************************
2016 \subsection{Generating an unconditional branch}
2018 %************************************************************************
2020 We accept two types of targets: an immediate CLabel or a tree that
2021 gets evaluated into a register. Any CLabels which are AsmTemporaries
2022 are assumed to be in the local block of code, close enough for a
2023 branch instruction. Other CLabels are assumed to be far away.
2025 (If applicable) Do not fill the delay slots here; you will confuse the
2029 genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
2031 #if alpha_TARGET_ARCH
2033 genJump (StCLbl lbl)
2034 | isAsmTemp lbl = returnInstr (BR target)
2035 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2037 target = ImmCLbl lbl
2040 = getRegister tree `thenNat` \ register ->
2041 getNewRegNCG PtrRep `thenNat` \ tmp ->
2043 dst = registerName register pv
2044 code = registerCode register pv
2045 target = registerName register pv
2047 if isFixed register then
2048 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2050 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2052 #endif {- alpha_TARGET_ARCH -}
2053 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2054 #if i386_TARGET_ARCH
2056 genJump dsts (StInd pk mem)
2057 = getAmode mem `thenNat` \ amode ->
2059 code = amodeCode amode
2060 target = amodeAddr amode
2062 returnNat (code `snocOL` JMP dsts (OpAddr target))
2066 = returnNat (unitOL (JMP dsts (OpImm target)))
2069 = getRegister tree `thenNat` \ register ->
2070 getNewRegNCG PtrRep `thenNat` \ tmp ->
2072 code = registerCode register tmp
2073 target = registerName register tmp
2075 returnNat (code `snocOL` JMP dsts (OpReg target))
2078 target = case imm of Just x -> x
2080 #endif {- i386_TARGET_ARCH -}
2081 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2082 #if sparc_TARGET_ARCH
2084 genJump dsts (StCLbl lbl)
2085 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2086 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2087 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2089 target = ImmCLbl lbl
2092 = getRegister tree `thenNat` \ register ->
2093 getNewRegNCG PtrRep `thenNat` \ tmp ->
2095 code = registerCode register tmp
2096 target = registerName register tmp
2098 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2100 #endif {- sparc_TARGET_ARCH -}
2103 %************************************************************************
2105 \subsection{Conditional jumps}
2107 %************************************************************************
2109 Conditional jumps are always to local labels, so we can use branch
2110 instructions. We peek at the arguments to decide what kind of
2113 ALPHA: For comparisons with 0, we're laughing, because we can just do
2114 the desired conditional branch.
2116 I386: First, we have to ensure that the condition
2117 codes are set according to the supplied comparison operation.
2119 SPARC: First, we have to ensure that the condition codes are set
2120 according to the supplied comparison operation. We generate slightly
2121 different code for floating point comparisons, because a floating
2122 point operation cannot directly precede a @BF@. We assume the worst
2123 and fill that slot with a @NOP@.
2125 SPARC: Do not fill the delay slots here; you will confuse the register
2130 :: CLabel -- the branch target
2131 -> StixTree -- the condition on which to branch
2134 #if alpha_TARGET_ARCH
2136 genCondJump lbl (StPrim op [x, StInt 0])
2137 = getRegister x `thenNat` \ register ->
2138 getNewRegNCG (registerRep register)
2141 code = registerCode register tmp
2142 value = registerName register tmp
2143 pk = registerRep register
2144 target = ImmCLbl lbl
2146 returnSeq code [BI (cmpOp op) value target]
2148 cmpOp CharGtOp = GTT
2150 cmpOp CharEqOp = EQQ
2152 cmpOp CharLtOp = LTT
2161 cmpOp WordGeOp = ALWAYS
2162 cmpOp WordEqOp = EQQ
2164 cmpOp WordLtOp = NEVER
2165 cmpOp WordLeOp = EQQ
2167 cmpOp AddrGeOp = ALWAYS
2168 cmpOp AddrEqOp = EQQ
2170 cmpOp AddrLtOp = NEVER
2171 cmpOp AddrLeOp = EQQ
2173 genCondJump lbl (StPrim op [x, StDouble 0.0])
2174 = getRegister x `thenNat` \ register ->
2175 getNewRegNCG (registerRep register)
2178 code = registerCode register tmp
2179 value = registerName register tmp
2180 pk = registerRep register
2181 target = ImmCLbl lbl
2183 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2185 cmpOp FloatGtOp = GTT
2186 cmpOp FloatGeOp = GE
2187 cmpOp FloatEqOp = EQQ
2188 cmpOp FloatNeOp = NE
2189 cmpOp FloatLtOp = LTT
2190 cmpOp FloatLeOp = LE
2191 cmpOp DoubleGtOp = GTT
2192 cmpOp DoubleGeOp = GE
2193 cmpOp DoubleEqOp = EQQ
2194 cmpOp DoubleNeOp = NE
2195 cmpOp DoubleLtOp = LTT
2196 cmpOp DoubleLeOp = LE
2198 genCondJump lbl (StPrim op [x, y])
2200 = trivialFCode pr instr x y `thenNat` \ register ->
2201 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2203 code = registerCode register tmp
2204 result = registerName register tmp
2205 target = ImmCLbl lbl
2207 returnNat (code . mkSeqInstr (BF cond result target))
2209 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2211 fltCmpOp op = case op of
2225 (instr, cond) = case op of
2226 FloatGtOp -> (FCMP TF LE, EQQ)
2227 FloatGeOp -> (FCMP TF LTT, EQQ)
2228 FloatEqOp -> (FCMP TF EQQ, NE)
2229 FloatNeOp -> (FCMP TF EQQ, EQQ)
2230 FloatLtOp -> (FCMP TF LTT, NE)
2231 FloatLeOp -> (FCMP TF LE, NE)
2232 DoubleGtOp -> (FCMP TF LE, EQQ)
2233 DoubleGeOp -> (FCMP TF LTT, EQQ)
2234 DoubleEqOp -> (FCMP TF EQQ, NE)
2235 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2236 DoubleLtOp -> (FCMP TF LTT, NE)
2237 DoubleLeOp -> (FCMP TF LE, NE)
2239 genCondJump lbl (StPrim op [x, y])
2240 = trivialCode instr x y `thenNat` \ register ->
2241 getNewRegNCG IntRep `thenNat` \ tmp ->
2243 code = registerCode register tmp
2244 result = registerName register tmp
2245 target = ImmCLbl lbl
2247 returnNat (code . mkSeqInstr (BI cond result target))
2249 (instr, cond) = case op of
2250 CharGtOp -> (CMP LE, EQQ)
2251 CharGeOp -> (CMP LTT, EQQ)
2252 CharEqOp -> (CMP EQQ, NE)
2253 CharNeOp -> (CMP EQQ, EQQ)
2254 CharLtOp -> (CMP LTT, NE)
2255 CharLeOp -> (CMP LE, NE)
2256 IntGtOp -> (CMP LE, EQQ)
2257 IntGeOp -> (CMP LTT, EQQ)
2258 IntEqOp -> (CMP EQQ, NE)
2259 IntNeOp -> (CMP EQQ, EQQ)
2260 IntLtOp -> (CMP LTT, NE)
2261 IntLeOp -> (CMP LE, NE)
2262 WordGtOp -> (CMP ULE, EQQ)
2263 WordGeOp -> (CMP ULT, EQQ)
2264 WordEqOp -> (CMP EQQ, NE)
2265 WordNeOp -> (CMP EQQ, EQQ)
2266 WordLtOp -> (CMP ULT, NE)
2267 WordLeOp -> (CMP ULE, NE)
2268 AddrGtOp -> (CMP ULE, EQQ)
2269 AddrGeOp -> (CMP ULT, EQQ)
2270 AddrEqOp -> (CMP EQQ, NE)
2271 AddrNeOp -> (CMP EQQ, EQQ)
2272 AddrLtOp -> (CMP ULT, NE)
2273 AddrLeOp -> (CMP ULE, NE)
2275 #endif {- alpha_TARGET_ARCH -}
2276 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2277 #if i386_TARGET_ARCH
2279 genCondJump lbl bool
2280 = getCondCode bool `thenNat` \ condition ->
2282 code = condCode condition
2283 cond = condName condition
2285 returnNat (code `snocOL` JXX cond lbl)
2287 #endif {- i386_TARGET_ARCH -}
2288 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2289 #if sparc_TARGET_ARCH
2291 genCondJump lbl bool
2292 = getCondCode bool `thenNat` \ condition ->
2294 code = condCode condition
2295 cond = condName condition
2296 target = ImmCLbl lbl
2301 if condFloat condition
2302 then [NOP, BF cond False target, NOP]
2303 else [BI cond False target, NOP]
2307 #endif {- sparc_TARGET_ARCH -}
2310 %************************************************************************
2312 \subsection{Generating C calls}
2314 %************************************************************************
2316 Now the biggest nightmare---calls. Most of the nastiness is buried in
2317 @get_arg@, which moves the arguments to the correct registers/stack
2318 locations. Apart from that, the code is easy.
2320 (If applicable) Do not fill the delay slots here; you will confuse the
2325 :: FAST_STRING -- function to call
2327 -> PrimRep -- type of the result
2328 -> [StixTree] -- arguments (of mixed type)
2331 #if alpha_TARGET_ARCH
2333 genCCall fn cconv kind args
2334 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2335 `thenNat` \ ((unused,_), argCode) ->
2337 nRegs = length allArgRegs - length unused
2338 code = asmSeqThen (map ($ []) argCode)
2341 LDA pv (AddrImm (ImmLab (ptext fn))),
2342 JSR ra (AddrReg pv) nRegs,
2343 LDGP gp (AddrReg ra)]
2345 ------------------------
2346 {- Try to get a value into a specific register (or registers) for
2347 a call. The first 6 arguments go into the appropriate
2348 argument register (separate registers for integer and floating
2349 point arguments, but used in lock-step), and the remaining
2350 arguments are dumped to the stack, beginning at 0(sp). Our
2351 first argument is a pair of the list of remaining argument
2352 registers to be assigned for this call and the next stack
2353 offset to use for overflowing arguments. This way,
2354 @get_Arg@ can be applied to all of a call's arguments using
2358 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2359 -> StixTree -- Current argument
2360 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2362 -- We have to use up all of our argument registers first...
2364 get_arg ((iDst,fDst):dsts, offset) arg
2365 = getRegister arg `thenNat` \ register ->
2367 reg = if isFloatingRep pk then fDst else iDst
2368 code = registerCode register reg
2369 src = registerName register reg
2370 pk = registerRep register
2373 if isFloatingRep pk then
2374 ((dsts, offset), if isFixed register then
2375 code . mkSeqInstr (FMOV src fDst)
2378 ((dsts, offset), if isFixed register then
2379 code . mkSeqInstr (OR src (RIReg src) iDst)
2382 -- Once we have run out of argument registers, we move to the
2385 get_arg ([], offset) arg
2386 = getRegister arg `thenNat` \ register ->
2387 getNewRegNCG (registerRep register)
2390 code = registerCode register tmp
2391 src = registerName register tmp
2392 pk = registerRep register
2393 sz = primRepToSize pk
2395 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2397 #endif {- alpha_TARGET_ARCH -}
2398 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2399 #if i386_TARGET_ARCH
2401 genCCall fn cconv kind [StInt i]
2402 | fn == SLIT ("PerformGC_wrapper")
2404 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2405 CALL (ImmLit (ptext (if underscorePrefix
2406 then (SLIT ("_PerformGC_wrapper"))
2407 else (SLIT ("PerformGC_wrapper")))))
2413 genCCall fn cconv kind args
2414 = mapNat get_call_arg
2415 (reverse args) `thenNat` \ sizes_n_codes ->
2416 getDeltaNat `thenNat` \ delta ->
2417 let (sizes, codes) = unzip sizes_n_codes
2418 tot_arg_size = sum sizes
2419 code2 = concatOL codes
2421 [CALL (fn__2 tot_arg_size)]
2423 (if cconv == stdCallConv then [] else
2424 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2426 [DELTA (delta + tot_arg_size)]
2429 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2430 returnNat (code2 `appOL` call)
2433 -- function names that begin with '.' are assumed to be special
2434 -- internally generated names like '.mul,' which don't get an
2435 -- underscore prefix
2436 -- ToDo:needed (WDP 96/03) ???
2440 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2442 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2444 stdcallsize tot_arg_size
2445 | cconv == stdCallConv = '@':show tot_arg_size
2453 get_call_arg :: StixTree{-current argument-}
2454 -> NatM (Int, InstrBlock) -- argsz, code
2457 = get_op arg `thenNat` \ (code, reg, sz) ->
2458 getDeltaNat `thenNat` \ delta ->
2459 arg_size sz `bind` \ size ->
2460 setDeltaNat (delta-size) `thenNat` \ _ ->
2461 if (case sz of DF -> True; F -> True; _ -> False)
2462 then returnNat (size,
2464 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2466 GST sz reg (AddrBaseIndex (Just esp)
2470 else returnNat (size,
2472 PUSH L (OpReg reg) `snocOL`
2478 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2481 = getRegister op `thenNat` \ register ->
2482 getNewRegNCG (registerRep register)
2485 code = registerCode register tmp
2486 reg = registerName register tmp
2487 pk = registerRep register
2488 sz = primRepToSize pk
2490 returnNat (code, reg, sz)
2492 #endif {- i386_TARGET_ARCH -}
2493 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2494 #if sparc_TARGET_ARCH
2496 The SPARC calling convention is an absolute
2497 nightmare. The first 6x32 bits of arguments are mapped into
2498 %o0 through %o5, and the remaining arguments are dumped to the
2499 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2501 If we have to put args on the stack, move %o6==%sp down by
2502 the number of words to go on the stack, to ensure there's enough space.
2504 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2505 16 words above the stack pointer is a word for the address of
2506 a structure return value. I use this as a temporary location
2507 for moving values from float to int regs. Certainly it isn't
2508 safe to put anything in the 16 words starting at %sp, since
2509 this area can get trashed at any time due to window overflows
2510 caused by signal handlers.
2512 A final complication (if the above isn't enough) is that
2513 we can't blithely calculate the arguments one by one into
2514 %o0 .. %o5. Consider the following nested calls:
2518 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2519 the inner call will itself use %o0, which trashes the value put there
2520 in preparation for the outer call. Upshot: we need to calculate the
2521 args into temporary regs, and move those to arg regs or onto the
2522 stack only immediately prior to the call proper. Sigh.
2525 genCCall fn cconv kind args
2526 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2527 let (argcodes, vregss) = unzip argcode_and_vregs
2528 argcode = concatOL argcodes
2529 vregs = concat vregss
2530 n_argRegs = length allArgRegs
2531 n_argRegs_used = min (length vregs) n_argRegs
2532 (move_sp_down, move_sp_up)
2533 = let nn = length vregs - n_argRegs
2534 + 1 -- (for the road)
2537 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2539 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2541 = unitOL (CALL fn__2 n_argRegs_used False)
2543 returnNat (argcode `appOL`
2544 move_sp_down `appOL`
2545 transfer_code `appOL`
2550 -- function names that begin with '.' are assumed to be special
2551 -- internally generated names like '.mul,' which don't get an
2552 -- underscore prefix
2553 -- ToDo:needed (WDP 96/03) ???
2554 fn__2 = case (_HEAD_ fn) of
2555 '.' -> ImmLit (ptext fn)
2556 _ -> ImmLab False (ptext fn)
2558 -- move args from the integer vregs into which they have been
2559 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2560 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2562 move_final [] _ offset -- all args done
2565 move_final (v:vs) [] offset -- out of aregs; move to stack
2566 = ST W v (spRel offset)
2567 : move_final vs [] (offset+1)
2569 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2570 = OR False g0 (RIReg v) a
2571 : move_final vs az offset
2573 -- generate code to calculate an argument, and move it into one
2574 -- or two integer vregs.
2575 arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
2576 arg_to_int_vregs arg
2577 = getRegister arg `thenNat` \ register ->
2578 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2579 let code = registerCode register tmp
2580 src = registerName register tmp
2581 pk = registerRep register
2583 -- the value is in src. Get it into 1 or 2 int vregs.
2586 getNewRegNCG WordRep `thenNat` \ v1 ->
2587 getNewRegNCG WordRep `thenNat` \ v2 ->
2590 FMOV DF src f0 `snocOL`
2591 ST F f0 (spRel 16) `snocOL`
2592 LD W (spRel 16) v1 `snocOL`
2593 ST F (fPair f0) (spRel 16) `snocOL`
2599 getNewRegNCG WordRep `thenNat` \ v1 ->
2602 ST F src (spRel 16) `snocOL`
2608 getNewRegNCG WordRep `thenNat` \ v1 ->
2610 code `snocOL` OR False g0 (RIReg src) v1
2614 #endif {- sparc_TARGET_ARCH -}
2617 %************************************************************************
2619 \subsection{Support bits}
2621 %************************************************************************
2623 %************************************************************************
2625 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2627 %************************************************************************
2629 Turn those condition codes into integers now (when they appear on
2630 the right hand side of an assignment).
2632 (If applicable) Do not fill the delay slots here; you will confuse the
2636 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2638 #if alpha_TARGET_ARCH
2639 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2640 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2641 #endif {- alpha_TARGET_ARCH -}
2643 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2644 #if i386_TARGET_ARCH
2647 = condIntCode cond x y `thenNat` \ condition ->
2648 getNewRegNCG IntRep `thenNat` \ tmp ->
2650 code = condCode condition
2651 cond = condName condition
2652 code__2 dst = code `appOL` toOL [
2653 SETCC cond (OpReg tmp),
2654 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2655 MOV L (OpReg tmp) (OpReg dst)]
2657 returnNat (Any IntRep code__2)
2660 = getNatLabelNCG `thenNat` \ lbl1 ->
2661 getNatLabelNCG `thenNat` \ lbl2 ->
2662 condFltCode cond x y `thenNat` \ condition ->
2664 code = condCode condition
2665 cond = condName condition
2666 code__2 dst = code `appOL` toOL [
2668 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2671 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2674 returnNat (Any IntRep code__2)
2676 #endif {- i386_TARGET_ARCH -}
2677 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2678 #if sparc_TARGET_ARCH
2680 condIntReg EQQ x (StInt 0)
2681 = getRegister x `thenNat` \ register ->
2682 getNewRegNCG IntRep `thenNat` \ tmp ->
2684 code = registerCode register tmp
2685 src = registerName register tmp
2686 code__2 dst = code `appOL` toOL [
2687 SUB False True g0 (RIReg src) g0,
2688 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2690 returnNat (Any IntRep code__2)
2693 = getRegister x `thenNat` \ register1 ->
2694 getRegister y `thenNat` \ register2 ->
2695 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2696 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2698 code1 = registerCode register1 tmp1
2699 src1 = registerName register1 tmp1
2700 code2 = registerCode register2 tmp2
2701 src2 = registerName register2 tmp2
2702 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2703 XOR False src1 (RIReg src2) dst,
2704 SUB False True g0 (RIReg dst) g0,
2705 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2707 returnNat (Any IntRep code__2)
2709 condIntReg NE x (StInt 0)
2710 = getRegister x `thenNat` \ register ->
2711 getNewRegNCG IntRep `thenNat` \ tmp ->
2713 code = registerCode register tmp
2714 src = registerName register tmp
2715 code__2 dst = code `appOL` toOL [
2716 SUB False True g0 (RIReg src) g0,
2717 ADD True False g0 (RIImm (ImmInt 0)) dst]
2719 returnNat (Any IntRep code__2)
2722 = getRegister x `thenNat` \ register1 ->
2723 getRegister y `thenNat` \ register2 ->
2724 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2725 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2727 code1 = registerCode register1 tmp1
2728 src1 = registerName register1 tmp1
2729 code2 = registerCode register2 tmp2
2730 src2 = registerName register2 tmp2
2731 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2732 XOR False src1 (RIReg src2) dst,
2733 SUB False True g0 (RIReg dst) g0,
2734 ADD True False g0 (RIImm (ImmInt 0)) dst]
2736 returnNat (Any IntRep code__2)
2739 = getNatLabelNCG `thenNat` \ lbl1 ->
2740 getNatLabelNCG `thenNat` \ lbl2 ->
2741 condIntCode cond x y `thenNat` \ condition ->
2743 code = condCode condition
2744 cond = condName condition
2745 code__2 dst = code `appOL` toOL [
2746 BI cond False (ImmCLbl lbl1), NOP,
2747 OR False g0 (RIImm (ImmInt 0)) dst,
2748 BI ALWAYS False (ImmCLbl lbl2), NOP,
2750 OR False g0 (RIImm (ImmInt 1)) dst,
2753 returnNat (Any IntRep code__2)
2756 = getNatLabelNCG `thenNat` \ lbl1 ->
2757 getNatLabelNCG `thenNat` \ lbl2 ->
2758 condFltCode cond x y `thenNat` \ condition ->
2760 code = condCode condition
2761 cond = condName condition
2762 code__2 dst = code `appOL` toOL [
2764 BF cond False (ImmCLbl lbl1), NOP,
2765 OR False g0 (RIImm (ImmInt 0)) dst,
2766 BI ALWAYS False (ImmCLbl lbl2), NOP,
2768 OR False g0 (RIImm (ImmInt 1)) dst,
2771 returnNat (Any IntRep code__2)
2773 #endif {- sparc_TARGET_ARCH -}
2776 %************************************************************************
2778 \subsubsection{@trivial*Code@: deal with trivial instructions}
2780 %************************************************************************
2782 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2783 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2784 for constants on the right hand side, because that's where the generic
2785 optimizer will have put them.
2787 Similarly, for unary instructions, we don't have to worry about
2788 matching an StInt as the argument, because genericOpt will already
2789 have handled the constant-folding.
2793 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2794 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2795 -> Maybe (Operand -> Operand -> Instr)
2796 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2798 -> StixTree -> StixTree -- the two arguments
2803 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2804 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2805 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2807 -> StixTree -> StixTree -- the two arguments
2811 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2812 ,IF_ARCH_i386 ((Operand -> Instr)
2813 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2815 -> StixTree -- the one argument
2820 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2821 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2822 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2824 -> StixTree -- the one argument
2827 #if alpha_TARGET_ARCH
2829 trivialCode instr x (StInt y)
2831 = getRegister x `thenNat` \ register ->
2832 getNewRegNCG IntRep `thenNat` \ tmp ->
2834 code = registerCode register tmp
2835 src1 = registerName register tmp
2836 src2 = ImmInt (fromInteger y)
2837 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2839 returnNat (Any IntRep code__2)
2841 trivialCode instr x y
2842 = getRegister x `thenNat` \ register1 ->
2843 getRegister y `thenNat` \ register2 ->
2844 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2845 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2847 code1 = registerCode register1 tmp1 []
2848 src1 = registerName register1 tmp1
2849 code2 = registerCode register2 tmp2 []
2850 src2 = registerName register2 tmp2
2851 code__2 dst = asmSeqThen [code1, code2] .
2852 mkSeqInstr (instr src1 (RIReg src2) dst)
2854 returnNat (Any IntRep code__2)
2857 trivialUCode instr x
2858 = getRegister x `thenNat` \ register ->
2859 getNewRegNCG IntRep `thenNat` \ tmp ->
2861 code = registerCode register tmp
2862 src = registerName register tmp
2863 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2865 returnNat (Any IntRep code__2)
2868 trivialFCode _ 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
2880 code__2 dst = asmSeqThen [code1 [], code2 []] .
2881 mkSeqInstr (instr src1 src2 dst)
2883 returnNat (Any DoubleRep code__2)
2885 trivialUFCode _ instr x
2886 = getRegister x `thenNat` \ register ->
2887 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2889 code = registerCode register tmp
2890 src = registerName register tmp
2891 code__2 dst = code . mkSeqInstr (instr src dst)
2893 returnNat (Any DoubleRep code__2)
2895 #endif {- alpha_TARGET_ARCH -}
2896 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2897 #if i386_TARGET_ARCH
2899 The Rules of the Game are:
2901 * You cannot assume anything about the destination register dst;
2902 it may be anything, including a fixed reg.
2904 * You may compute an operand into a fixed reg, but you may not
2905 subsequently change the contents of that fixed reg. If you
2906 want to do so, first copy the value either to a temporary
2907 or into dst. You are free to modify dst even if it happens
2908 to be a fixed reg -- that's not your problem.
2910 * You cannot assume that a fixed reg will stay live over an
2911 arbitrary computation. The same applies to the dst reg.
2913 * Temporary regs obtained from getNewRegNCG are distinct from
2914 each other and from all other regs, and stay live over
2915 arbitrary computations.
2919 trivialCode instr maybe_revinstr a b
2922 = getRegister a `thenNat` \ rega ->
2925 then registerCode rega dst `bind` \ code_a ->
2927 instr (OpImm imm_b) (OpReg dst)
2928 else registerCodeF rega `bind` \ code_a ->
2929 registerNameF rega `bind` \ r_a ->
2931 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2932 instr (OpImm imm_b) (OpReg dst)
2934 returnNat (Any IntRep mkcode)
2937 = getRegister b `thenNat` \ regb ->
2938 getNewRegNCG IntRep `thenNat` \ tmp ->
2939 let revinstr_avail = maybeToBool maybe_revinstr
2940 revinstr = case maybe_revinstr of Just ri -> ri
2944 then registerCode regb dst `bind` \ code_b ->
2946 revinstr (OpImm imm_a) (OpReg dst)
2947 else registerCodeF regb `bind` \ code_b ->
2948 registerNameF regb `bind` \ r_b ->
2950 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2951 revinstr (OpImm imm_a) (OpReg dst)
2955 then registerCode regb tmp `bind` \ code_b ->
2957 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2958 instr (OpReg tmp) (OpReg dst)
2959 else registerCodeF regb `bind` \ code_b ->
2960 registerNameF regb `bind` \ r_b ->
2962 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2963 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2964 instr (OpReg tmp) (OpReg dst)
2966 returnNat (Any IntRep mkcode)
2969 = getRegister a `thenNat` \ rega ->
2970 getRegister b `thenNat` \ regb ->
2971 getNewRegNCG IntRep `thenNat` \ tmp ->
2973 = case (isAny rega, isAny regb) of
2975 -> registerCode regb tmp `bind` \ code_b ->
2976 registerCode rega dst `bind` \ code_a ->
2979 instr (OpReg tmp) (OpReg dst)
2981 -> registerCode rega tmp `bind` \ code_a ->
2982 registerCodeF regb `bind` \ code_b ->
2983 registerNameF regb `bind` \ r_b ->
2986 instr (OpReg r_b) (OpReg tmp) `snocOL`
2987 MOV L (OpReg tmp) (OpReg dst)
2989 -> registerCode regb tmp `bind` \ code_b ->
2990 registerCodeF rega `bind` \ code_a ->
2991 registerNameF rega `bind` \ r_a ->
2994 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2995 instr (OpReg tmp) (OpReg dst)
2997 -> registerCodeF rega `bind` \ code_a ->
2998 registerNameF rega `bind` \ r_a ->
2999 registerCodeF regb `bind` \ code_b ->
3000 registerNameF regb `bind` \ r_b ->
3002 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3004 instr (OpReg r_b) (OpReg tmp) `snocOL`
3005 MOV L (OpReg tmp) (OpReg dst)
3007 returnNat (Any IntRep mkcode)
3010 maybe_imm_a = maybeImm a
3011 is_imm_a = maybeToBool maybe_imm_a
3012 imm_a = case maybe_imm_a of Just imm -> imm
3014 maybe_imm_b = maybeImm b
3015 is_imm_b = maybeToBool maybe_imm_b
3016 imm_b = case maybe_imm_b of Just imm -> imm
3020 trivialUCode instr x
3021 = getRegister x `thenNat` \ register ->
3023 code__2 dst = let code = registerCode register dst
3024 src = registerName register dst
3026 if isFixed register && dst /= src
3027 then toOL [MOV L (OpReg src) (OpReg dst),
3029 else unitOL (instr (OpReg src))
3031 returnNat (Any IntRep code__2)
3034 trivialFCode pk instr x y
3035 = getRegister x `thenNat` \ register1 ->
3036 getRegister y `thenNat` \ register2 ->
3037 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3038 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3040 code1 = registerCode register1 tmp1
3041 src1 = registerName register1 tmp1
3043 code2 = registerCode register2 tmp2
3044 src2 = registerName register2 tmp2
3047 -- treat the common case specially: both operands in
3049 | isAny register1 && isAny register2
3052 instr (primRepToSize pk) src1 src2 dst
3054 -- be paranoid (and inefficient)
3056 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3058 instr (primRepToSize pk) tmp1 src2 dst
3060 returnNat (Any pk code__2)
3064 trivialUFCode pk instr x
3065 = getRegister x `thenNat` \ register ->
3066 getNewRegNCG pk `thenNat` \ tmp ->
3068 code = registerCode register tmp
3069 src = registerName register tmp
3070 code__2 dst = code `snocOL` instr src dst
3072 returnNat (Any pk code__2)
3074 #endif {- i386_TARGET_ARCH -}
3075 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3076 #if sparc_TARGET_ARCH
3078 trivialCode instr x (StInt y)
3080 = getRegister x `thenNat` \ register ->
3081 getNewRegNCG IntRep `thenNat` \ tmp ->
3083 code = registerCode register tmp
3084 src1 = registerName register tmp
3085 src2 = ImmInt (fromInteger y)
3086 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3088 returnNat (Any IntRep code__2)
3090 trivialCode instr x y
3091 = getRegister x `thenNat` \ register1 ->
3092 getRegister y `thenNat` \ register2 ->
3093 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3094 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3096 code1 = registerCode register1 tmp1
3097 src1 = registerName register1 tmp1
3098 code2 = registerCode register2 tmp2
3099 src2 = registerName register2 tmp2
3100 code__2 dst = code1 `appOL` code2 `snocOL`
3101 instr src1 (RIReg src2) dst
3103 returnNat (Any IntRep code__2)
3106 trivialFCode pk instr x y
3107 = getRegister x `thenNat` \ register1 ->
3108 getRegister y `thenNat` \ register2 ->
3109 getNewRegNCG (registerRep register1)
3111 getNewRegNCG (registerRep register2)
3113 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3115 promote x = FxTOy F DF x tmp
3117 pk1 = registerRep register1
3118 code1 = registerCode register1 tmp1
3119 src1 = registerName register1 tmp1
3121 pk2 = registerRep register2
3122 code2 = registerCode register2 tmp2
3123 src2 = registerName register2 tmp2
3127 code1 `appOL` code2 `snocOL`
3128 instr (primRepToSize pk) src1 src2 dst
3129 else if pk1 == FloatRep then
3130 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3131 instr DF tmp src2 dst
3133 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3134 instr DF src1 tmp dst
3136 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3139 trivialUCode instr x
3140 = getRegister x `thenNat` \ register ->
3141 getNewRegNCG IntRep `thenNat` \ tmp ->
3143 code = registerCode register tmp
3144 src = registerName register tmp
3145 code__2 dst = code `snocOL` instr (RIReg src) dst
3147 returnNat (Any IntRep code__2)
3150 trivialUFCode pk instr x
3151 = getRegister x `thenNat` \ register ->
3152 getNewRegNCG pk `thenNat` \ tmp ->
3154 code = registerCode register tmp
3155 src = registerName register tmp
3156 code__2 dst = code `snocOL` instr src dst
3158 returnNat (Any pk code__2)
3160 #endif {- sparc_TARGET_ARCH -}
3163 %************************************************************************
3165 \subsubsection{Coercing to/from integer/floating-point...}
3167 %************************************************************************
3169 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3170 to be generated. Here we just change the type on the Register passed
3171 on up. The code is machine-independent.
3173 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3174 conversions. We have to store temporaries in memory to move
3175 between the integer and the floating point register sets.
3178 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3179 coerceFltCode :: StixTree -> NatM Register
3181 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3182 coerceFP2Int :: StixTree -> NatM Register
3185 = getRegister x `thenNat` \ register ->
3188 Fixed _ reg code -> Fixed pk reg code
3189 Any _ code -> Any pk code
3194 = getRegister x `thenNat` \ register ->
3197 Fixed _ reg code -> Fixed DoubleRep reg code
3198 Any _ code -> Any DoubleRep code
3203 #if alpha_TARGET_ARCH
3206 = getRegister x `thenNat` \ register ->
3207 getNewRegNCG IntRep `thenNat` \ reg ->
3209 code = registerCode register reg
3210 src = registerName register reg
3212 code__2 dst = code . mkSeqInstrs [
3214 LD TF dst (spRel 0),
3217 returnNat (Any DoubleRep code__2)
3221 = getRegister x `thenNat` \ register ->
3222 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3224 code = registerCode register tmp
3225 src = registerName register tmp
3227 code__2 dst = code . mkSeqInstrs [
3229 ST TF tmp (spRel 0),
3232 returnNat (Any IntRep code__2)
3234 #endif {- alpha_TARGET_ARCH -}
3235 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3236 #if i386_TARGET_ARCH
3239 = getRegister x `thenNat` \ register ->
3240 getNewRegNCG IntRep `thenNat` \ reg ->
3242 code = registerCode register reg
3243 src = registerName register reg
3244 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3245 code__2 dst = code `snocOL` opc src dst
3247 returnNat (Any pk code__2)
3251 = getRegister x `thenNat` \ register ->
3252 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3254 code = registerCode register tmp
3255 src = registerName register tmp
3256 pk = registerRep register
3258 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3259 code__2 dst = code `snocOL` opc src dst
3261 returnNat (Any IntRep code__2)
3263 #endif {- i386_TARGET_ARCH -}
3264 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3265 #if sparc_TARGET_ARCH
3268 = getRegister x `thenNat` \ register ->
3269 getNewRegNCG IntRep `thenNat` \ reg ->
3271 code = registerCode register reg
3272 src = registerName register reg
3274 code__2 dst = code `appOL` toOL [
3275 ST W src (spRel (-2)),
3276 LD W (spRel (-2)) dst,
3277 FxTOy W (primRepToSize pk) dst dst]
3279 returnNat (Any pk code__2)
3283 = getRegister x `thenNat` \ register ->
3284 getNewRegNCG IntRep `thenNat` \ reg ->
3285 getNewRegNCG FloatRep `thenNat` \ tmp ->
3287 code = registerCode register reg
3288 src = registerName register reg
3289 pk = registerRep register
3291 code__2 dst = code `appOL` toOL [
3292 FxTOy (primRepToSize pk) W src tmp,
3293 ST W tmp (spRel (-2)),
3294 LD W (spRel (-2)) dst]
3296 returnNat (Any IntRep code__2)
3298 #endif {- sparc_TARGET_ARCH -}
3301 %************************************************************************
3303 \subsubsection{Coercing integer to @Char@...}
3305 %************************************************************************
3307 Integer to character conversion.
3310 chrCode :: StixTree -> NatM Register
3312 #if alpha_TARGET_ARCH
3314 -- TODO: This is probably wrong, but I don't know Alpha assembler.
3315 -- It should coerce a 64-bit value to a 32-bit value.
3318 = getRegister x `thenNat` \ register ->
3319 getNewRegNCG IntRep `thenNat` \ reg ->
3321 code = registerCode register reg
3322 src = registerName register reg
3323 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3325 returnNat (Any IntRep code__2)
3327 #endif {- alpha_TARGET_ARCH -}
3328 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3329 #if i386_TARGET_ARCH
3332 = getRegister x `thenNat` \ register ->
3335 Fixed _ reg code -> Fixed IntRep reg code
3336 Any _ code -> Any IntRep code
3339 #endif {- i386_TARGET_ARCH -}
3340 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3341 #if sparc_TARGET_ARCH
3344 = getRegister x `thenNat` \ register ->
3347 Fixed _ reg code -> Fixed IntRep reg code
3348 Any _ code -> Any IntRep code
3351 #endif {- sparc_TARGET_ARCH -}