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.
96 liftStrings :: [StixTree] -- originals
97 -> [StixTree] -- (reverse) originals with strings lifted out
98 -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels
101 -- First, examine the original trees and lift out strings in top-level StDatas.
102 liftStrings (st:sts) acc_stix acc_strs
105 -> lift datas acc_strs `thenNat` \ (datas_done, acc_strs1) ->
106 liftStrings sts ((StData sz datas_done):acc_stix) acc_strs1
108 -> liftStrings sts (other:acc_stix) acc_strs
110 -- Handle a top-level StData
111 lift [] acc_strs = returnNat ([], acc_strs)
113 = lift ds acc_strs `thenNat` \ (ds_done, acc_strs1) ->
116 -> getNatLabelNCG `thenNat` \ lbl ->
117 returnNat ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
119 -> returnNat (other:ds_done, acc_strs1)
121 -- When we've run out of original trees, emit the lifted strings.
122 liftStrings [] acc_stix acc_strs
123 = returnNat (reverse acc_stix ++ concatMap f acc_strs)
125 f (lbl,str) = [StSegment RoDataSegment,
128 StSegment TextSegment]
131 stmtToInstrs :: StixTree {- a stix statement -} -> NatM InstrBlock
132 stmtToInstrs stmt = case stmt of
133 StComment s -> returnNat (unitOL (COMMENT s))
134 StSegment seg -> returnNat (unitOL (SEGMENT seg))
136 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
138 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
141 StLabel lab -> returnNat (unitOL (LABEL lab))
143 StJump dsts arg -> genJump dsts (derefDLL arg)
144 StCondJump lab arg -> genCondJump lab (derefDLL arg)
146 -- A call returning void, ie one done for its side-effects
147 StCall fn cconv VoidRep args -> genCCall fn
148 cconv VoidRep (map derefDLL args)
151 | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
152 | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
155 -- When falling through on the Alpha, we still have to load pv
156 -- with the address of the next routine, so that it can load gp.
157 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
161 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
162 returnNat (DATA (primRepToSize kind) imms
163 `consOL` concatOL codes)
165 getData :: StixTree -> NatM (InstrBlock, Imm)
166 getData (StInt i) = returnNat (nilOL, ImmInteger i)
167 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
168 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
169 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
170 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
171 -- the linker can handle simple arithmetic...
172 getData (StIndex rep (StCLbl lbl) (StInt off)) =
174 ImmIndex lbl (fromInteger (off * sizeOf rep)))
176 -- Top-level lifted-out string. The segment will already have been set
177 -- (see liftStrings above).
179 -> returnNat (unitOL (ASCII True (_UNPK_ str)))
182 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
183 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
184 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
186 derefDLL :: StixTree -> StixTree
188 | opt_Static -- short out the entire deal if not doing DLLs
195 StCLbl lbl -> if labelDynamic lbl
196 then StInd PtrRep (StCLbl lbl)
198 -- all the rest are boring
199 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
200 StPrim pk args -> StPrim pk (map qq args)
201 StInd pk addr -> StInd pk (qq addr)
202 StCall who cc pk args -> StCall who cc pk (map qq args)
209 _ -> pprPanic "derefDLL: unhandled case"
213 %************************************************************************
215 \subsection{General things for putting together code sequences}
217 %************************************************************************
220 mangleIndexTree :: StixTree -> StixTree
222 mangleIndexTree (StIndex pk base (StInt i))
223 = StPrim IntAddOp [base, off]
225 off = StInt (i * sizeOf pk)
227 mangleIndexTree (StIndex pk base off)
231 in if s == 0 then off else StPrim SllOp [off, StInt (toInteger s)]
234 shift :: PrimRep -> Int
235 shift rep = case (fromInteger (sizeOf rep) :: Int) of
240 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
245 maybeImm :: StixTree -> Maybe Imm
249 maybeImm (StIndex rep (StCLbl l) (StInt off))
250 = Just (ImmIndex l (fromInteger (off * sizeOf rep)))
252 | i >= toInteger minInt && i <= toInteger maxInt
253 = Just (ImmInt (fromInteger i))
255 = Just (ImmInteger i)
260 %************************************************************************
262 \subsection{The @Register@ type}
264 %************************************************************************
266 @Register@s passed up the tree. If the stix code forces the register
267 to live in a pre-decided machine register, it comes out as @Fixed@;
268 otherwise, it comes out as @Any@, and the parent can decide which
269 register to put it in.
273 = Fixed PrimRep Reg InstrBlock
274 | Any PrimRep (Reg -> InstrBlock)
276 registerCode :: Register -> Reg -> InstrBlock
277 registerCode (Fixed _ _ code) reg = code
278 registerCode (Any _ code) reg = code reg
280 registerCodeF (Fixed _ _ code) = code
281 registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
283 registerCodeA (Any _ code) = code
284 registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
286 registerName :: Register -> Reg -> Reg
287 registerName (Fixed _ reg _) _ = reg
288 registerName (Any _ _) reg = reg
290 registerNameF (Fixed _ reg _) = reg
291 registerNameF (Any _ _) = pprPanic "registerNameF" empty
293 registerRep :: Register -> PrimRep
294 registerRep (Fixed pk _ _) = pk
295 registerRep (Any pk _) = pk
297 {-# INLINE registerCode #-}
298 {-# INLINE registerCodeF #-}
299 {-# INLINE registerName #-}
300 {-# INLINE registerNameF #-}
301 {-# INLINE registerRep #-}
302 {-# INLINE isFixed #-}
305 isFixed, isAny :: Register -> Bool
306 isFixed (Fixed _ _ _) = True
307 isFixed (Any _ _) = False
309 isAny = not . isFixed
312 Generate code to get a subtree into a @Register@:
314 getRegister :: StixTree -> NatM Register
316 getRegister (StReg (StixMagicId stgreg))
317 = case (magicIdRegMaybe stgreg) of
318 Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
321 getRegister (StReg (StixTemp u pk))
322 = returnNat (Fixed pk (mkVReg u pk) nilOL)
324 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
326 getRegister (StCall fn cconv kind args)
327 = genCCall fn cconv kind args `thenNat` \ call ->
328 returnNat (Fixed kind reg call)
330 reg = if isFloatingRep kind
331 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
332 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
334 getRegister (StString s)
335 = getNatLabelNCG `thenNat` \ lbl ->
337 imm_lbl = ImmCLbl lbl
340 SEGMENT RoDataSegment,
342 ASCII True (_UNPK_ s),
344 #if alpha_TARGET_ARCH
345 LDA dst (AddrImm imm_lbl)
348 MOV L (OpImm imm_lbl) (OpReg dst)
350 #if sparc_TARGET_ARCH
351 SETHI (HI imm_lbl) dst,
352 OR False dst (RIImm (LO imm_lbl)) dst
356 returnNat (Any PtrRep code)
360 -- end of machine-"independent" bit; here we go on the rest...
362 #if alpha_TARGET_ARCH
364 getRegister (StDouble d)
365 = getNatLabelNCG `thenNat` \ lbl ->
366 getNewRegNCG PtrRep `thenNat` \ tmp ->
367 let code dst = mkSeqInstrs [
370 DATA TF [ImmLab (rational d)],
372 LDA tmp (AddrImm (ImmCLbl lbl)),
373 LD TF dst (AddrReg tmp)]
375 returnNat (Any DoubleRep code)
377 getRegister (StPrim primop [x]) -- unary PrimOps
379 IntNegOp -> trivialUCode (NEG Q False) x
381 NotOp -> trivialUCode NOT x
383 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
384 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
386 OrdOp -> coerceIntCode IntRep x
389 Float2IntOp -> coerceFP2Int x
390 Int2FloatOp -> coerceInt2FP pr x
391 Double2IntOp -> coerceFP2Int x
392 Int2DoubleOp -> coerceInt2FP pr x
394 Double2FloatOp -> coerceFltCode x
395 Float2DoubleOp -> coerceFltCode x
397 other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
399 fn = case other_op of
400 FloatExpOp -> SLIT("exp")
401 FloatLogOp -> SLIT("log")
402 FloatSqrtOp -> SLIT("sqrt")
403 FloatSinOp -> SLIT("sin")
404 FloatCosOp -> SLIT("cos")
405 FloatTanOp -> SLIT("tan")
406 FloatAsinOp -> SLIT("asin")
407 FloatAcosOp -> SLIT("acos")
408 FloatAtanOp -> SLIT("atan")
409 FloatSinhOp -> SLIT("sinh")
410 FloatCoshOp -> SLIT("cosh")
411 FloatTanhOp -> SLIT("tanh")
412 DoubleExpOp -> SLIT("exp")
413 DoubleLogOp -> SLIT("log")
414 DoubleSqrtOp -> SLIT("sqrt")
415 DoubleSinOp -> SLIT("sin")
416 DoubleCosOp -> SLIT("cos")
417 DoubleTanOp -> SLIT("tan")
418 DoubleAsinOp -> SLIT("asin")
419 DoubleAcosOp -> SLIT("acos")
420 DoubleAtanOp -> SLIT("atan")
421 DoubleSinhOp -> SLIT("sinh")
422 DoubleCoshOp -> SLIT("cosh")
423 DoubleTanhOp -> SLIT("tanh")
425 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
427 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
429 CharGtOp -> trivialCode (CMP LTT) y x
430 CharGeOp -> trivialCode (CMP LE) y x
431 CharEqOp -> trivialCode (CMP EQQ) x y
432 CharNeOp -> int_NE_code x y
433 CharLtOp -> trivialCode (CMP LTT) x y
434 CharLeOp -> trivialCode (CMP LE) x y
436 IntGtOp -> trivialCode (CMP LTT) y x
437 IntGeOp -> trivialCode (CMP LE) y x
438 IntEqOp -> trivialCode (CMP EQQ) x y
439 IntNeOp -> int_NE_code x y
440 IntLtOp -> trivialCode (CMP LTT) x y
441 IntLeOp -> trivialCode (CMP LE) x y
443 WordGtOp -> trivialCode (CMP ULT) y x
444 WordGeOp -> trivialCode (CMP ULE) x y
445 WordEqOp -> trivialCode (CMP EQQ) x y
446 WordNeOp -> int_NE_code x y
447 WordLtOp -> trivialCode (CMP ULT) x y
448 WordLeOp -> trivialCode (CMP ULE) x y
450 AddrGtOp -> trivialCode (CMP ULT) y x
451 AddrGeOp -> trivialCode (CMP ULE) y x
452 AddrEqOp -> trivialCode (CMP EQQ) x y
453 AddrNeOp -> int_NE_code x y
454 AddrLtOp -> trivialCode (CMP ULT) x y
455 AddrLeOp -> trivialCode (CMP ULE) x y
457 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
458 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
459 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
460 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
461 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
462 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
464 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
465 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
466 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
467 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
468 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
469 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
471 IntAddOp -> trivialCode (ADD Q False) x y
472 IntSubOp -> trivialCode (SUB Q False) x y
473 IntMulOp -> trivialCode (MUL Q False) x y
474 IntQuotOp -> trivialCode (DIV Q False) x y
475 IntRemOp -> trivialCode (REM Q False) x y
477 WordQuotOp -> trivialCode (DIV Q True) x y
478 WordRemOp -> trivialCode (REM Q True) x y
480 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
481 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
482 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
483 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
485 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
486 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
487 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
488 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
490 AndOp -> trivialCode AND x y
491 OrOp -> trivialCode OR x y
492 XorOp -> trivialCode XOR x y
493 SllOp -> trivialCode SLL x y
494 SrlOp -> trivialCode SRL x y
496 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
497 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
498 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
500 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
501 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
503 {- ------------------------------------------------------------
504 Some bizarre special code for getting condition codes into
505 registers. Integer non-equality is a test for equality
506 followed by an XOR with 1. (Integer comparisons always set
507 the result register to 0 or 1.) Floating point comparisons of
508 any kind leave the result in a floating point register, so we
509 need to wrangle an integer register out of things.
511 int_NE_code :: StixTree -> StixTree -> NatM Register
514 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
515 getNewRegNCG IntRep `thenNat` \ tmp ->
517 code = registerCode register tmp
518 src = registerName register tmp
519 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
521 returnNat (Any IntRep code__2)
523 {- ------------------------------------------------------------
524 Comments for int_NE_code also apply to cmpF_code
527 :: (Reg -> Reg -> Reg -> Instr)
529 -> StixTree -> StixTree
532 cmpF_code instr cond x y
533 = trivialFCode pr instr x y `thenNat` \ register ->
534 getNewRegNCG DoubleRep `thenNat` \ tmp ->
535 getNatLabelNCG `thenNat` \ lbl ->
537 code = registerCode register tmp
538 result = registerName register tmp
540 code__2 dst = code . mkSeqInstrs [
541 OR zeroh (RIImm (ImmInt 1)) dst,
542 BF cond result (ImmCLbl lbl),
543 OR zeroh (RIReg zeroh) dst,
546 returnNat (Any IntRep code__2)
548 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
549 ------------------------------------------------------------
551 getRegister (StInd pk mem)
552 = getAmode mem `thenNat` \ amode ->
554 code = amodeCode amode
555 src = amodeAddr amode
556 size = primRepToSize pk
557 code__2 dst = code . mkSeqInstr (LD size dst src)
559 returnNat (Any pk code__2)
561 getRegister (StInt i)
564 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
566 returnNat (Any IntRep code)
569 code dst = mkSeqInstr (LDI Q dst src)
571 returnNat (Any IntRep code)
573 src = ImmInt (fromInteger i)
578 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
580 returnNat (Any PtrRep code)
583 imm__2 = case imm of Just x -> x
585 #endif {- alpha_TARGET_ARCH -}
586 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
589 getRegister (StFloat f)
590 = getNatLabelNCG `thenNat` \ lbl ->
591 let code dst = toOL [
596 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
599 returnNat (Any FloatRep code)
602 getRegister (StDouble d)
605 = let code dst = unitOL (GLDZ dst)
606 in returnNat (Any DoubleRep code)
609 = let code dst = unitOL (GLD1 dst)
610 in returnNat (Any DoubleRep code)
613 = getNatLabelNCG `thenNat` \ lbl ->
614 let code dst = toOL [
617 DATA DF [ImmDouble d],
619 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
622 returnNat (Any DoubleRep code)
624 -- Calculate the offset for (i+1) words above the _initial_
625 -- %esp value by first determining the current offset of it.
626 getRegister (StScratchWord i)
628 = getDeltaNat `thenNat` \ current_stack_offset ->
629 let j = i+1 - (current_stack_offset `div` 4)
631 = unitOL (LEA L (OpAddr (spRel j)) (OpReg dst))
633 returnNat (Any PtrRep code)
635 getRegister (StPrim primop [x]) -- unary PrimOps
637 IntNegOp -> trivialUCode (NEGI L) x
638 NotOp -> trivialUCode (NOT L) x
640 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
641 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
643 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
644 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
646 FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
647 DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
649 FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
650 DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
652 FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
653 DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
655 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
656 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
658 OrdOp -> coerceIntCode IntRep x
661 Float2IntOp -> coerceFP2Int x
662 Int2FloatOp -> coerceInt2FP FloatRep x
663 Double2IntOp -> coerceFP2Int x
664 Int2DoubleOp -> coerceInt2FP DoubleRep x
667 getRegister (StCall fn cCallConv DoubleRep [x])
671 FloatExpOp -> (True, SLIT("exp"))
672 FloatLogOp -> (True, SLIT("log"))
674 FloatAsinOp -> (True, SLIT("asin"))
675 FloatAcosOp -> (True, SLIT("acos"))
676 FloatAtanOp -> (True, SLIT("atan"))
678 FloatSinhOp -> (True, SLIT("sinh"))
679 FloatCoshOp -> (True, SLIT("cosh"))
680 FloatTanhOp -> (True, SLIT("tanh"))
682 DoubleExpOp -> (False, SLIT("exp"))
683 DoubleLogOp -> (False, SLIT("log"))
685 DoubleAsinOp -> (False, SLIT("asin"))
686 DoubleAcosOp -> (False, SLIT("acos"))
687 DoubleAtanOp -> (False, SLIT("atan"))
689 DoubleSinhOp -> (False, SLIT("sinh"))
690 DoubleCoshOp -> (False, SLIT("cosh"))
691 DoubleTanhOp -> (False, SLIT("tanh"))
694 -> pprPanic "getRegister(x86,unary primop)"
695 (pprStixTree (StPrim primop [x]))
697 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
699 CharGtOp -> condIntReg GTT x y
700 CharGeOp -> condIntReg GE x y
701 CharEqOp -> condIntReg EQQ x y
702 CharNeOp -> condIntReg NE x y
703 CharLtOp -> condIntReg LTT x y
704 CharLeOp -> condIntReg LE x y
706 IntGtOp -> condIntReg GTT x y
707 IntGeOp -> condIntReg GE x y
708 IntEqOp -> condIntReg EQQ x y
709 IntNeOp -> condIntReg NE x y
710 IntLtOp -> condIntReg LTT x y
711 IntLeOp -> condIntReg LE x y
713 WordGtOp -> condIntReg GU x y
714 WordGeOp -> condIntReg GEU x y
715 WordEqOp -> condIntReg EQQ x y
716 WordNeOp -> condIntReg NE x y
717 WordLtOp -> condIntReg LU x y
718 WordLeOp -> condIntReg LEU x y
720 AddrGtOp -> condIntReg GU x y
721 AddrGeOp -> condIntReg GEU x y
722 AddrEqOp -> condIntReg EQQ x y
723 AddrNeOp -> condIntReg NE x y
724 AddrLtOp -> condIntReg LU x y
725 AddrLeOp -> condIntReg LEU x y
727 FloatGtOp -> condFltReg GTT x y
728 FloatGeOp -> condFltReg GE x y
729 FloatEqOp -> condFltReg EQQ x y
730 FloatNeOp -> condFltReg NE x y
731 FloatLtOp -> condFltReg LTT x y
732 FloatLeOp -> condFltReg LE x y
734 DoubleGtOp -> condFltReg GTT x y
735 DoubleGeOp -> condFltReg GE x y
736 DoubleEqOp -> condFltReg EQQ x y
737 DoubleNeOp -> condFltReg NE x y
738 DoubleLtOp -> condFltReg LTT x y
739 DoubleLeOp -> condFltReg LE x y
741 IntAddOp -> add_code L x y
742 IntSubOp -> sub_code L x y
743 IntQuotOp -> trivialCode (IQUOT L) Nothing x y
744 IntRemOp -> trivialCode (IREM L) Nothing x y
745 IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
747 FloatAddOp -> trivialFCode FloatRep GADD x y
748 FloatSubOp -> trivialFCode FloatRep GSUB x y
749 FloatMulOp -> trivialFCode FloatRep GMUL x y
750 FloatDivOp -> trivialFCode FloatRep GDIV x y
752 DoubleAddOp -> trivialFCode DoubleRep GADD x y
753 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
754 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
755 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
757 AndOp -> let op = AND L in trivialCode op (Just op) x y
758 OrOp -> let op = OR L in trivialCode op (Just op) x y
759 XorOp -> let op = XOR L in trivialCode op (Just op) x y
761 {- Shift ops on x86s have constraints on their source, it
762 either has to be Imm, CL or 1
763 => trivialCode's is not restrictive enough (sigh.)
766 SllOp -> shift_code (SHL L) x y {-False-}
767 SrlOp -> shift_code (SHR L) x y {-False-}
768 ISllOp -> shift_code (SHL L) x y {-False-}
769 ISraOp -> shift_code (SAR L) x y {-False-}
770 ISrlOp -> shift_code (SHR L) x y {-False-}
772 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
773 [promote x, promote y])
774 where promote x = StPrim Float2DoubleOp [x]
775 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
778 -> pprPanic "getRegister(x86,dyadic primop)"
779 (pprStixTree (StPrim primop [x, y]))
783 shift_code :: (Imm -> Operand -> Instr)
788 {- Case1: shift length as immediate -}
789 -- Code is the same as the first eq. for trivialCode -- sigh.
790 shift_code instr x y{-amount-}
792 = getRegister x `thenNat` \ regx ->
795 then registerCodeA regx dst `bind` \ code_x ->
797 instr imm__2 (OpReg dst)
798 else registerCodeF regx `bind` \ code_x ->
799 registerNameF regx `bind` \ r_x ->
801 MOV L (OpReg r_x) (OpReg dst) `snocOL`
802 instr imm__2 (OpReg dst)
804 returnNat (Any IntRep mkcode)
807 imm__2 = case imm of Just x -> x
809 {- Case2: shift length is complex (non-immediate) -}
810 -- Since ECX is always used as a spill temporary, we can't
811 -- use it here to do non-immediate shifts. No big deal --
812 -- they are only very rare, and we can use an equivalent
813 -- test-and-jump sequence which doesn't use ECX.
814 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
815 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
816 shift_code instr x y{-amount-}
817 = getRegister x `thenNat` \ register1 ->
818 getRegister y `thenNat` \ register2 ->
819 getNatLabelNCG `thenNat` \ lbl_test3 ->
820 getNatLabelNCG `thenNat` \ lbl_test2 ->
821 getNatLabelNCG `thenNat` \ lbl_test1 ->
822 getNatLabelNCG `thenNat` \ lbl_test0 ->
823 getNatLabelNCG `thenNat` \ lbl_after ->
824 getNewRegNCG IntRep `thenNat` \ tmp ->
826 = let src_val = registerName register1 dst
827 code_val = registerCode register1 dst
828 src_amt = registerName register2 tmp
829 code_amt = registerCode register2 tmp
834 MOV L (OpReg src_amt) r_tmp `appOL`
836 MOV L (OpReg src_val) r_dst `appOL`
838 COMMENT (_PK_ "begin shift sequence"),
839 MOV L (OpReg src_val) r_dst,
840 MOV L (OpReg src_amt) r_tmp,
842 BT L (ImmInt 4) r_tmp,
844 instr (ImmInt 16) r_dst,
847 BT L (ImmInt 3) r_tmp,
849 instr (ImmInt 8) r_dst,
852 BT L (ImmInt 2) r_tmp,
854 instr (ImmInt 4) r_dst,
857 BT L (ImmInt 1) r_tmp,
859 instr (ImmInt 2) r_dst,
862 BT L (ImmInt 0) r_tmp,
864 instr (ImmInt 1) r_dst,
867 COMMENT (_PK_ "end shift sequence")
870 returnNat (Any IntRep code__2)
873 add_code :: Size -> StixTree -> StixTree -> NatM Register
875 add_code sz x (StInt y)
876 = getRegister x `thenNat` \ register ->
877 getNewRegNCG IntRep `thenNat` \ tmp ->
879 code = registerCode register tmp
880 src1 = registerName register tmp
881 src2 = ImmInt (fromInteger y)
884 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
887 returnNat (Any IntRep code__2)
889 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
892 sub_code :: Size -> StixTree -> StixTree -> NatM Register
894 sub_code sz x (StInt y)
895 = getRegister x `thenNat` \ register ->
896 getNewRegNCG IntRep `thenNat` \ tmp ->
898 code = registerCode register tmp
899 src1 = registerName register tmp
900 src2 = ImmInt (-(fromInteger y))
903 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
906 returnNat (Any IntRep code__2)
908 sub_code sz x y = trivialCode (SUB sz) Nothing x y
911 getRegister (StInd pk mem)
912 = getAmode mem `thenNat` \ amode ->
914 code = amodeCode amode
915 src = amodeAddr amode
916 size = primRepToSize pk
917 code__2 dst = code `snocOL`
918 if pk == DoubleRep || pk == FloatRep
919 then GLD size src dst
921 L -> MOV L (OpAddr src) (OpReg dst)
922 BU -> MOVZxL BU (OpAddr src) (OpReg dst)
924 returnNat (Any pk code__2)
926 getRegister (StInt i)
928 src = ImmInt (fromInteger i)
931 = unitOL (XOR L (OpReg dst) (OpReg dst))
933 = unitOL (MOV L (OpImm src) (OpReg dst))
935 returnNat (Any IntRep code)
939 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
941 returnNat (Any PtrRep code)
943 = pprPanic "getRegister(x86)" (pprStixTree leaf)
946 imm__2 = case imm of Just x -> x
948 #endif {- i386_TARGET_ARCH -}
949 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
950 #if sparc_TARGET_ARCH
952 getRegister (StFloat d)
953 = getNatLabelNCG `thenNat` \ lbl ->
954 getNewRegNCG PtrRep `thenNat` \ tmp ->
955 let code dst = toOL [
960 SETHI (HI (ImmCLbl lbl)) tmp,
961 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
963 returnNat (Any FloatRep code)
965 getRegister (StDouble d)
966 = getNatLabelNCG `thenNat` \ lbl ->
967 getNewRegNCG PtrRep `thenNat` \ tmp ->
968 let code dst = toOL [
971 DATA DF [ImmDouble d],
973 SETHI (HI (ImmCLbl lbl)) tmp,
974 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
976 returnNat (Any DoubleRep code)
978 -- The 6-word scratch area is immediately below the frame pointer.
979 -- Below that is the spill area.
980 getRegister (StScratchWord i)
983 code dst = unitOL (fpRelEA (i-6) dst)
985 returnNat (Any PtrRep code)
988 getRegister (StPrim primop [x]) -- unary PrimOps
990 IntNegOp -> trivialUCode (SUB False False g0) x
991 NotOp -> trivialUCode (XNOR False g0) x
993 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
994 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
996 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
997 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
999 OrdOp -> coerceIntCode IntRep x
1002 Float2IntOp -> coerceFP2Int x
1003 Int2FloatOp -> coerceInt2FP FloatRep x
1004 Double2IntOp -> coerceFP2Int x
1005 Int2DoubleOp -> coerceInt2FP DoubleRep x
1009 fixed_x = if is_float_op -- promote to double
1010 then StPrim Float2DoubleOp [x]
1013 getRegister (StCall fn cCallConv DoubleRep [fixed_x])
1017 FloatExpOp -> (True, SLIT("exp"))
1018 FloatLogOp -> (True, SLIT("log"))
1019 FloatSqrtOp -> (True, SLIT("sqrt"))
1021 FloatSinOp -> (True, SLIT("sin"))
1022 FloatCosOp -> (True, SLIT("cos"))
1023 FloatTanOp -> (True, SLIT("tan"))
1025 FloatAsinOp -> (True, SLIT("asin"))
1026 FloatAcosOp -> (True, SLIT("acos"))
1027 FloatAtanOp -> (True, SLIT("atan"))
1029 FloatSinhOp -> (True, SLIT("sinh"))
1030 FloatCoshOp -> (True, SLIT("cosh"))
1031 FloatTanhOp -> (True, SLIT("tanh"))
1033 DoubleExpOp -> (False, SLIT("exp"))
1034 DoubleLogOp -> (False, SLIT("log"))
1035 DoubleSqrtOp -> (False, SLIT("sqrt"))
1037 DoubleSinOp -> (False, SLIT("sin"))
1038 DoubleCosOp -> (False, SLIT("cos"))
1039 DoubleTanOp -> (False, SLIT("tan"))
1041 DoubleAsinOp -> (False, SLIT("asin"))
1042 DoubleAcosOp -> (False, SLIT("acos"))
1043 DoubleAtanOp -> (False, SLIT("atan"))
1045 DoubleSinhOp -> (False, SLIT("sinh"))
1046 DoubleCoshOp -> (False, SLIT("cosh"))
1047 DoubleTanhOp -> (False, SLIT("tanh"))
1050 -> pprPanic "getRegister(sparc,monadicprimop)"
1051 (pprStixTree (StPrim primop [x]))
1053 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
1055 CharGtOp -> condIntReg GTT x y
1056 CharGeOp -> condIntReg GE x y
1057 CharEqOp -> condIntReg EQQ x y
1058 CharNeOp -> condIntReg NE x y
1059 CharLtOp -> condIntReg LTT x y
1060 CharLeOp -> condIntReg LE x y
1062 IntGtOp -> condIntReg GTT x y
1063 IntGeOp -> condIntReg GE x y
1064 IntEqOp -> condIntReg EQQ x y
1065 IntNeOp -> condIntReg NE x y
1066 IntLtOp -> condIntReg LTT x y
1067 IntLeOp -> condIntReg LE x y
1069 WordGtOp -> condIntReg GU x y
1070 WordGeOp -> condIntReg GEU x y
1071 WordEqOp -> condIntReg EQQ x y
1072 WordNeOp -> condIntReg NE x y
1073 WordLtOp -> condIntReg LU x y
1074 WordLeOp -> condIntReg LEU x y
1076 AddrGtOp -> condIntReg GU x y
1077 AddrGeOp -> condIntReg GEU x y
1078 AddrEqOp -> condIntReg EQQ x y
1079 AddrNeOp -> condIntReg NE x y
1080 AddrLtOp -> condIntReg LU x y
1081 AddrLeOp -> condIntReg LEU x y
1083 FloatGtOp -> condFltReg GTT x y
1084 FloatGeOp -> condFltReg GE x y
1085 FloatEqOp -> condFltReg EQQ x y
1086 FloatNeOp -> condFltReg NE x y
1087 FloatLtOp -> condFltReg LTT x y
1088 FloatLeOp -> condFltReg LE x y
1090 DoubleGtOp -> condFltReg GTT x y
1091 DoubleGeOp -> condFltReg GE x y
1092 DoubleEqOp -> condFltReg EQQ x y
1093 DoubleNeOp -> condFltReg NE x y
1094 DoubleLtOp -> condFltReg LTT x y
1095 DoubleLeOp -> condFltReg LE x y
1097 IntAddOp -> trivialCode (ADD False False) x y
1098 IntSubOp -> trivialCode (SUB False False) x y
1100 -- ToDo: teach about V8+ SPARC mul/div instructions
1101 IntMulOp -> imul_div SLIT(".umul") x y
1102 IntQuotOp -> imul_div SLIT(".div") x y
1103 IntRemOp -> imul_div SLIT(".rem") x y
1105 FloatAddOp -> trivialFCode FloatRep FADD x y
1106 FloatSubOp -> trivialFCode FloatRep FSUB x y
1107 FloatMulOp -> trivialFCode FloatRep FMUL x y
1108 FloatDivOp -> trivialFCode FloatRep FDIV x y
1110 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1111 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1112 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1113 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1115 AndOp -> trivialCode (AND False) x y
1116 OrOp -> trivialCode (OR False) x y
1117 XorOp -> trivialCode (XOR False) x y
1118 SllOp -> trivialCode SLL x y
1119 SrlOp -> trivialCode SRL x y
1121 ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
1122 ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
1123 ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
1125 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1126 [promote x, promote y])
1127 where promote x = StPrim Float2DoubleOp [x]
1128 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1132 -> pprPanic "getRegister(sparc,dyadic primop)"
1133 (pprStixTree (StPrim primop [x, y]))
1136 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1138 getRegister (StInd pk mem)
1139 = getAmode mem `thenNat` \ amode ->
1141 code = amodeCode amode
1142 src = amodeAddr amode
1143 size = primRepToSize pk
1144 code__2 dst = code `snocOL` LD size src dst
1146 returnNat (Any pk code__2)
1148 getRegister (StInt i)
1151 src = ImmInt (fromInteger i)
1152 code dst = unitOL (OR False g0 (RIImm src) dst)
1154 returnNat (Any IntRep code)
1160 SETHI (HI imm__2) dst,
1161 OR False dst (RIImm (LO imm__2)) dst]
1163 returnNat (Any PtrRep code)
1165 = pprPanic "getRegister(sparc)" (pprStixTree leaf)
1168 imm__2 = case imm of Just x -> x
1170 #endif {- sparc_TARGET_ARCH -}
1173 %************************************************************************
1175 \subsection{The @Amode@ type}
1177 %************************************************************************
1179 @Amode@s: Memory addressing modes passed up the tree.
1181 data Amode = Amode MachRegsAddr InstrBlock
1183 amodeAddr (Amode addr _) = addr
1184 amodeCode (Amode _ code) = code
1187 Now, given a tree (the argument to an StInd) that references memory,
1188 produce a suitable addressing mode.
1190 A Rule of the Game (tm) for Amodes: use of the addr bit must
1191 immediately follow use of the code part, since the code part puts
1192 values in registers which the addr then refers to. So you can't put
1193 anything in between, lest it overwrite some of those registers. If
1194 you need to do some other computation between the code part and use of
1195 the addr bit, first store the effective address from the amode in a
1196 temporary, then do the other computation, and then use the temporary:
1200 ... other computation ...
1204 getAmode :: StixTree -> NatM Amode
1206 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1208 #if alpha_TARGET_ARCH
1210 getAmode (StPrim IntSubOp [x, StInt i])
1211 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1212 getRegister x `thenNat` \ register ->
1214 code = registerCode register tmp
1215 reg = registerName register tmp
1216 off = ImmInt (-(fromInteger i))
1218 returnNat (Amode (AddrRegImm reg off) code)
1220 getAmode (StPrim IntAddOp [x, StInt i])
1221 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1222 getRegister x `thenNat` \ register ->
1224 code = registerCode register tmp
1225 reg = registerName register tmp
1226 off = ImmInt (fromInteger i)
1228 returnNat (Amode (AddrRegImm reg off) code)
1232 = returnNat (Amode (AddrImm imm__2) id)
1235 imm__2 = case imm of Just x -> x
1238 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1239 getRegister other `thenNat` \ register ->
1241 code = registerCode register tmp
1242 reg = registerName register tmp
1244 returnNat (Amode (AddrReg reg) code)
1246 #endif {- alpha_TARGET_ARCH -}
1247 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1248 #if i386_TARGET_ARCH
1250 getAmode (StPrim IntSubOp [x, StInt i])
1251 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1252 getRegister x `thenNat` \ register ->
1254 code = registerCode register tmp
1255 reg = registerName register tmp
1256 off = ImmInt (-(fromInteger i))
1258 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1260 getAmode (StPrim IntAddOp [x, StInt i])
1262 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1265 imm__2 = case imm of Just x -> x
1267 getAmode (StPrim IntAddOp [x, StInt i])
1268 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1269 getRegister x `thenNat` \ register ->
1271 code = registerCode register tmp
1272 reg = registerName register tmp
1273 off = ImmInt (fromInteger i)
1275 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1277 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1278 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1279 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1280 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1281 getRegister x `thenNat` \ register1 ->
1282 getRegister y `thenNat` \ register2 ->
1284 code1 = registerCode register1 tmp1
1285 reg1 = registerName register1 tmp1
1286 code2 = registerCode register2 tmp2
1287 reg2 = registerName register2 tmp2
1288 code__2 = code1 `appOL` code2
1289 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1291 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1296 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1299 imm__2 = case imm of Just x -> x
1302 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1303 getRegister other `thenNat` \ register ->
1305 code = registerCode register tmp
1306 reg = registerName register tmp
1308 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1310 #endif {- i386_TARGET_ARCH -}
1311 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1312 #if sparc_TARGET_ARCH
1314 getAmode (StPrim IntSubOp [x, StInt i])
1316 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1317 getRegister x `thenNat` \ register ->
1319 code = registerCode register tmp
1320 reg = registerName register tmp
1321 off = ImmInt (-(fromInteger i))
1323 returnNat (Amode (AddrRegImm reg off) code)
1326 getAmode (StPrim IntAddOp [x, StInt i])
1328 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1329 getRegister x `thenNat` \ register ->
1331 code = registerCode register tmp
1332 reg = registerName register tmp
1333 off = ImmInt (fromInteger i)
1335 returnNat (Amode (AddrRegImm reg off) code)
1337 getAmode (StPrim IntAddOp [x, y])
1338 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1339 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1340 getRegister x `thenNat` \ register1 ->
1341 getRegister y `thenNat` \ register2 ->
1343 code1 = registerCode register1 tmp1
1344 reg1 = registerName register1 tmp1
1345 code2 = registerCode register2 tmp2
1346 reg2 = registerName register2 tmp2
1347 code__2 = code1 `appOL` code2
1349 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1353 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1355 code = unitOL (SETHI (HI imm__2) tmp)
1357 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1360 imm__2 = case imm of Just x -> x
1363 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1364 getRegister other `thenNat` \ register ->
1366 code = registerCode register tmp
1367 reg = registerName register tmp
1370 returnNat (Amode (AddrRegImm reg off) code)
1372 #endif {- sparc_TARGET_ARCH -}
1375 %************************************************************************
1377 \subsection{The @CondCode@ type}
1379 %************************************************************************
1381 Condition codes passed up the tree.
1383 data CondCode = CondCode Bool Cond InstrBlock
1385 condName (CondCode _ cond _) = cond
1386 condFloat (CondCode is_float _ _) = is_float
1387 condCode (CondCode _ _ code) = code
1390 Set up a condition code for a conditional branch.
1393 getCondCode :: StixTree -> NatM CondCode
1395 #if alpha_TARGET_ARCH
1396 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1397 #endif {- alpha_TARGET_ARCH -}
1398 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1400 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1401 -- yes, they really do seem to want exactly the same!
1403 getCondCode (StPrim primop [x, y])
1405 CharGtOp -> condIntCode GTT x y
1406 CharGeOp -> condIntCode GE x y
1407 CharEqOp -> condIntCode EQQ x y
1408 CharNeOp -> condIntCode NE x y
1409 CharLtOp -> condIntCode LTT x y
1410 CharLeOp -> condIntCode LE x y
1412 IntGtOp -> condIntCode GTT x y
1413 IntGeOp -> condIntCode GE x y
1414 IntEqOp -> condIntCode EQQ x y
1415 IntNeOp -> condIntCode NE x y
1416 IntLtOp -> condIntCode LTT x y
1417 IntLeOp -> condIntCode LE x y
1419 WordGtOp -> condIntCode GU x y
1420 WordGeOp -> condIntCode GEU x y
1421 WordEqOp -> condIntCode EQQ x y
1422 WordNeOp -> condIntCode NE x y
1423 WordLtOp -> condIntCode LU x y
1424 WordLeOp -> condIntCode LEU x y
1426 AddrGtOp -> condIntCode GU x y
1427 AddrGeOp -> condIntCode GEU x y
1428 AddrEqOp -> condIntCode EQQ x y
1429 AddrNeOp -> condIntCode NE x y
1430 AddrLtOp -> condIntCode LU x y
1431 AddrLeOp -> condIntCode LEU x y
1433 FloatGtOp -> condFltCode GTT x y
1434 FloatGeOp -> condFltCode GE x y
1435 FloatEqOp -> condFltCode EQQ x y
1436 FloatNeOp -> condFltCode NE x y
1437 FloatLtOp -> condFltCode LTT x y
1438 FloatLeOp -> condFltCode LE x y
1440 DoubleGtOp -> condFltCode GTT x y
1441 DoubleGeOp -> condFltCode GE x y
1442 DoubleEqOp -> condFltCode EQQ x y
1443 DoubleNeOp -> condFltCode NE x y
1444 DoubleLtOp -> condFltCode LTT x y
1445 DoubleLeOp -> condFltCode LE x y
1447 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1452 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1453 passed back up the tree.
1456 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1458 #if alpha_TARGET_ARCH
1459 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1460 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1461 #endif {- alpha_TARGET_ARCH -}
1463 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1464 #if i386_TARGET_ARCH
1466 -- memory vs immediate
1467 condIntCode cond (StInd pk x) y
1469 = getAmode x `thenNat` \ amode ->
1471 code1 = amodeCode amode
1472 x__2 = amodeAddr amode
1473 sz = primRepToSize pk
1474 code__2 = code1 `snocOL`
1475 CMP sz (OpImm imm__2) (OpAddr x__2)
1477 returnNat (CondCode False cond code__2)
1480 imm__2 = case imm of Just x -> x
1483 condIntCode cond x (StInt 0)
1484 = getRegister x `thenNat` \ register1 ->
1485 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1487 code1 = registerCode register1 tmp1
1488 src1 = registerName register1 tmp1
1489 code__2 = code1 `snocOL`
1490 TEST L (OpReg src1) (OpReg src1)
1492 returnNat (CondCode False cond code__2)
1494 -- anything vs immediate
1495 condIntCode cond x y
1497 = getRegister x `thenNat` \ register1 ->
1498 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1500 code1 = registerCode register1 tmp1
1501 src1 = registerName register1 tmp1
1502 code__2 = code1 `snocOL`
1503 CMP L (OpImm imm__2) (OpReg src1)
1505 returnNat (CondCode False cond code__2)
1508 imm__2 = case imm of Just x -> x
1510 -- memory vs anything
1511 condIntCode cond (StInd pk x) y
1512 = getAmode x `thenNat` \ amode_x ->
1513 getRegister y `thenNat` \ reg_y ->
1514 getNewRegNCG IntRep `thenNat` \ tmp ->
1516 c_x = amodeCode amode_x
1517 am_x = amodeAddr amode_x
1518 c_y = registerCode reg_y tmp
1519 r_y = registerName reg_y tmp
1520 sz = primRepToSize pk
1522 -- optimisation: if there's no code for x, just an amode,
1523 -- use whatever reg y winds up in. Assumes that c_y doesn't
1524 -- clobber any regs in the amode am_x, which I'm not sure is
1525 -- justified. The otherwise clause makes the same assumption.
1526 code__2 | isNilOL c_x
1528 CMP sz (OpReg r_y) (OpAddr am_x)
1532 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1534 CMP sz (OpReg tmp) (OpAddr am_x)
1536 returnNat (CondCode False cond code__2)
1538 -- anything vs memory
1540 condIntCode cond y (StInd pk x)
1541 = getAmode x `thenNat` \ amode_x ->
1542 getRegister y `thenNat` \ reg_y ->
1543 getNewRegNCG IntRep `thenNat` \ tmp ->
1545 c_x = amodeCode amode_x
1546 am_x = amodeAddr amode_x
1547 c_y = registerCode reg_y tmp
1548 r_y = registerName reg_y tmp
1549 sz = primRepToSize pk
1550 -- same optimisation and nagging doubts as previous clause
1551 code__2 | isNilOL c_x
1553 CMP sz (OpAddr am_x) (OpReg r_y)
1557 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1559 CMP sz (OpAddr am_x) (OpReg tmp)
1561 returnNat (CondCode False cond code__2)
1563 -- anything vs anything
1564 condIntCode cond x y
1565 = getRegister x `thenNat` \ register1 ->
1566 getRegister y `thenNat` \ register2 ->
1567 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1568 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1570 code1 = registerCode register1 tmp1
1571 src1 = registerName register1 tmp1
1572 code2 = registerCode register2 tmp2
1573 src2 = registerName register2 tmp2
1574 code__2 = code1 `snocOL`
1575 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1577 CMP L (OpReg src2) (OpReg tmp1)
1579 returnNat (CondCode False cond code__2)
1582 condFltCode cond x y
1583 = getRegister x `thenNat` \ register1 ->
1584 getRegister y `thenNat` \ register2 ->
1585 getNewRegNCG (registerRep register1)
1587 getNewRegNCG (registerRep register2)
1589 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1591 pk1 = registerRep register1
1592 code1 = registerCode register1 tmp1
1593 src1 = registerName register1 tmp1
1595 code2 = registerCode register2 tmp2
1596 src2 = registerName register2 tmp2
1598 code__2 | isAny register1
1599 = code1 `appOL` -- result in tmp1
1601 GCMP (primRepToSize pk1) tmp1 src2
1605 GMOV src1 tmp1 `appOL`
1607 GCMP (primRepToSize pk1) tmp1 src2
1609 {- On the 486, the flags set by FP compare are the unsigned ones!
1610 (This looks like a HACK to me. WDP 96/03)
1612 fix_FP_cond :: Cond -> Cond
1614 fix_FP_cond GE = GEU
1615 fix_FP_cond GTT = GU
1616 fix_FP_cond LTT = LU
1617 fix_FP_cond LE = LEU
1618 fix_FP_cond any = any
1620 returnNat (CondCode True (fix_FP_cond cond) code__2)
1624 #endif {- i386_TARGET_ARCH -}
1625 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1626 #if sparc_TARGET_ARCH
1628 condIntCode cond x (StInt y)
1630 = getRegister x `thenNat` \ register ->
1631 getNewRegNCG IntRep `thenNat` \ tmp ->
1633 code = registerCode register tmp
1634 src1 = registerName register tmp
1635 src2 = ImmInt (fromInteger y)
1636 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1638 returnNat (CondCode False cond code__2)
1640 condIntCode cond x y
1641 = getRegister x `thenNat` \ register1 ->
1642 getRegister y `thenNat` \ register2 ->
1643 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1644 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1646 code1 = registerCode register1 tmp1
1647 src1 = registerName register1 tmp1
1648 code2 = registerCode register2 tmp2
1649 src2 = registerName register2 tmp2
1650 code__2 = code1 `appOL` code2 `snocOL`
1651 SUB False True src1 (RIReg src2) g0
1653 returnNat (CondCode False cond code__2)
1656 condFltCode cond x y
1657 = getRegister x `thenNat` \ register1 ->
1658 getRegister y `thenNat` \ register2 ->
1659 getNewRegNCG (registerRep register1)
1661 getNewRegNCG (registerRep register2)
1663 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1665 promote x = FxTOy F DF x tmp
1667 pk1 = registerRep register1
1668 code1 = registerCode register1 tmp1
1669 src1 = registerName register1 tmp1
1671 pk2 = registerRep register2
1672 code2 = registerCode register2 tmp2
1673 src2 = registerName register2 tmp2
1677 code1 `appOL` code2 `snocOL`
1678 FCMP True (primRepToSize pk1) src1 src2
1679 else if pk1 == FloatRep then
1680 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1681 FCMP True DF tmp src2
1683 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1684 FCMP True DF src1 tmp
1686 returnNat (CondCode True cond code__2)
1688 #endif {- sparc_TARGET_ARCH -}
1691 %************************************************************************
1693 \subsection{Generating assignments}
1695 %************************************************************************
1697 Assignments are really at the heart of the whole code generation
1698 business. Almost all top-level nodes of any real importance are
1699 assignments, which correspond to loads, stores, or register transfers.
1700 If we're really lucky, some of the register transfers will go away,
1701 because we can use the destination register to complete the code
1702 generation for the right hand side. This only fails when the right
1703 hand side is forced into a fixed register (e.g. the result of a call).
1706 assignIntCode, assignFltCode
1707 :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1709 #if alpha_TARGET_ARCH
1711 assignIntCode pk (StInd _ dst) src
1712 = getNewRegNCG IntRep `thenNat` \ tmp ->
1713 getAmode dst `thenNat` \ amode ->
1714 getRegister src `thenNat` \ register ->
1716 code1 = amodeCode amode []
1717 dst__2 = amodeAddr amode
1718 code2 = registerCode register tmp []
1719 src__2 = registerName register tmp
1720 sz = primRepToSize pk
1721 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1725 assignIntCode pk dst src
1726 = getRegister dst `thenNat` \ register1 ->
1727 getRegister src `thenNat` \ register2 ->
1729 dst__2 = registerName register1 zeroh
1730 code = registerCode register2 dst__2
1731 src__2 = registerName register2 dst__2
1732 code__2 = if isFixed register2
1733 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1738 #endif {- alpha_TARGET_ARCH -}
1739 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1740 #if i386_TARGET_ARCH
1742 -- Destination of an assignment can only be reg or mem.
1743 -- This is the mem case.
1744 assignIntCode pk (StInd _ dst) src
1745 = getAmode dst `thenNat` \ amode ->
1746 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
1747 getNewRegNCG PtrRep `thenNat` \ tmp ->
1749 -- In general, if the address computation for dst may require
1750 -- some insns preceding the addressing mode itself. So there's
1751 -- no guarantee that the code for dst and the code for src won't
1752 -- write the same register. This means either the address or
1753 -- the value needs to be copied into a temporary. We detect the
1754 -- common case where the amode has no code, and elide the copy.
1755 codea = amodeCode amode
1756 dst__a = amodeAddr amode
1758 code | isNilOL codea
1760 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1764 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1766 MOV (primRepToSize pk) opsrc
1767 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1773 -> NatM (InstrBlock,Operand) -- code, operator
1777 = returnNat (nilOL, OpImm imm_op)
1780 imm_op = case imm of Just x -> x
1783 = getRegister op `thenNat` \ register ->
1784 getNewRegNCG (registerRep register)
1786 let code = registerCode register tmp
1787 reg = registerName register tmp
1789 returnNat (code, OpReg reg)
1791 -- Assign; dst is a reg, rhs is mem
1792 assignIntCode pk dst (StInd pks src)
1793 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1794 getAmode src `thenNat` \ amode ->
1795 getRegister dst `thenNat` \ reg_dst ->
1797 c_addr = amodeCode amode
1798 am_addr = amodeAddr amode
1800 c_dst = registerCode reg_dst tmp -- should be empty
1801 r_dst = registerName reg_dst tmp
1802 szs = primRepToSize pks
1803 opc = case szs of L -> MOV L ; BU -> MOVZxL BU
1805 code | isNilOL c_dst
1807 opc (OpAddr am_addr) (OpReg r_dst)
1809 = pprPanic "assignIntCode(x86): bad dst(2)" empty
1813 -- dst is a reg, but src could be anything
1814 assignIntCode pk dst src
1815 = getRegister dst `thenNat` \ registerd ->
1816 getRegister src `thenNat` \ registers ->
1817 getNewRegNCG IntRep `thenNat` \ tmp ->
1819 r_dst = registerName registerd tmp
1820 c_dst = registerCode registerd tmp -- should be empty
1821 r_src = registerName registers r_dst
1822 c_src = registerCode registers r_dst
1824 code | isNilOL c_dst
1826 MOV L (OpReg r_src) (OpReg r_dst)
1828 = pprPanic "assignIntCode(x86): bad dst(3)" empty
1832 #endif {- i386_TARGET_ARCH -}
1833 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1834 #if sparc_TARGET_ARCH
1836 assignIntCode pk (StInd _ dst) src
1837 = getNewRegNCG IntRep `thenNat` \ tmp ->
1838 getAmode dst `thenNat` \ amode ->
1839 getRegister src `thenNat` \ register ->
1841 code1 = amodeCode amode
1842 dst__2 = amodeAddr amode
1843 code2 = registerCode register tmp
1844 src__2 = registerName register tmp
1845 sz = primRepToSize pk
1846 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
1850 assignIntCode pk dst src
1851 = getRegister dst `thenNat` \ register1 ->
1852 getRegister src `thenNat` \ register2 ->
1854 dst__2 = registerName register1 g0
1855 code = registerCode register2 dst__2
1856 src__2 = registerName register2 dst__2
1857 code__2 = if isFixed register2
1858 then code `snocOL` OR False g0 (RIReg src__2) dst__2
1863 #endif {- sparc_TARGET_ARCH -}
1866 % --------------------------------
1867 Floating-point assignments:
1868 % --------------------------------
1870 #if alpha_TARGET_ARCH
1872 assignFltCode pk (StInd _ dst) src
1873 = getNewRegNCG pk `thenNat` \ tmp ->
1874 getAmode dst `thenNat` \ amode ->
1875 getRegister src `thenNat` \ register ->
1877 code1 = amodeCode amode []
1878 dst__2 = amodeAddr amode
1879 code2 = registerCode register tmp []
1880 src__2 = registerName register tmp
1881 sz = primRepToSize pk
1882 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1886 assignFltCode pk dst src
1887 = getRegister dst `thenNat` \ register1 ->
1888 getRegister src `thenNat` \ register2 ->
1890 dst__2 = registerName register1 zeroh
1891 code = registerCode register2 dst__2
1892 src__2 = registerName register2 dst__2
1893 code__2 = if isFixed register2
1894 then code . mkSeqInstr (FMOV src__2 dst__2)
1899 #endif {- alpha_TARGET_ARCH -}
1900 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1901 #if i386_TARGET_ARCH
1904 assignFltCode pk (StInd pk_dst addr) src
1906 = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
1908 = getRegister src `thenNat` \ reg_src ->
1909 getRegister addr `thenNat` \ reg_addr ->
1910 getNewRegNCG pk `thenNat` \ tmp_src ->
1911 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
1912 let r_src = registerName reg_src tmp_src
1913 c_src = registerCode reg_src tmp_src
1914 r_addr = registerName reg_addr tmp_addr
1915 c_addr = registerCode reg_addr tmp_addr
1916 sz = primRepToSize pk
1918 code = c_src `appOL`
1919 -- no need to preserve r_src across the addr computation,
1920 -- since r_src must be a float reg
1921 -- whilst r_addr is an int reg
1924 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1928 -- dst must be a (FP) register
1929 assignFltCode pk dst src
1930 = getRegister dst `thenNat` \ reg_dst ->
1931 getRegister src `thenNat` \ reg_src ->
1932 getNewRegNCG pk `thenNat` \ tmp ->
1934 r_dst = registerName reg_dst tmp
1935 c_dst = registerCode reg_dst tmp -- should be empty
1937 r_src = registerName reg_src r_dst
1938 c_src = registerCode reg_src r_dst
1940 code | isNilOL c_dst
1941 = if isFixed reg_src
1942 then c_src `snocOL` GMOV r_src r_dst
1945 = pprPanic "assignFltCode(x86): lhs is not mem or reg"
1951 #endif {- i386_TARGET_ARCH -}
1952 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1953 #if sparc_TARGET_ARCH
1955 assignFltCode pk (StInd _ dst) src
1956 = getNewRegNCG pk `thenNat` \ tmp1 ->
1957 getAmode dst `thenNat` \ amode ->
1958 getRegister src `thenNat` \ register ->
1960 sz = primRepToSize pk
1961 dst__2 = amodeAddr amode
1963 code1 = amodeCode amode
1964 code2 = registerCode register tmp1
1966 src__2 = registerName register tmp1
1967 pk__2 = registerRep register
1968 sz__2 = primRepToSize pk__2
1970 code__2 = code1 `appOL` code2 `appOL`
1972 then unitOL (ST sz src__2 dst__2)
1973 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1977 assignFltCode pk dst src
1978 = getRegister dst `thenNat` \ register1 ->
1979 getRegister src `thenNat` \ register2 ->
1981 pk__2 = registerRep register2
1982 sz__2 = primRepToSize pk__2
1984 getNewRegNCG pk__2 `thenNat` \ tmp ->
1986 sz = primRepToSize pk
1987 dst__2 = registerName register1 g0 -- must be Fixed
1990 reg__2 = if pk /= pk__2 then tmp else dst__2
1992 code = registerCode register2 reg__2
1994 src__2 = registerName register2 reg__2
1998 code `snocOL` FxTOy sz__2 sz src__2 dst__2
1999 else if isFixed register2 then
2000 code `snocOL` FMOV sz src__2 dst__2
2006 #endif {- sparc_TARGET_ARCH -}
2009 %************************************************************************
2011 \subsection{Generating an unconditional branch}
2013 %************************************************************************
2015 We accept two types of targets: an immediate CLabel or a tree that
2016 gets evaluated into a register. Any CLabels which are AsmTemporaries
2017 are assumed to be in the local block of code, close enough for a
2018 branch instruction. Other CLabels are assumed to be far away.
2020 (If applicable) Do not fill the delay slots here; you will confuse the
2024 genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
2026 #if alpha_TARGET_ARCH
2028 genJump (StCLbl lbl)
2029 | isAsmTemp lbl = returnInstr (BR target)
2030 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2032 target = ImmCLbl lbl
2035 = getRegister tree `thenNat` \ register ->
2036 getNewRegNCG PtrRep `thenNat` \ tmp ->
2038 dst = registerName register pv
2039 code = registerCode register pv
2040 target = registerName register pv
2042 if isFixed register then
2043 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2045 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2047 #endif {- alpha_TARGET_ARCH -}
2048 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2049 #if i386_TARGET_ARCH
2051 genJump dsts (StInd pk mem)
2052 = getAmode mem `thenNat` \ amode ->
2054 code = amodeCode amode
2055 target = amodeAddr amode
2057 returnNat (code `snocOL` JMP dsts (OpAddr target))
2061 = returnNat (unitOL (JMP dsts (OpImm target)))
2064 = getRegister tree `thenNat` \ register ->
2065 getNewRegNCG PtrRep `thenNat` \ tmp ->
2067 code = registerCode register tmp
2068 target = registerName register tmp
2070 returnNat (code `snocOL` JMP dsts (OpReg target))
2073 target = case imm of Just x -> x
2075 #endif {- i386_TARGET_ARCH -}
2076 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2077 #if sparc_TARGET_ARCH
2079 genJump dsts (StCLbl lbl)
2080 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2081 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2082 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2084 target = ImmCLbl lbl
2087 = getRegister tree `thenNat` \ register ->
2088 getNewRegNCG PtrRep `thenNat` \ tmp ->
2090 code = registerCode register tmp
2091 target = registerName register tmp
2093 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2095 #endif {- sparc_TARGET_ARCH -}
2098 %************************************************************************
2100 \subsection{Conditional jumps}
2102 %************************************************************************
2104 Conditional jumps are always to local labels, so we can use branch
2105 instructions. We peek at the arguments to decide what kind of
2108 ALPHA: For comparisons with 0, we're laughing, because we can just do
2109 the desired conditional branch.
2111 I386: First, we have to ensure that the condition
2112 codes are set according to the supplied comparison operation.
2114 SPARC: First, we have to ensure that the condition codes are set
2115 according to the supplied comparison operation. We generate slightly
2116 different code for floating point comparisons, because a floating
2117 point operation cannot directly precede a @BF@. We assume the worst
2118 and fill that slot with a @NOP@.
2120 SPARC: Do not fill the delay slots here; you will confuse the register
2125 :: CLabel -- the branch target
2126 -> StixTree -- the condition on which to branch
2129 #if alpha_TARGET_ARCH
2131 genCondJump lbl (StPrim op [x, StInt 0])
2132 = getRegister x `thenNat` \ register ->
2133 getNewRegNCG (registerRep register)
2136 code = registerCode register tmp
2137 value = registerName register tmp
2138 pk = registerRep register
2139 target = ImmCLbl lbl
2141 returnSeq code [BI (cmpOp op) value target]
2143 cmpOp CharGtOp = GTT
2145 cmpOp CharEqOp = EQQ
2147 cmpOp CharLtOp = LTT
2156 cmpOp WordGeOp = ALWAYS
2157 cmpOp WordEqOp = EQQ
2159 cmpOp WordLtOp = NEVER
2160 cmpOp WordLeOp = EQQ
2162 cmpOp AddrGeOp = ALWAYS
2163 cmpOp AddrEqOp = EQQ
2165 cmpOp AddrLtOp = NEVER
2166 cmpOp AddrLeOp = EQQ
2168 genCondJump lbl (StPrim op [x, StDouble 0.0])
2169 = getRegister x `thenNat` \ register ->
2170 getNewRegNCG (registerRep register)
2173 code = registerCode register tmp
2174 value = registerName register tmp
2175 pk = registerRep register
2176 target = ImmCLbl lbl
2178 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2180 cmpOp FloatGtOp = GTT
2181 cmpOp FloatGeOp = GE
2182 cmpOp FloatEqOp = EQQ
2183 cmpOp FloatNeOp = NE
2184 cmpOp FloatLtOp = LTT
2185 cmpOp FloatLeOp = LE
2186 cmpOp DoubleGtOp = GTT
2187 cmpOp DoubleGeOp = GE
2188 cmpOp DoubleEqOp = EQQ
2189 cmpOp DoubleNeOp = NE
2190 cmpOp DoubleLtOp = LTT
2191 cmpOp DoubleLeOp = LE
2193 genCondJump lbl (StPrim op [x, y])
2195 = trivialFCode pr instr x y `thenNat` \ register ->
2196 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2198 code = registerCode register tmp
2199 result = registerName register tmp
2200 target = ImmCLbl lbl
2202 returnNat (code . mkSeqInstr (BF cond result target))
2204 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2206 fltCmpOp op = case op of
2220 (instr, cond) = case op of
2221 FloatGtOp -> (FCMP TF LE, EQQ)
2222 FloatGeOp -> (FCMP TF LTT, EQQ)
2223 FloatEqOp -> (FCMP TF EQQ, NE)
2224 FloatNeOp -> (FCMP TF EQQ, EQQ)
2225 FloatLtOp -> (FCMP TF LTT, NE)
2226 FloatLeOp -> (FCMP TF LE, NE)
2227 DoubleGtOp -> (FCMP TF LE, EQQ)
2228 DoubleGeOp -> (FCMP TF LTT, EQQ)
2229 DoubleEqOp -> (FCMP TF EQQ, NE)
2230 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2231 DoubleLtOp -> (FCMP TF LTT, NE)
2232 DoubleLeOp -> (FCMP TF LE, NE)
2234 genCondJump lbl (StPrim op [x, y])
2235 = trivialCode instr x y `thenNat` \ register ->
2236 getNewRegNCG IntRep `thenNat` \ tmp ->
2238 code = registerCode register tmp
2239 result = registerName register tmp
2240 target = ImmCLbl lbl
2242 returnNat (code . mkSeqInstr (BI cond result target))
2244 (instr, cond) = case op of
2245 CharGtOp -> (CMP LE, EQQ)
2246 CharGeOp -> (CMP LTT, EQQ)
2247 CharEqOp -> (CMP EQQ, NE)
2248 CharNeOp -> (CMP EQQ, EQQ)
2249 CharLtOp -> (CMP LTT, NE)
2250 CharLeOp -> (CMP LE, NE)
2251 IntGtOp -> (CMP LE, EQQ)
2252 IntGeOp -> (CMP LTT, EQQ)
2253 IntEqOp -> (CMP EQQ, NE)
2254 IntNeOp -> (CMP EQQ, EQQ)
2255 IntLtOp -> (CMP LTT, NE)
2256 IntLeOp -> (CMP LE, NE)
2257 WordGtOp -> (CMP ULE, EQQ)
2258 WordGeOp -> (CMP ULT, EQQ)
2259 WordEqOp -> (CMP EQQ, NE)
2260 WordNeOp -> (CMP EQQ, EQQ)
2261 WordLtOp -> (CMP ULT, NE)
2262 WordLeOp -> (CMP ULE, NE)
2263 AddrGtOp -> (CMP ULE, EQQ)
2264 AddrGeOp -> (CMP ULT, EQQ)
2265 AddrEqOp -> (CMP EQQ, NE)
2266 AddrNeOp -> (CMP EQQ, EQQ)
2267 AddrLtOp -> (CMP ULT, NE)
2268 AddrLeOp -> (CMP ULE, NE)
2270 #endif {- alpha_TARGET_ARCH -}
2271 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2272 #if i386_TARGET_ARCH
2274 genCondJump lbl bool
2275 = getCondCode bool `thenNat` \ condition ->
2277 code = condCode condition
2278 cond = condName condition
2280 returnNat (code `snocOL` JXX cond lbl)
2282 #endif {- i386_TARGET_ARCH -}
2283 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2284 #if sparc_TARGET_ARCH
2286 genCondJump lbl bool
2287 = getCondCode bool `thenNat` \ condition ->
2289 code = condCode condition
2290 cond = condName condition
2291 target = ImmCLbl lbl
2296 if condFloat condition
2297 then [NOP, BF cond False target, NOP]
2298 else [BI cond False target, NOP]
2302 #endif {- sparc_TARGET_ARCH -}
2305 %************************************************************************
2307 \subsection{Generating C calls}
2309 %************************************************************************
2311 Now the biggest nightmare---calls. Most of the nastiness is buried in
2312 @get_arg@, which moves the arguments to the correct registers/stack
2313 locations. Apart from that, the code is easy.
2315 (If applicable) Do not fill the delay slots here; you will confuse the
2320 :: FAST_STRING -- function to call
2322 -> PrimRep -- type of the result
2323 -> [StixTree] -- arguments (of mixed type)
2326 #if alpha_TARGET_ARCH
2328 genCCall fn cconv kind args
2329 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2330 `thenNat` \ ((unused,_), argCode) ->
2332 nRegs = length allArgRegs - length unused
2333 code = asmSeqThen (map ($ []) argCode)
2336 LDA pv (AddrImm (ImmLab (ptext fn))),
2337 JSR ra (AddrReg pv) nRegs,
2338 LDGP gp (AddrReg ra)]
2340 ------------------------
2341 {- Try to get a value into a specific register (or registers) for
2342 a call. The first 6 arguments go into the appropriate
2343 argument register (separate registers for integer and floating
2344 point arguments, but used in lock-step), and the remaining
2345 arguments are dumped to the stack, beginning at 0(sp). Our
2346 first argument is a pair of the list of remaining argument
2347 registers to be assigned for this call and the next stack
2348 offset to use for overflowing arguments. This way,
2349 @get_Arg@ can be applied to all of a call's arguments using
2353 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2354 -> StixTree -- Current argument
2355 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2357 -- We have to use up all of our argument registers first...
2359 get_arg ((iDst,fDst):dsts, offset) arg
2360 = getRegister arg `thenNat` \ register ->
2362 reg = if isFloatingRep pk then fDst else iDst
2363 code = registerCode register reg
2364 src = registerName register reg
2365 pk = registerRep register
2368 if isFloatingRep pk then
2369 ((dsts, offset), if isFixed register then
2370 code . mkSeqInstr (FMOV src fDst)
2373 ((dsts, offset), if isFixed register then
2374 code . mkSeqInstr (OR src (RIReg src) iDst)
2377 -- Once we have run out of argument registers, we move to the
2380 get_arg ([], offset) arg
2381 = getRegister arg `thenNat` \ register ->
2382 getNewRegNCG (registerRep register)
2385 code = registerCode register tmp
2386 src = registerName register tmp
2387 pk = registerRep register
2388 sz = primRepToSize pk
2390 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2392 #endif {- alpha_TARGET_ARCH -}
2393 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2394 #if i386_TARGET_ARCH
2396 genCCall fn cconv kind [StInt i]
2397 | fn == SLIT ("PerformGC_wrapper")
2399 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2400 CALL (ImmLit (ptext (if underscorePrefix
2401 then (SLIT ("_PerformGC_wrapper"))
2402 else (SLIT ("PerformGC_wrapper")))))
2408 genCCall fn cconv kind args
2409 = mapNat get_call_arg
2410 (reverse args) `thenNat` \ sizes_n_codes ->
2411 getDeltaNat `thenNat` \ delta ->
2412 let (sizes, codes) = unzip sizes_n_codes
2413 tot_arg_size = sum sizes
2414 code2 = concatOL codes
2416 [CALL (fn__2 tot_arg_size)]
2418 (if cconv == stdCallConv then [] else
2419 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2421 [DELTA (delta + tot_arg_size)]
2424 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2425 returnNat (code2 `appOL` call)
2428 -- function names that begin with '.' are assumed to be special
2429 -- internally generated names like '.mul,' which don't get an
2430 -- underscore prefix
2431 -- ToDo:needed (WDP 96/03) ???
2435 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2437 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2439 stdcallsize tot_arg_size
2440 | cconv == stdCallConv = '@':show tot_arg_size
2448 get_call_arg :: StixTree{-current argument-}
2449 -> NatM (Int, InstrBlock) -- argsz, code
2452 = get_op arg `thenNat` \ (code, reg, sz) ->
2453 getDeltaNat `thenNat` \ delta ->
2454 arg_size sz `bind` \ size ->
2455 setDeltaNat (delta-size) `thenNat` \ _ ->
2456 if (case sz of DF -> True; F -> True; _ -> False)
2457 then returnNat (size,
2459 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2461 GST sz reg (AddrBaseIndex (Just esp)
2465 else returnNat (size,
2467 PUSH L (OpReg reg) `snocOL`
2473 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2476 = getRegister op `thenNat` \ register ->
2477 getNewRegNCG (registerRep register)
2480 code = registerCode register tmp
2481 reg = registerName register tmp
2482 pk = registerRep register
2483 sz = primRepToSize pk
2485 returnNat (code, reg, sz)
2487 #endif {- i386_TARGET_ARCH -}
2488 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2489 #if sparc_TARGET_ARCH
2491 The SPARC calling convention is an absolute
2492 nightmare. The first 6x32 bits of arguments are mapped into
2493 %o0 through %o5, and the remaining arguments are dumped to the
2494 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2496 If we have to put args on the stack, move %o6==%sp down by
2497 the number of words to go on the stack, to ensure there's enough space.
2499 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2500 16 words above the stack pointer is a word for the address of
2501 a structure return value. I use this as a temporary location
2502 for moving values from float to int regs. Certainly it isn't
2503 safe to put anything in the 16 words starting at %sp, since
2504 this area can get trashed at any time due to window overflows
2505 caused by signal handlers.
2507 A final complication (if the above isn't enough) is that
2508 we can't blithely calculate the arguments one by one into
2509 %o0 .. %o5. Consider the following nested calls:
2513 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2514 the inner call will itself use %o0, which trashes the value put there
2515 in preparation for the outer call. Upshot: we need to calculate the
2516 args into temporary regs, and move those to arg regs or onto the
2517 stack only immediately prior to the call proper. Sigh.
2520 genCCall fn cconv kind args
2521 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2522 let (argcodes, vregss) = unzip argcode_and_vregs
2523 argcode = concatOL argcodes
2524 vregs = concat vregss
2525 n_argRegs = length allArgRegs
2526 n_argRegs_used = min (length vregs) n_argRegs
2527 (move_sp_down, move_sp_up)
2528 = let nn = length vregs - n_argRegs
2529 + 1 -- (for the road)
2532 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2534 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2536 = unitOL (CALL fn__2 n_argRegs_used False)
2538 returnNat (argcode `appOL`
2539 move_sp_down `appOL`
2540 transfer_code `appOL`
2545 -- function names that begin with '.' are assumed to be special
2546 -- internally generated names like '.mul,' which don't get an
2547 -- underscore prefix
2548 -- ToDo:needed (WDP 96/03) ???
2549 fn__2 = case (_HEAD_ fn) of
2550 '.' -> ImmLit (ptext fn)
2551 _ -> ImmLab False (ptext fn)
2553 -- move args from the integer vregs into which they have been
2554 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2555 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2557 move_final [] _ offset -- all args done
2560 move_final (v:vs) [] offset -- out of aregs; move to stack
2561 = ST W v (spRel offset)
2562 : move_final vs [] (offset+1)
2564 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2565 = OR False g0 (RIReg v) a
2566 : move_final vs az offset
2568 -- generate code to calculate an argument, and move it into one
2569 -- or two integer vregs.
2570 arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
2571 arg_to_int_vregs arg
2572 = getRegister arg `thenNat` \ register ->
2573 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2574 let code = registerCode register tmp
2575 src = registerName register tmp
2576 pk = registerRep register
2578 -- the value is in src. Get it into 1 or 2 int vregs.
2581 getNewRegNCG WordRep `thenNat` \ v1 ->
2582 getNewRegNCG WordRep `thenNat` \ v2 ->
2585 FMOV DF src f0 `snocOL`
2586 ST F f0 (spRel 16) `snocOL`
2587 LD W (spRel 16) v1 `snocOL`
2588 ST F (fPair f0) (spRel 16) `snocOL`
2594 getNewRegNCG WordRep `thenNat` \ v1 ->
2597 ST F src (spRel 16) `snocOL`
2603 getNewRegNCG WordRep `thenNat` \ v1 ->
2605 code `snocOL` OR False g0 (RIReg src) v1
2609 #endif {- sparc_TARGET_ARCH -}
2612 %************************************************************************
2614 \subsection{Support bits}
2616 %************************************************************************
2618 %************************************************************************
2620 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2622 %************************************************************************
2624 Turn those condition codes into integers now (when they appear on
2625 the right hand side of an assignment).
2627 (If applicable) Do not fill the delay slots here; you will confuse the
2631 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2633 #if alpha_TARGET_ARCH
2634 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2635 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2636 #endif {- alpha_TARGET_ARCH -}
2638 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2639 #if i386_TARGET_ARCH
2642 = condIntCode cond x y `thenNat` \ condition ->
2643 getNewRegNCG IntRep `thenNat` \ tmp ->
2645 code = condCode condition
2646 cond = condName condition
2647 code__2 dst = code `appOL` toOL [
2648 SETCC cond (OpReg tmp),
2649 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2650 MOV L (OpReg tmp) (OpReg dst)]
2652 returnNat (Any IntRep code__2)
2655 = getNatLabelNCG `thenNat` \ lbl1 ->
2656 getNatLabelNCG `thenNat` \ lbl2 ->
2657 condFltCode cond x y `thenNat` \ condition ->
2659 code = condCode condition
2660 cond = condName condition
2661 code__2 dst = code `appOL` toOL [
2663 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2666 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2669 returnNat (Any IntRep code__2)
2671 #endif {- i386_TARGET_ARCH -}
2672 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2673 #if sparc_TARGET_ARCH
2675 condIntReg EQQ x (StInt 0)
2676 = getRegister x `thenNat` \ register ->
2677 getNewRegNCG IntRep `thenNat` \ tmp ->
2679 code = registerCode register tmp
2680 src = registerName register tmp
2681 code__2 dst = code `appOL` toOL [
2682 SUB False True g0 (RIReg src) g0,
2683 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2685 returnNat (Any IntRep code__2)
2688 = getRegister x `thenNat` \ register1 ->
2689 getRegister y `thenNat` \ register2 ->
2690 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2691 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2693 code1 = registerCode register1 tmp1
2694 src1 = registerName register1 tmp1
2695 code2 = registerCode register2 tmp2
2696 src2 = registerName register2 tmp2
2697 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2698 XOR False src1 (RIReg src2) dst,
2699 SUB False True g0 (RIReg dst) g0,
2700 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2702 returnNat (Any IntRep code__2)
2704 condIntReg NE x (StInt 0)
2705 = getRegister x `thenNat` \ register ->
2706 getNewRegNCG IntRep `thenNat` \ tmp ->
2708 code = registerCode register tmp
2709 src = registerName register tmp
2710 code__2 dst = code `appOL` toOL [
2711 SUB False True g0 (RIReg src) g0,
2712 ADD True False g0 (RIImm (ImmInt 0)) dst]
2714 returnNat (Any IntRep code__2)
2717 = getRegister x `thenNat` \ register1 ->
2718 getRegister y `thenNat` \ register2 ->
2719 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2720 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2722 code1 = registerCode register1 tmp1
2723 src1 = registerName register1 tmp1
2724 code2 = registerCode register2 tmp2
2725 src2 = registerName register2 tmp2
2726 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2727 XOR False src1 (RIReg src2) dst,
2728 SUB False True g0 (RIReg dst) g0,
2729 ADD True False g0 (RIImm (ImmInt 0)) dst]
2731 returnNat (Any IntRep code__2)
2734 = getNatLabelNCG `thenNat` \ lbl1 ->
2735 getNatLabelNCG `thenNat` \ lbl2 ->
2736 condIntCode cond x y `thenNat` \ condition ->
2738 code = condCode condition
2739 cond = condName condition
2740 code__2 dst = code `appOL` toOL [
2741 BI cond False (ImmCLbl lbl1), NOP,
2742 OR False g0 (RIImm (ImmInt 0)) dst,
2743 BI ALWAYS False (ImmCLbl lbl2), NOP,
2745 OR False g0 (RIImm (ImmInt 1)) dst,
2748 returnNat (Any IntRep code__2)
2751 = getNatLabelNCG `thenNat` \ lbl1 ->
2752 getNatLabelNCG `thenNat` \ lbl2 ->
2753 condFltCode cond x y `thenNat` \ condition ->
2755 code = condCode condition
2756 cond = condName condition
2757 code__2 dst = code `appOL` toOL [
2759 BF cond False (ImmCLbl lbl1), NOP,
2760 OR False g0 (RIImm (ImmInt 0)) dst,
2761 BI ALWAYS False (ImmCLbl lbl2), NOP,
2763 OR False g0 (RIImm (ImmInt 1)) dst,
2766 returnNat (Any IntRep code__2)
2768 #endif {- sparc_TARGET_ARCH -}
2771 %************************************************************************
2773 \subsubsection{@trivial*Code@: deal with trivial instructions}
2775 %************************************************************************
2777 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2778 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2779 for constants on the right hand side, because that's where the generic
2780 optimizer will have put them.
2782 Similarly, for unary instructions, we don't have to worry about
2783 matching an StInt as the argument, because genericOpt will already
2784 have handled the constant-folding.
2788 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2789 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2790 -> Maybe (Operand -> Operand -> Instr)
2791 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2793 -> StixTree -> StixTree -- the two arguments
2798 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2799 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2800 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2802 -> StixTree -> StixTree -- the two arguments
2806 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2807 ,IF_ARCH_i386 ((Operand -> Instr)
2808 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2810 -> StixTree -- the one argument
2815 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2816 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2817 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2819 -> StixTree -- the one argument
2822 #if alpha_TARGET_ARCH
2824 trivialCode instr x (StInt y)
2826 = getRegister x `thenNat` \ register ->
2827 getNewRegNCG IntRep `thenNat` \ tmp ->
2829 code = registerCode register tmp
2830 src1 = registerName register tmp
2831 src2 = ImmInt (fromInteger y)
2832 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2834 returnNat (Any IntRep code__2)
2836 trivialCode instr x y
2837 = getRegister x `thenNat` \ register1 ->
2838 getRegister y `thenNat` \ register2 ->
2839 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2840 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2842 code1 = registerCode register1 tmp1 []
2843 src1 = registerName register1 tmp1
2844 code2 = registerCode register2 tmp2 []
2845 src2 = registerName register2 tmp2
2846 code__2 dst = asmSeqThen [code1, code2] .
2847 mkSeqInstr (instr src1 (RIReg src2) dst)
2849 returnNat (Any IntRep code__2)
2852 trivialUCode instr x
2853 = getRegister x `thenNat` \ register ->
2854 getNewRegNCG IntRep `thenNat` \ tmp ->
2856 code = registerCode register tmp
2857 src = registerName register tmp
2858 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2860 returnNat (Any IntRep code__2)
2863 trivialFCode _ instr x y
2864 = getRegister x `thenNat` \ register1 ->
2865 getRegister y `thenNat` \ register2 ->
2866 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2867 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2869 code1 = registerCode register1 tmp1
2870 src1 = registerName register1 tmp1
2872 code2 = registerCode register2 tmp2
2873 src2 = registerName register2 tmp2
2875 code__2 dst = asmSeqThen [code1 [], code2 []] .
2876 mkSeqInstr (instr src1 src2 dst)
2878 returnNat (Any DoubleRep code__2)
2880 trivialUFCode _ instr x
2881 = getRegister x `thenNat` \ register ->
2882 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2884 code = registerCode register tmp
2885 src = registerName register tmp
2886 code__2 dst = code . mkSeqInstr (instr src dst)
2888 returnNat (Any DoubleRep code__2)
2890 #endif {- alpha_TARGET_ARCH -}
2891 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2892 #if i386_TARGET_ARCH
2894 The Rules of the Game are:
2896 * You cannot assume anything about the destination register dst;
2897 it may be anything, including a fixed reg.
2899 * You may compute an operand into a fixed reg, but you may not
2900 subsequently change the contents of that fixed reg. If you
2901 want to do so, first copy the value either to a temporary
2902 or into dst. You are free to modify dst even if it happens
2903 to be a fixed reg -- that's not your problem.
2905 * You cannot assume that a fixed reg will stay live over an
2906 arbitrary computation. The same applies to the dst reg.
2908 * Temporary regs obtained from getNewRegNCG are distinct from
2909 each other and from all other regs, and stay live over
2910 arbitrary computations.
2914 trivialCode instr maybe_revinstr a b
2917 = getRegister a `thenNat` \ rega ->
2920 then registerCode rega dst `bind` \ code_a ->
2922 instr (OpImm imm_b) (OpReg dst)
2923 else registerCodeF rega `bind` \ code_a ->
2924 registerNameF rega `bind` \ r_a ->
2926 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2927 instr (OpImm imm_b) (OpReg dst)
2929 returnNat (Any IntRep mkcode)
2932 = getRegister b `thenNat` \ regb ->
2933 getNewRegNCG IntRep `thenNat` \ tmp ->
2934 let revinstr_avail = maybeToBool maybe_revinstr
2935 revinstr = case maybe_revinstr of Just ri -> ri
2939 then registerCode regb dst `bind` \ code_b ->
2941 revinstr (OpImm imm_a) (OpReg dst)
2942 else registerCodeF regb `bind` \ code_b ->
2943 registerNameF regb `bind` \ r_b ->
2945 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2946 revinstr (OpImm imm_a) (OpReg dst)
2950 then registerCode regb tmp `bind` \ code_b ->
2952 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2953 instr (OpReg tmp) (OpReg dst)
2954 else registerCodeF regb `bind` \ code_b ->
2955 registerNameF regb `bind` \ r_b ->
2957 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2958 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2959 instr (OpReg tmp) (OpReg dst)
2961 returnNat (Any IntRep mkcode)
2964 = getRegister a `thenNat` \ rega ->
2965 getRegister b `thenNat` \ regb ->
2966 getNewRegNCG IntRep `thenNat` \ tmp ->
2968 = case (isAny rega, isAny regb) of
2970 -> registerCode regb tmp `bind` \ code_b ->
2971 registerCode rega dst `bind` \ code_a ->
2974 instr (OpReg tmp) (OpReg dst)
2976 -> registerCode rega tmp `bind` \ code_a ->
2977 registerCodeF regb `bind` \ code_b ->
2978 registerNameF regb `bind` \ r_b ->
2981 instr (OpReg r_b) (OpReg tmp) `snocOL`
2982 MOV L (OpReg tmp) (OpReg dst)
2984 -> registerCode regb tmp `bind` \ code_b ->
2985 registerCodeF rega `bind` \ code_a ->
2986 registerNameF rega `bind` \ r_a ->
2989 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2990 instr (OpReg tmp) (OpReg dst)
2992 -> registerCodeF rega `bind` \ code_a ->
2993 registerNameF rega `bind` \ r_a ->
2994 registerCodeF regb `bind` \ code_b ->
2995 registerNameF regb `bind` \ r_b ->
2997 MOV L (OpReg r_a) (OpReg tmp) `appOL`
2999 instr (OpReg r_b) (OpReg tmp) `snocOL`
3000 MOV L (OpReg tmp) (OpReg dst)
3002 returnNat (Any IntRep mkcode)
3005 maybe_imm_a = maybeImm a
3006 is_imm_a = maybeToBool maybe_imm_a
3007 imm_a = case maybe_imm_a of Just imm -> imm
3009 maybe_imm_b = maybeImm b
3010 is_imm_b = maybeToBool maybe_imm_b
3011 imm_b = case maybe_imm_b of Just imm -> imm
3015 trivialUCode instr x
3016 = getRegister x `thenNat` \ register ->
3018 code__2 dst = let code = registerCode register dst
3019 src = registerName register dst
3021 if isFixed register && dst /= src
3022 then toOL [MOV L (OpReg src) (OpReg dst),
3024 else unitOL (instr (OpReg src))
3026 returnNat (Any IntRep code__2)
3029 trivialFCode pk instr x y
3030 = getRegister x `thenNat` \ register1 ->
3031 getRegister y `thenNat` \ register2 ->
3032 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3033 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3035 code1 = registerCode register1 tmp1
3036 src1 = registerName register1 tmp1
3038 code2 = registerCode register2 tmp2
3039 src2 = registerName register2 tmp2
3042 -- treat the common case specially: both operands in
3044 | isAny register1 && isAny register2
3047 instr (primRepToSize pk) src1 src2 dst
3049 -- be paranoid (and inefficient)
3051 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3053 instr (primRepToSize pk) tmp1 src2 dst
3055 returnNat (Any pk code__2)
3059 trivialUFCode pk instr x
3060 = getRegister x `thenNat` \ register ->
3061 getNewRegNCG pk `thenNat` \ tmp ->
3063 code = registerCode register tmp
3064 src = registerName register tmp
3065 code__2 dst = code `snocOL` instr src dst
3067 returnNat (Any pk code__2)
3069 #endif {- i386_TARGET_ARCH -}
3070 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3071 #if sparc_TARGET_ARCH
3073 trivialCode instr x (StInt y)
3075 = getRegister x `thenNat` \ register ->
3076 getNewRegNCG IntRep `thenNat` \ tmp ->
3078 code = registerCode register tmp
3079 src1 = registerName register tmp
3080 src2 = ImmInt (fromInteger y)
3081 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3083 returnNat (Any IntRep code__2)
3085 trivialCode instr x y
3086 = getRegister x `thenNat` \ register1 ->
3087 getRegister y `thenNat` \ register2 ->
3088 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3089 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3091 code1 = registerCode register1 tmp1
3092 src1 = registerName register1 tmp1
3093 code2 = registerCode register2 tmp2
3094 src2 = registerName register2 tmp2
3095 code__2 dst = code1 `appOL` code2 `snocOL`
3096 instr src1 (RIReg src2) dst
3098 returnNat (Any IntRep code__2)
3101 trivialFCode pk instr x y
3102 = getRegister x `thenNat` \ register1 ->
3103 getRegister y `thenNat` \ register2 ->
3104 getNewRegNCG (registerRep register1)
3106 getNewRegNCG (registerRep register2)
3108 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3110 promote x = FxTOy F DF x tmp
3112 pk1 = registerRep register1
3113 code1 = registerCode register1 tmp1
3114 src1 = registerName register1 tmp1
3116 pk2 = registerRep register2
3117 code2 = registerCode register2 tmp2
3118 src2 = registerName register2 tmp2
3122 code1 `appOL` code2 `snocOL`
3123 instr (primRepToSize pk) src1 src2 dst
3124 else if pk1 == FloatRep then
3125 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3126 instr DF tmp src2 dst
3128 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3129 instr DF src1 tmp dst
3131 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3134 trivialUCode instr x
3135 = getRegister x `thenNat` \ register ->
3136 getNewRegNCG IntRep `thenNat` \ tmp ->
3138 code = registerCode register tmp
3139 src = registerName register tmp
3140 code__2 dst = code `snocOL` instr (RIReg src) dst
3142 returnNat (Any IntRep code__2)
3145 trivialUFCode pk instr x
3146 = getRegister x `thenNat` \ register ->
3147 getNewRegNCG pk `thenNat` \ tmp ->
3149 code = registerCode register tmp
3150 src = registerName register tmp
3151 code__2 dst = code `snocOL` instr src dst
3153 returnNat (Any pk code__2)
3155 #endif {- sparc_TARGET_ARCH -}
3158 %************************************************************************
3160 \subsubsection{Coercing to/from integer/floating-point...}
3162 %************************************************************************
3164 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3165 to be generated. Here we just change the type on the Register passed
3166 on up. The code is machine-independent.
3168 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3169 conversions. We have to store temporaries in memory to move
3170 between the integer and the floating point register sets.
3173 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3174 coerceFltCode :: StixTree -> NatM Register
3176 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3177 coerceFP2Int :: StixTree -> NatM Register
3180 = getRegister x `thenNat` \ register ->
3183 Fixed _ reg code -> Fixed pk reg code
3184 Any _ code -> Any pk code
3189 = getRegister x `thenNat` \ register ->
3192 Fixed _ reg code -> Fixed DoubleRep reg code
3193 Any _ code -> Any DoubleRep code
3198 #if alpha_TARGET_ARCH
3201 = getRegister x `thenNat` \ register ->
3202 getNewRegNCG IntRep `thenNat` \ reg ->
3204 code = registerCode register reg
3205 src = registerName register reg
3207 code__2 dst = code . mkSeqInstrs [
3209 LD TF dst (spRel 0),
3212 returnNat (Any DoubleRep code__2)
3216 = getRegister x `thenNat` \ register ->
3217 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3219 code = registerCode register tmp
3220 src = registerName register tmp
3222 code__2 dst = code . mkSeqInstrs [
3224 ST TF tmp (spRel 0),
3227 returnNat (Any IntRep code__2)
3229 #endif {- alpha_TARGET_ARCH -}
3230 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3231 #if i386_TARGET_ARCH
3234 = getRegister x `thenNat` \ register ->
3235 getNewRegNCG IntRep `thenNat` \ reg ->
3237 code = registerCode register reg
3238 src = registerName register reg
3239 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3240 code__2 dst = code `snocOL` opc src dst
3242 returnNat (Any pk code__2)
3246 = getRegister x `thenNat` \ register ->
3247 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3249 code = registerCode register tmp
3250 src = registerName register tmp
3251 pk = registerRep register
3253 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3254 code__2 dst = code `snocOL` opc src dst
3256 returnNat (Any IntRep code__2)
3258 #endif {- i386_TARGET_ARCH -}
3259 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3260 #if sparc_TARGET_ARCH
3263 = getRegister x `thenNat` \ register ->
3264 getNewRegNCG IntRep `thenNat` \ reg ->
3266 code = registerCode register reg
3267 src = registerName register reg
3269 code__2 dst = code `appOL` toOL [
3270 ST W src (spRel (-2)),
3271 LD W (spRel (-2)) dst,
3272 FxTOy W (primRepToSize pk) dst dst]
3274 returnNat (Any pk code__2)
3278 = getRegister x `thenNat` \ register ->
3279 getNewRegNCG IntRep `thenNat` \ reg ->
3280 getNewRegNCG FloatRep `thenNat` \ tmp ->
3282 code = registerCode register reg
3283 src = registerName register reg
3284 pk = registerRep register
3286 code__2 dst = code `appOL` toOL [
3287 FxTOy (primRepToSize pk) W src tmp,
3288 ST W tmp (spRel (-2)),
3289 LD W (spRel (-2)) dst]
3291 returnNat (Any IntRep code__2)
3293 #endif {- sparc_TARGET_ARCH -}
3296 %************************************************************************
3298 \subsubsection{Coercing integer to @Char@...}
3300 %************************************************************************
3302 Integer to character conversion.
3305 chrCode :: StixTree -> NatM Register
3307 #if alpha_TARGET_ARCH
3309 -- TODO: This is probably wrong, but I don't know Alpha assembler.
3310 -- It should coerce a 64-bit value to a 32-bit value.
3313 = getRegister x `thenNat` \ register ->
3314 getNewRegNCG IntRep `thenNat` \ reg ->
3316 code = registerCode register reg
3317 src = registerName register reg
3318 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3320 returnNat (Any IntRep code__2)
3322 #endif {- alpha_TARGET_ARCH -}
3323 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3324 #if i386_TARGET_ARCH
3327 = getRegister x `thenNat` \ register ->
3330 Fixed _ reg code -> Fixed IntRep reg code
3331 Any _ code -> Any IntRep code
3334 #endif {- i386_TARGET_ARCH -}
3335 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3336 #if sparc_TARGET_ARCH
3339 = getRegister x `thenNat` \ register ->
3342 Fixed _ reg code -> Fixed IntRep reg code
3343 Any _ code -> Any IntRep code
3346 #endif {- sparc_TARGET_ARCH -}