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 ForeignCall ( CCallConv(..) )
23 import CLabel ( CLabel, labelDynamic )
24 #if sparc_TARGET_ARCH || alpha_TARGET_ARCH
25 import CLabel ( isAsmTemp )
27 import Maybes ( maybeToBool )
28 import PrimRep ( isFloatingRep, PrimRep(..) )
29 import PrimOp ( PrimOp(..) )
30 import Stix ( getNatLabelNCG, StixTree(..),
31 StixReg(..), CodeSegment(..),
32 DestInfo, hasDestInfo,
34 NatM, thenNat, returnNat, mapNat,
35 mapAndUnzipNat, mapAccumLNat,
36 getDeltaNat, setDeltaNat
39 import CmdLineOpts ( opt_Static )
45 @InstrBlock@s are the insn sequences generated by the insn selectors.
46 They are really trees of insns to facilitate fast appending, where a
47 left-to-right traversal (pre-order?) yields the insns in the correct
52 type InstrBlock = OrdList Instr
58 Code extractor for an entire stix tree---stix statement level.
61 stmtsToInstrs :: [StixTree] -> NatM InstrBlock
63 = liftStrings stmts [] [] `thenNat` \ lifted ->
64 mapNat stmtToInstrs lifted `thenNat` \ instrss ->
65 returnNat (concatOL instrss)
68 -- Lift StStrings out of top-level StDatas, putting them at the end of
69 -- the block, and replacing them with StCLbls which refer to the lifted-out strings.
70 {- Motivation for this hackery provided by the following bug:
74 (Data P_ Addr.A#_static_info)
75 (Data StgAddr (Str `alalal'))
80 .global Bogon_ping_closure
82 .long Addr_Azh_static_info
93 ie, the Str is planted in-line, when what we really meant was to place
94 a _reference_ to the string there. liftStrings will lift out all such
95 strings in top-level data and place them at the end of the block.
97 This is still a rather half-baked solution -- to do the job entirely right
98 would mean a complete traversal of all the Stixes, but there's currently no
99 real need for it, and it would be slow. Also, potentially there could be
100 literal types other than strings which need lifting out?
103 liftStrings :: [StixTree] -- originals
104 -> [StixTree] -- (reverse) originals with strings lifted out
105 -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels
108 -- First, examine the original trees and lift out strings in top-level StDatas.
109 liftStrings (st:sts) acc_stix acc_strs
112 -> lift datas acc_strs `thenNat` \ (datas_done, acc_strs1) ->
113 liftStrings sts ((StData sz datas_done):acc_stix) acc_strs1
115 -> liftStrings sts (other:acc_stix) acc_strs
117 -- Handle a top-level StData
118 lift [] acc_strs = returnNat ([], acc_strs)
120 = lift ds acc_strs `thenNat` \ (ds_done, acc_strs1) ->
123 -> getNatLabelNCG `thenNat` \ lbl ->
124 returnNat ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
126 -> returnNat (other:ds_done, acc_strs1)
128 -- When we've run out of original trees, emit the lifted strings.
129 liftStrings [] acc_stix acc_strs
130 = returnNat (reverse acc_stix ++ concatMap f acc_strs)
132 f (lbl,str) = [StSegment RoDataSegment,
135 StSegment TextSegment]
138 stmtToInstrs :: StixTree {- a stix statement -} -> NatM InstrBlock
139 stmtToInstrs stmt = case stmt of
140 StComment s -> returnNat (unitOL (COMMENT s))
141 StSegment seg -> returnNat (unitOL (SEGMENT seg))
143 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
145 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
148 StLabel lab -> returnNat (unitOL (LABEL lab))
150 StJump dsts arg -> genJump dsts (derefDLL arg)
151 StCondJump lab arg -> genCondJump lab (derefDLL arg)
153 -- A call returning void, ie one done for its side-effects
154 StCall fn cconv VoidRep args -> genCCall fn
155 cconv VoidRep (map derefDLL args)
158 | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
159 | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
162 -- When falling through on the Alpha, we still have to load pv
163 -- with the address of the next routine, so that it can load gp.
164 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
168 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
169 returnNat (DATA (primRepToSize kind) imms
170 `consOL` concatOL codes)
172 getData :: StixTree -> NatM (InstrBlock, Imm)
173 getData (StInt i) = returnNat (nilOL, ImmInteger i)
174 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
175 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
176 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
177 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
178 -- the linker can handle simple arithmetic...
179 getData (StIndex rep (StCLbl lbl) (StInt off)) =
181 ImmIndex lbl (fromInteger off * sizeOf rep))
183 -- Top-level lifted-out string. The segment will already have been set
184 -- (see liftStrings above).
186 -> returnNat (unitOL (ASCII True (_UNPK_ str)))
189 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
190 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
191 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
193 derefDLL :: StixTree -> StixTree
195 | opt_Static -- short out the entire deal if not doing DLLs
202 StCLbl lbl -> if labelDynamic lbl
203 then StInd PtrRep (StCLbl lbl)
205 -- all the rest are boring
206 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
207 StPrim pk args -> StPrim pk (map qq args)
208 StInd pk addr -> StInd pk (qq addr)
209 StCall who cc pk args -> StCall who cc pk (map qq args)
216 _ -> pprPanic "derefDLL: unhandled case"
220 %************************************************************************
222 \subsection{General things for putting together code sequences}
224 %************************************************************************
227 mangleIndexTree :: StixTree -> StixTree
229 mangleIndexTree (StIndex pk base (StInt i))
230 = StPrim IntAddOp [base, off]
232 off = StInt (i * toInteger (sizeOf pk))
234 mangleIndexTree (StIndex pk base off)
238 in if s == 0 then off else StPrim SllOp [off, StInt (toInteger s)]
241 shift :: PrimRep -> Int
242 shift rep = case sizeOf rep of
247 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
252 maybeImm :: StixTree -> Maybe Imm
256 maybeImm (StIndex rep (StCLbl l) (StInt off))
257 = Just (ImmIndex l (fromInteger off * sizeOf rep))
259 | i >= toInteger minInt && i <= toInteger maxInt
260 = Just (ImmInt (fromInteger i))
262 = Just (ImmInteger i)
267 %************************************************************************
269 \subsection{The @Register@ type}
271 %************************************************************************
273 @Register@s passed up the tree. If the stix code forces the register
274 to live in a pre-decided machine register, it comes out as @Fixed@;
275 otherwise, it comes out as @Any@, and the parent can decide which
276 register to put it in.
280 = Fixed PrimRep Reg InstrBlock
281 | Any PrimRep (Reg -> InstrBlock)
283 registerCode :: Register -> Reg -> InstrBlock
284 registerCode (Fixed _ _ code) reg = code
285 registerCode (Any _ code) reg = code reg
287 registerCodeF (Fixed _ _ code) = code
288 registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
290 registerCodeA (Any _ code) = code
291 registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
293 registerName :: Register -> Reg -> Reg
294 registerName (Fixed _ reg _) _ = reg
295 registerName (Any _ _) reg = reg
297 registerNameF (Fixed _ reg _) = reg
298 registerNameF (Any _ _) = pprPanic "registerNameF" empty
300 registerRep :: Register -> PrimRep
301 registerRep (Fixed pk _ _) = pk
302 registerRep (Any pk _) = pk
304 {-# INLINE registerCode #-}
305 {-# INLINE registerCodeF #-}
306 {-# INLINE registerName #-}
307 {-# INLINE registerNameF #-}
308 {-# INLINE registerRep #-}
309 {-# INLINE isFixed #-}
312 isFixed, isAny :: Register -> Bool
313 isFixed (Fixed _ _ _) = True
314 isFixed (Any _ _) = False
316 isAny = not . isFixed
319 Generate code to get a subtree into a @Register@:
321 getRegister :: StixTree -> NatM Register
323 getRegister (StReg (StixMagicId stgreg))
324 = case (magicIdRegMaybe stgreg) of
325 Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
328 getRegister (StReg (StixTemp u pk))
329 = returnNat (Fixed pk (mkVReg u pk) nilOL)
331 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
333 getRegister (StCall fn cconv kind args)
334 = genCCall fn cconv kind args `thenNat` \ call ->
335 returnNat (Fixed kind reg call)
337 reg = if isFloatingRep kind
338 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
339 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
341 getRegister (StString s)
342 = getNatLabelNCG `thenNat` \ lbl ->
344 imm_lbl = ImmCLbl lbl
347 SEGMENT RoDataSegment,
349 ASCII True (_UNPK_ s),
351 #if alpha_TARGET_ARCH
352 LDA dst (AddrImm imm_lbl)
355 MOV L (OpImm imm_lbl) (OpReg dst)
357 #if sparc_TARGET_ARCH
358 SETHI (HI imm_lbl) dst,
359 OR False dst (RIImm (LO imm_lbl)) dst
363 returnNat (Any PtrRep code)
367 -- end of machine-"independent" bit; here we go on the rest...
369 #if alpha_TARGET_ARCH
371 getRegister (StDouble d)
372 = getNatLabelNCG `thenNat` \ lbl ->
373 getNewRegNCG PtrRep `thenNat` \ tmp ->
374 let code dst = mkSeqInstrs [
377 DATA TF [ImmLab (rational d)],
379 LDA tmp (AddrImm (ImmCLbl lbl)),
380 LD TF dst (AddrReg tmp)]
382 returnNat (Any DoubleRep code)
384 getRegister (StPrim primop [x]) -- unary PrimOps
386 IntNegOp -> trivialUCode (NEG Q False) x
388 NotOp -> trivialUCode NOT x
390 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
391 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
393 OrdOp -> coerceIntCode IntRep x
396 Float2IntOp -> coerceFP2Int x
397 Int2FloatOp -> coerceInt2FP pr x
398 Double2IntOp -> coerceFP2Int x
399 Int2DoubleOp -> coerceInt2FP pr x
401 Double2FloatOp -> coerceFltCode x
402 Float2DoubleOp -> coerceFltCode x
404 other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
406 fn = case other_op of
407 FloatExpOp -> SLIT("exp")
408 FloatLogOp -> SLIT("log")
409 FloatSqrtOp -> SLIT("sqrt")
410 FloatSinOp -> SLIT("sin")
411 FloatCosOp -> SLIT("cos")
412 FloatTanOp -> SLIT("tan")
413 FloatAsinOp -> SLIT("asin")
414 FloatAcosOp -> SLIT("acos")
415 FloatAtanOp -> SLIT("atan")
416 FloatSinhOp -> SLIT("sinh")
417 FloatCoshOp -> SLIT("cosh")
418 FloatTanhOp -> SLIT("tanh")
419 DoubleExpOp -> SLIT("exp")
420 DoubleLogOp -> SLIT("log")
421 DoubleSqrtOp -> SLIT("sqrt")
422 DoubleSinOp -> SLIT("sin")
423 DoubleCosOp -> SLIT("cos")
424 DoubleTanOp -> SLIT("tan")
425 DoubleAsinOp -> SLIT("asin")
426 DoubleAcosOp -> SLIT("acos")
427 DoubleAtanOp -> SLIT("atan")
428 DoubleSinhOp -> SLIT("sinh")
429 DoubleCoshOp -> SLIT("cosh")
430 DoubleTanhOp -> SLIT("tanh")
432 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
434 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
436 CharGtOp -> trivialCode (CMP LTT) y x
437 CharGeOp -> trivialCode (CMP LE) y x
438 CharEqOp -> trivialCode (CMP EQQ) x y
439 CharNeOp -> int_NE_code x y
440 CharLtOp -> trivialCode (CMP LTT) x y
441 CharLeOp -> trivialCode (CMP LE) x y
443 IntGtOp -> trivialCode (CMP LTT) y x
444 IntGeOp -> trivialCode (CMP LE) y x
445 IntEqOp -> trivialCode (CMP EQQ) x y
446 IntNeOp -> int_NE_code x y
447 IntLtOp -> trivialCode (CMP LTT) x y
448 IntLeOp -> trivialCode (CMP LE) x y
450 WordGtOp -> trivialCode (CMP ULT) y x
451 WordGeOp -> trivialCode (CMP ULE) x y
452 WordEqOp -> trivialCode (CMP EQQ) x y
453 WordNeOp -> int_NE_code x y
454 WordLtOp -> trivialCode (CMP ULT) x y
455 WordLeOp -> trivialCode (CMP ULE) x y
457 AddrGtOp -> trivialCode (CMP ULT) y x
458 AddrGeOp -> trivialCode (CMP ULE) y x
459 AddrEqOp -> trivialCode (CMP EQQ) x y
460 AddrNeOp -> int_NE_code x y
461 AddrLtOp -> trivialCode (CMP ULT) x y
462 AddrLeOp -> trivialCode (CMP ULE) x y
464 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
465 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
466 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
467 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
468 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
469 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
471 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
472 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
473 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
474 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
475 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
476 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
478 IntAddOp -> trivialCode (ADD Q False) x y
479 IntSubOp -> trivialCode (SUB Q False) x y
480 IntMulOp -> trivialCode (MUL Q False) x y
481 IntQuotOp -> trivialCode (DIV Q False) x y
482 IntRemOp -> trivialCode (REM Q False) x y
484 WordAddOp -> trivialCode (ADD Q False) x y
485 WordSubOp -> trivialCode (SUB Q False) x y
486 WordMulOp -> trivialCode (MUL Q False) x y
487 WordQuotOp -> trivialCode (DIV Q True) x y
488 WordRemOp -> trivialCode (REM Q True) x y
490 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
491 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
492 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
493 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
495 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
496 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
497 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
498 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
500 AddrAddOp -> trivialCode (ADD Q False) x y
501 AddrSubOp -> trivialCode (SUB Q False) x y
502 AddrRemOp -> trivialCode (REM Q True) x y
504 AndOp -> trivialCode AND x y
505 OrOp -> trivialCode OR x y
506 XorOp -> trivialCode XOR x y
507 SllOp -> trivialCode SLL x y
508 SrlOp -> trivialCode SRL x y
510 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
511 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
512 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
514 FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
515 DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
517 {- ------------------------------------------------------------
518 Some bizarre special code for getting condition codes into
519 registers. Integer non-equality is a test for equality
520 followed by an XOR with 1. (Integer comparisons always set
521 the result register to 0 or 1.) Floating point comparisons of
522 any kind leave the result in a floating point register, so we
523 need to wrangle an integer register out of things.
525 int_NE_code :: StixTree -> StixTree -> NatM Register
528 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
529 getNewRegNCG IntRep `thenNat` \ tmp ->
531 code = registerCode register tmp
532 src = registerName register tmp
533 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
535 returnNat (Any IntRep code__2)
537 {- ------------------------------------------------------------
538 Comments for int_NE_code also apply to cmpF_code
541 :: (Reg -> Reg -> Reg -> Instr)
543 -> StixTree -> StixTree
546 cmpF_code instr cond x y
547 = trivialFCode pr instr x y `thenNat` \ register ->
548 getNewRegNCG DoubleRep `thenNat` \ tmp ->
549 getNatLabelNCG `thenNat` \ lbl ->
551 code = registerCode register tmp
552 result = registerName register tmp
554 code__2 dst = code . mkSeqInstrs [
555 OR zeroh (RIImm (ImmInt 1)) dst,
556 BF cond result (ImmCLbl lbl),
557 OR zeroh (RIReg zeroh) dst,
560 returnNat (Any IntRep code__2)
562 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
563 ------------------------------------------------------------
565 getRegister (StInd pk mem)
566 = getAmode mem `thenNat` \ amode ->
568 code = amodeCode amode
569 src = amodeAddr amode
570 size = primRepToSize pk
571 code__2 dst = code . mkSeqInstr (LD size dst src)
573 returnNat (Any pk code__2)
575 getRegister (StInt i)
578 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
580 returnNat (Any IntRep code)
583 code dst = mkSeqInstr (LDI Q dst src)
585 returnNat (Any IntRep code)
587 src = ImmInt (fromInteger i)
592 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
594 returnNat (Any PtrRep code)
597 imm__2 = case imm of Just x -> x
599 #endif {- alpha_TARGET_ARCH -}
600 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
603 getRegister (StFloat f)
604 = getNatLabelNCG `thenNat` \ lbl ->
605 let code dst = toOL [
610 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
613 returnNat (Any FloatRep code)
616 getRegister (StDouble d)
619 = let code dst = unitOL (GLDZ dst)
620 in returnNat (Any DoubleRep code)
623 = let code dst = unitOL (GLD1 dst)
624 in returnNat (Any DoubleRep code)
627 = getNatLabelNCG `thenNat` \ lbl ->
628 let code dst = toOL [
631 DATA DF [ImmDouble d],
633 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
636 returnNat (Any DoubleRep code)
638 -- Calculate the offset for (i+1) words above the _initial_
639 -- %esp value by first determining the current offset of it.
640 getRegister (StScratchWord i)
642 = getDeltaNat `thenNat` \ current_stack_offset ->
643 let j = i+1 - (current_stack_offset `div` 4)
645 = unitOL (LEA L (OpAddr (spRel j)) (OpReg dst))
647 returnNat (Any PtrRep code)
649 getRegister (StPrim primop [x]) -- unary PrimOps
651 IntNegOp -> trivialUCode (NEGI L) x
652 NotOp -> trivialUCode (NOT L) x
654 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
655 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
657 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
658 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
660 FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
661 DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
663 FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
664 DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
666 FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
667 DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
669 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
670 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
672 OrdOp -> coerceIntCode IntRep x
675 Float2IntOp -> coerceFP2Int x
676 Int2FloatOp -> coerceInt2FP FloatRep x
677 Double2IntOp -> coerceFP2Int x
678 Int2DoubleOp -> coerceInt2FP DoubleRep x
681 getRegister (StCall fn CCallConv DoubleRep [x])
685 FloatExpOp -> (True, SLIT("exp"))
686 FloatLogOp -> (True, SLIT("log"))
688 FloatAsinOp -> (True, SLIT("asin"))
689 FloatAcosOp -> (True, SLIT("acos"))
690 FloatAtanOp -> (True, SLIT("atan"))
692 FloatSinhOp -> (True, SLIT("sinh"))
693 FloatCoshOp -> (True, SLIT("cosh"))
694 FloatTanhOp -> (True, SLIT("tanh"))
696 DoubleExpOp -> (False, SLIT("exp"))
697 DoubleLogOp -> (False, SLIT("log"))
699 DoubleAsinOp -> (False, SLIT("asin"))
700 DoubleAcosOp -> (False, SLIT("acos"))
701 DoubleAtanOp -> (False, SLIT("atan"))
703 DoubleSinhOp -> (False, SLIT("sinh"))
704 DoubleCoshOp -> (False, SLIT("cosh"))
705 DoubleTanhOp -> (False, SLIT("tanh"))
708 -> pprPanic "getRegister(x86,unary primop)"
709 (pprStixTree (StPrim primop [x]))
711 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
713 CharGtOp -> condIntReg GTT x y
714 CharGeOp -> condIntReg GE x y
715 CharEqOp -> condIntReg EQQ x y
716 CharNeOp -> condIntReg NE x y
717 CharLtOp -> condIntReg LTT x y
718 CharLeOp -> condIntReg LE x y
720 IntGtOp -> condIntReg GTT x y
721 IntGeOp -> condIntReg GE x y
722 IntEqOp -> condIntReg EQQ x y
723 IntNeOp -> condIntReg NE x y
724 IntLtOp -> condIntReg LTT x y
725 IntLeOp -> condIntReg LE x y
727 WordGtOp -> condIntReg GU x y
728 WordGeOp -> condIntReg GEU x y
729 WordEqOp -> condIntReg EQQ x y
730 WordNeOp -> condIntReg NE x y
731 WordLtOp -> condIntReg LU x y
732 WordLeOp -> condIntReg LEU x y
734 AddrGtOp -> condIntReg GU x y
735 AddrGeOp -> condIntReg GEU x y
736 AddrEqOp -> condIntReg EQQ x y
737 AddrNeOp -> condIntReg NE x y
738 AddrLtOp -> condIntReg LU x y
739 AddrLeOp -> condIntReg LEU x y
741 FloatGtOp -> condFltReg GTT x y
742 FloatGeOp -> condFltReg GE x y
743 FloatEqOp -> condFltReg EQQ x y
744 FloatNeOp -> condFltReg NE x y
745 FloatLtOp -> condFltReg LTT x y
746 FloatLeOp -> condFltReg LE x y
748 DoubleGtOp -> condFltReg GTT x y
749 DoubleGeOp -> condFltReg GE x y
750 DoubleEqOp -> condFltReg EQQ x y
751 DoubleNeOp -> condFltReg NE x y
752 DoubleLtOp -> condFltReg LTT x y
753 DoubleLeOp -> condFltReg LE x y
755 IntAddOp -> add_code L x y
756 IntSubOp -> sub_code L x y
757 IntQuotOp -> trivialCode (IQUOT L) Nothing x y
758 IntRemOp -> trivialCode (IREM L) Nothing x y
759 IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
761 WordAddOp -> add_code L x y
762 WordSubOp -> sub_code L x y
763 WordMulOp -> let op = IMUL L in trivialCode op (Just op) x y
765 FloatAddOp -> trivialFCode FloatRep GADD x y
766 FloatSubOp -> trivialFCode FloatRep GSUB x y
767 FloatMulOp -> trivialFCode FloatRep GMUL x y
768 FloatDivOp -> trivialFCode FloatRep GDIV x y
770 DoubleAddOp -> trivialFCode DoubleRep GADD x y
771 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
772 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
773 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
775 AddrAddOp -> add_code L x y
776 AddrSubOp -> sub_code L x y
777 AddrRemOp -> trivialCode (IREM L) Nothing x y
779 AndOp -> let op = AND L in trivialCode op (Just op) x y
780 OrOp -> let op = OR L in trivialCode op (Just op) x y
781 XorOp -> let op = XOR L in trivialCode op (Just op) x y
783 {- Shift ops on x86s have constraints on their source, it
784 either has to be Imm, CL or 1
785 => trivialCode's is not restrictive enough (sigh.)
788 SllOp -> shift_code (SHL L) x y {-False-}
789 SrlOp -> shift_code (SHR L) x y {-False-}
790 ISllOp -> shift_code (SHL L) x y {-False-}
791 ISraOp -> shift_code (SAR L) x y {-False-}
792 ISrlOp -> shift_code (SHR L) x y {-False-}
794 FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
795 [promote x, promote y])
796 where promote x = StPrim Float2DoubleOp [x]
797 DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
800 -> pprPanic "getRegister(x86,dyadic primop)"
801 (pprStixTree (StPrim primop [x, y]))
805 shift_code :: (Imm -> Operand -> Instr)
810 {- Case1: shift length as immediate -}
811 -- Code is the same as the first eq. for trivialCode -- sigh.
812 shift_code instr x y{-amount-}
814 = getRegister x `thenNat` \ regx ->
817 then registerCodeA regx dst `bind` \ code_x ->
819 instr imm__2 (OpReg dst)
820 else registerCodeF regx `bind` \ code_x ->
821 registerNameF regx `bind` \ r_x ->
823 MOV L (OpReg r_x) (OpReg dst) `snocOL`
824 instr imm__2 (OpReg dst)
826 returnNat (Any IntRep mkcode)
829 imm__2 = case imm of Just x -> x
831 {- Case2: shift length is complex (non-immediate) -}
832 -- Since ECX is always used as a spill temporary, we can't
833 -- use it here to do non-immediate shifts. No big deal --
834 -- they are only very rare, and we can use an equivalent
835 -- test-and-jump sequence which doesn't use ECX.
836 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
837 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
838 shift_code instr x y{-amount-}
839 = getRegister x `thenNat` \ register1 ->
840 getRegister y `thenNat` \ register2 ->
841 getNatLabelNCG `thenNat` \ lbl_test3 ->
842 getNatLabelNCG `thenNat` \ lbl_test2 ->
843 getNatLabelNCG `thenNat` \ lbl_test1 ->
844 getNatLabelNCG `thenNat` \ lbl_test0 ->
845 getNatLabelNCG `thenNat` \ lbl_after ->
846 getNewRegNCG IntRep `thenNat` \ tmp ->
848 = let src_val = registerName register1 dst
849 code_val = registerCode register1 dst
850 src_amt = registerName register2 tmp
851 code_amt = registerCode register2 tmp
856 MOV L (OpReg src_amt) r_tmp `appOL`
858 MOV L (OpReg src_val) r_dst `appOL`
860 COMMENT (_PK_ "begin shift sequence"),
861 MOV L (OpReg src_val) r_dst,
862 MOV L (OpReg src_amt) r_tmp,
864 BT L (ImmInt 4) r_tmp,
866 instr (ImmInt 16) r_dst,
869 BT L (ImmInt 3) r_tmp,
871 instr (ImmInt 8) r_dst,
874 BT L (ImmInt 2) r_tmp,
876 instr (ImmInt 4) r_dst,
879 BT L (ImmInt 1) r_tmp,
881 instr (ImmInt 2) r_dst,
884 BT L (ImmInt 0) r_tmp,
886 instr (ImmInt 1) r_dst,
889 COMMENT (_PK_ "end shift sequence")
892 returnNat (Any IntRep code__2)
895 add_code :: Size -> StixTree -> StixTree -> NatM Register
897 add_code sz x (StInt y)
898 = getRegister x `thenNat` \ register ->
899 getNewRegNCG IntRep `thenNat` \ tmp ->
901 code = registerCode register tmp
902 src1 = registerName register tmp
903 src2 = ImmInt (fromInteger y)
906 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
909 returnNat (Any IntRep code__2)
911 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
914 sub_code :: Size -> StixTree -> StixTree -> NatM Register
916 sub_code sz x (StInt y)
917 = getRegister x `thenNat` \ register ->
918 getNewRegNCG IntRep `thenNat` \ tmp ->
920 code = registerCode register tmp
921 src1 = registerName register tmp
922 src2 = ImmInt (-(fromInteger y))
925 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
928 returnNat (Any IntRep code__2)
930 sub_code sz x y = trivialCode (SUB sz) Nothing x y
933 getRegister (StInd pk mem)
934 = getAmode mem `thenNat` \ amode ->
936 code = amodeCode amode
937 src = amodeAddr amode
938 size = primRepToSize pk
939 code__2 dst = code `snocOL`
940 if pk == DoubleRep || pk == FloatRep
941 then GLD size src dst
949 (OpAddr src) (OpReg dst)
951 returnNat (Any pk code__2)
953 getRegister (StInt i)
955 src = ImmInt (fromInteger i)
958 = unitOL (XOR L (OpReg dst) (OpReg dst))
960 = unitOL (MOV L (OpImm src) (OpReg dst))
962 returnNat (Any IntRep code)
966 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
968 returnNat (Any PtrRep code)
970 = pprPanic "getRegister(x86)" (pprStixTree leaf)
973 imm__2 = case imm of Just x -> x
975 #endif {- i386_TARGET_ARCH -}
976 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
977 #if sparc_TARGET_ARCH
979 getRegister (StFloat d)
980 = getNatLabelNCG `thenNat` \ lbl ->
981 getNewRegNCG PtrRep `thenNat` \ tmp ->
982 let code dst = toOL [
987 SETHI (HI (ImmCLbl lbl)) tmp,
988 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
990 returnNat (Any FloatRep code)
992 getRegister (StDouble d)
993 = getNatLabelNCG `thenNat` \ lbl ->
994 getNewRegNCG PtrRep `thenNat` \ tmp ->
995 let code dst = toOL [
998 DATA DF [ImmDouble d],
1000 SETHI (HI (ImmCLbl lbl)) tmp,
1001 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1003 returnNat (Any DoubleRep code)
1005 -- The 6-word scratch area is immediately below the frame pointer.
1006 -- Below that is the spill area.
1007 getRegister (StScratchWord i)
1010 code dst = unitOL (fpRelEA (i-6) dst)
1012 returnNat (Any PtrRep code)
1015 getRegister (StPrim primop [x]) -- unary PrimOps
1017 IntNegOp -> trivialUCode (SUB False False g0) x
1018 NotOp -> trivialUCode (XNOR False g0) x
1020 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
1021 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
1023 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
1024 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
1026 OrdOp -> coerceIntCode IntRep x
1029 Float2IntOp -> coerceFP2Int x
1030 Int2FloatOp -> coerceInt2FP FloatRep x
1031 Double2IntOp -> coerceFP2Int x
1032 Int2DoubleOp -> coerceInt2FP DoubleRep x
1036 fixed_x = if is_float_op -- promote to double
1037 then StPrim Float2DoubleOp [x]
1040 getRegister (StCall fn CCallConv DoubleRep [fixed_x])
1044 FloatExpOp -> (True, SLIT("exp"))
1045 FloatLogOp -> (True, SLIT("log"))
1046 FloatSqrtOp -> (True, SLIT("sqrt"))
1048 FloatSinOp -> (True, SLIT("sin"))
1049 FloatCosOp -> (True, SLIT("cos"))
1050 FloatTanOp -> (True, SLIT("tan"))
1052 FloatAsinOp -> (True, SLIT("asin"))
1053 FloatAcosOp -> (True, SLIT("acos"))
1054 FloatAtanOp -> (True, SLIT("atan"))
1056 FloatSinhOp -> (True, SLIT("sinh"))
1057 FloatCoshOp -> (True, SLIT("cosh"))
1058 FloatTanhOp -> (True, SLIT("tanh"))
1060 DoubleExpOp -> (False, SLIT("exp"))
1061 DoubleLogOp -> (False, SLIT("log"))
1062 DoubleSqrtOp -> (False, SLIT("sqrt"))
1064 DoubleSinOp -> (False, SLIT("sin"))
1065 DoubleCosOp -> (False, SLIT("cos"))
1066 DoubleTanOp -> (False, SLIT("tan"))
1068 DoubleAsinOp -> (False, SLIT("asin"))
1069 DoubleAcosOp -> (False, SLIT("acos"))
1070 DoubleAtanOp -> (False, SLIT("atan"))
1072 DoubleSinhOp -> (False, SLIT("sinh"))
1073 DoubleCoshOp -> (False, SLIT("cosh"))
1074 DoubleTanhOp -> (False, SLIT("tanh"))
1077 -> pprPanic "getRegister(sparc,monadicprimop)"
1078 (pprStixTree (StPrim primop [x]))
1080 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
1082 CharGtOp -> condIntReg GTT x y
1083 CharGeOp -> condIntReg GE x y
1084 CharEqOp -> condIntReg EQQ x y
1085 CharNeOp -> condIntReg NE x y
1086 CharLtOp -> condIntReg LTT x y
1087 CharLeOp -> condIntReg LE x y
1089 IntGtOp -> condIntReg GTT x y
1090 IntGeOp -> condIntReg GE x y
1091 IntEqOp -> condIntReg EQQ x y
1092 IntNeOp -> condIntReg NE x y
1093 IntLtOp -> condIntReg LTT x y
1094 IntLeOp -> condIntReg LE x y
1096 WordGtOp -> condIntReg GU x y
1097 WordGeOp -> condIntReg GEU x y
1098 WordEqOp -> condIntReg EQQ x y
1099 WordNeOp -> condIntReg NE x y
1100 WordLtOp -> condIntReg LU x y
1101 WordLeOp -> condIntReg LEU x y
1103 AddrGtOp -> condIntReg GU x y
1104 AddrGeOp -> condIntReg GEU x y
1105 AddrEqOp -> condIntReg EQQ x y
1106 AddrNeOp -> condIntReg NE x y
1107 AddrLtOp -> condIntReg LU x y
1108 AddrLeOp -> condIntReg LEU x y
1110 FloatGtOp -> condFltReg GTT x y
1111 FloatGeOp -> condFltReg GE x y
1112 FloatEqOp -> condFltReg EQQ x y
1113 FloatNeOp -> condFltReg NE x y
1114 FloatLtOp -> condFltReg LTT x y
1115 FloatLeOp -> condFltReg LE x y
1117 DoubleGtOp -> condFltReg GTT x y
1118 DoubleGeOp -> condFltReg GE x y
1119 DoubleEqOp -> condFltReg EQQ x y
1120 DoubleNeOp -> condFltReg NE x y
1121 DoubleLtOp -> condFltReg LTT x y
1122 DoubleLeOp -> condFltReg LE x y
1124 IntAddOp -> trivialCode (ADD False False) x y
1125 IntSubOp -> trivialCode (SUB False False) x y
1127 -- ToDo: teach about V8+ SPARC mul/div instructions
1128 IntMulOp -> imul_div SLIT(".umul") x y
1129 IntQuotOp -> imul_div SLIT(".div") x y
1130 IntRemOp -> imul_div SLIT(".rem") x y
1132 WordAddOp -> trivialCode (ADD False False) x y
1133 WordSubOp -> trivialCode (SUB False False) x y
1134 WordMulOp -> imul_div SLIT(".umul") x y
1136 FloatAddOp -> trivialFCode FloatRep FADD x y
1137 FloatSubOp -> trivialFCode FloatRep FSUB x y
1138 FloatMulOp -> trivialFCode FloatRep FMUL x y
1139 FloatDivOp -> trivialFCode FloatRep FDIV x y
1141 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1142 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1143 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1144 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1146 AddrAddOp -> trivialCode (ADD False False) x y
1147 AddrSubOp -> trivialCode (SUB False False) x y
1148 AddrRemOp -> imul_div SLIT(".rem") x y
1150 AndOp -> trivialCode (AND False) x y
1151 OrOp -> trivialCode (OR False) x y
1152 XorOp -> trivialCode (XOR False) x y
1153 SllOp -> trivialCode SLL x y
1154 SrlOp -> trivialCode SRL x y
1156 ISllOp -> trivialCode SLL x y
1157 ISraOp -> trivialCode SRA x y
1158 ISrlOp -> trivialCode SRL x y
1160 FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
1161 [promote x, promote y])
1162 where promote x = StPrim Float2DoubleOp [x]
1163 DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
1167 -> pprPanic "getRegister(sparc,dyadic primop)"
1168 (pprStixTree (StPrim primop [x, y]))
1171 imul_div fn x y = getRegister (StCall fn CCallConv IntRep [x, y])
1173 getRegister (StInd pk mem)
1174 = getAmode mem `thenNat` \ amode ->
1176 code = amodeCode amode
1177 src = amodeAddr amode
1178 size = primRepToSize pk
1179 code__2 dst = code `snocOL` LD size src dst
1181 returnNat (Any pk code__2)
1183 getRegister (StInt i)
1186 src = ImmInt (fromInteger i)
1187 code dst = unitOL (OR False g0 (RIImm src) dst)
1189 returnNat (Any IntRep code)
1195 SETHI (HI imm__2) dst,
1196 OR False dst (RIImm (LO imm__2)) dst]
1198 returnNat (Any PtrRep code)
1200 = pprPanic "getRegister(sparc)" (pprStixTree leaf)
1203 imm__2 = case imm of Just x -> x
1205 #endif {- sparc_TARGET_ARCH -}
1208 %************************************************************************
1210 \subsection{The @Amode@ type}
1212 %************************************************************************
1214 @Amode@s: Memory addressing modes passed up the tree.
1216 data Amode = Amode MachRegsAddr InstrBlock
1218 amodeAddr (Amode addr _) = addr
1219 amodeCode (Amode _ code) = code
1222 Now, given a tree (the argument to an StInd) that references memory,
1223 produce a suitable addressing mode.
1225 A Rule of the Game (tm) for Amodes: use of the addr bit must
1226 immediately follow use of the code part, since the code part puts
1227 values in registers which the addr then refers to. So you can't put
1228 anything in between, lest it overwrite some of those registers. If
1229 you need to do some other computation between the code part and use of
1230 the addr bit, first store the effective address from the amode in a
1231 temporary, then do the other computation, and then use the temporary:
1235 ... other computation ...
1239 getAmode :: StixTree -> NatM Amode
1241 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1243 #if alpha_TARGET_ARCH
1245 getAmode (StPrim IntSubOp [x, StInt i])
1246 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1247 getRegister x `thenNat` \ register ->
1249 code = registerCode register tmp
1250 reg = registerName register tmp
1251 off = ImmInt (-(fromInteger i))
1253 returnNat (Amode (AddrRegImm reg off) code)
1255 getAmode (StPrim IntAddOp [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 (AddrRegImm reg off) code)
1267 = returnNat (Amode (AddrImm imm__2) id)
1270 imm__2 = case imm of Just x -> x
1273 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1274 getRegister other `thenNat` \ register ->
1276 code = registerCode register tmp
1277 reg = registerName register tmp
1279 returnNat (Amode (AddrReg reg) code)
1281 #endif {- alpha_TARGET_ARCH -}
1282 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1283 #if i386_TARGET_ARCH
1285 getAmode (StPrim IntSubOp [x, StInt i])
1286 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1287 getRegister x `thenNat` \ register ->
1289 code = registerCode register tmp
1290 reg = registerName register tmp
1291 off = ImmInt (-(fromInteger i))
1293 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1295 getAmode (StPrim IntAddOp [x, StInt i])
1297 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1300 imm__2 = case imm of Just x -> x
1302 getAmode (StPrim IntAddOp [x, StInt i])
1303 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1304 getRegister x `thenNat` \ register ->
1306 code = registerCode register tmp
1307 reg = registerName register tmp
1308 off = ImmInt (fromInteger i)
1310 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1312 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1313 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1314 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1315 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1316 getRegister x `thenNat` \ register1 ->
1317 getRegister y `thenNat` \ register2 ->
1319 code1 = registerCode register1 tmp1
1320 reg1 = registerName register1 tmp1
1321 code2 = registerCode register2 tmp2
1322 reg2 = registerName register2 tmp2
1323 code__2 = code1 `appOL` code2
1324 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1326 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1331 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1334 imm__2 = case imm of Just x -> x
1337 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1338 getRegister other `thenNat` \ register ->
1340 code = registerCode register tmp
1341 reg = registerName register tmp
1343 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1345 #endif {- i386_TARGET_ARCH -}
1346 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1347 #if sparc_TARGET_ARCH
1349 getAmode (StPrim IntSubOp [x, StInt i])
1351 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1352 getRegister x `thenNat` \ register ->
1354 code = registerCode register tmp
1355 reg = registerName register tmp
1356 off = ImmInt (-(fromInteger i))
1358 returnNat (Amode (AddrRegImm reg off) code)
1361 getAmode (StPrim IntAddOp [x, StInt i])
1363 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1364 getRegister x `thenNat` \ register ->
1366 code = registerCode register tmp
1367 reg = registerName register tmp
1368 off = ImmInt (fromInteger i)
1370 returnNat (Amode (AddrRegImm reg off) code)
1372 getAmode (StPrim IntAddOp [x, y])
1373 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1374 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1375 getRegister x `thenNat` \ register1 ->
1376 getRegister y `thenNat` \ register2 ->
1378 code1 = registerCode register1 tmp1
1379 reg1 = registerName register1 tmp1
1380 code2 = registerCode register2 tmp2
1381 reg2 = registerName register2 tmp2
1382 code__2 = code1 `appOL` code2
1384 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1388 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1390 code = unitOL (SETHI (HI imm__2) tmp)
1392 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1395 imm__2 = case imm of Just x -> x
1398 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1399 getRegister other `thenNat` \ register ->
1401 code = registerCode register tmp
1402 reg = registerName register tmp
1405 returnNat (Amode (AddrRegImm reg off) code)
1407 #endif {- sparc_TARGET_ARCH -}
1410 %************************************************************************
1412 \subsection{The @CondCode@ type}
1414 %************************************************************************
1416 Condition codes passed up the tree.
1418 data CondCode = CondCode Bool Cond InstrBlock
1420 condName (CondCode _ cond _) = cond
1421 condFloat (CondCode is_float _ _) = is_float
1422 condCode (CondCode _ _ code) = code
1425 Set up a condition code for a conditional branch.
1428 getCondCode :: StixTree -> NatM CondCode
1430 #if alpha_TARGET_ARCH
1431 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1432 #endif {- alpha_TARGET_ARCH -}
1433 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1435 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1436 -- yes, they really do seem to want exactly the same!
1438 getCondCode (StPrim primop [x, y])
1440 CharGtOp -> condIntCode GTT x y
1441 CharGeOp -> condIntCode GE x y
1442 CharEqOp -> condIntCode EQQ x y
1443 CharNeOp -> condIntCode NE x y
1444 CharLtOp -> condIntCode LTT x y
1445 CharLeOp -> condIntCode LE x y
1447 IntGtOp -> condIntCode GTT x y
1448 IntGeOp -> condIntCode GE x y
1449 IntEqOp -> condIntCode EQQ x y
1450 IntNeOp -> condIntCode NE x y
1451 IntLtOp -> condIntCode LTT x y
1452 IntLeOp -> condIntCode LE x y
1454 WordGtOp -> condIntCode GU x y
1455 WordGeOp -> condIntCode GEU x y
1456 WordEqOp -> condIntCode EQQ x y
1457 WordNeOp -> condIntCode NE x y
1458 WordLtOp -> condIntCode LU x y
1459 WordLeOp -> condIntCode LEU x y
1461 AddrGtOp -> condIntCode GU x y
1462 AddrGeOp -> condIntCode GEU x y
1463 AddrEqOp -> condIntCode EQQ x y
1464 AddrNeOp -> condIntCode NE x y
1465 AddrLtOp -> condIntCode LU x y
1466 AddrLeOp -> condIntCode LEU x y
1468 FloatGtOp -> condFltCode GTT x y
1469 FloatGeOp -> condFltCode GE x y
1470 FloatEqOp -> condFltCode EQQ x y
1471 FloatNeOp -> condFltCode NE x y
1472 FloatLtOp -> condFltCode LTT x y
1473 FloatLeOp -> condFltCode LE x y
1475 DoubleGtOp -> condFltCode GTT x y
1476 DoubleGeOp -> condFltCode GE x y
1477 DoubleEqOp -> condFltCode EQQ x y
1478 DoubleNeOp -> condFltCode NE x y
1479 DoubleLtOp -> condFltCode LTT x y
1480 DoubleLeOp -> condFltCode LE x y
1482 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1487 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1488 passed back up the tree.
1491 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1493 #if alpha_TARGET_ARCH
1494 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1495 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1496 #endif {- alpha_TARGET_ARCH -}
1498 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1499 #if i386_TARGET_ARCH
1501 -- memory vs immediate
1502 condIntCode cond (StInd pk x) y
1504 = getAmode x `thenNat` \ amode ->
1506 code1 = amodeCode amode
1507 x__2 = amodeAddr amode
1508 sz = primRepToSize pk
1509 code__2 = code1 `snocOL`
1510 CMP sz (OpImm imm__2) (OpAddr x__2)
1512 returnNat (CondCode False cond code__2)
1515 imm__2 = case imm of Just x -> x
1518 condIntCode cond x (StInt 0)
1519 = getRegister x `thenNat` \ register1 ->
1520 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1522 code1 = registerCode register1 tmp1
1523 src1 = registerName register1 tmp1
1524 code__2 = code1 `snocOL`
1525 TEST L (OpReg src1) (OpReg src1)
1527 returnNat (CondCode False cond code__2)
1529 -- anything vs immediate
1530 condIntCode cond x y
1532 = getRegister x `thenNat` \ register1 ->
1533 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1535 code1 = registerCode register1 tmp1
1536 src1 = registerName register1 tmp1
1537 code__2 = code1 `snocOL`
1538 CMP L (OpImm imm__2) (OpReg src1)
1540 returnNat (CondCode False cond code__2)
1543 imm__2 = case imm of Just x -> x
1545 -- memory vs anything
1546 condIntCode cond (StInd pk x) y
1547 = getAmode x `thenNat` \ amode_x ->
1548 getRegister y `thenNat` \ reg_y ->
1549 getNewRegNCG IntRep `thenNat` \ tmp ->
1551 c_x = amodeCode amode_x
1552 am_x = amodeAddr amode_x
1553 c_y = registerCode reg_y tmp
1554 r_y = registerName reg_y tmp
1555 sz = primRepToSize pk
1557 -- optimisation: if there's no code for x, just an amode,
1558 -- use whatever reg y winds up in. Assumes that c_y doesn't
1559 -- clobber any regs in the amode am_x, which I'm not sure is
1560 -- justified. The otherwise clause makes the same assumption.
1561 code__2 | isNilOL c_x
1563 CMP sz (OpReg r_y) (OpAddr am_x)
1567 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1569 CMP sz (OpReg tmp) (OpAddr am_x)
1571 returnNat (CondCode False cond code__2)
1573 -- anything vs memory
1575 condIntCode cond y (StInd pk x)
1576 = getAmode x `thenNat` \ amode_x ->
1577 getRegister y `thenNat` \ reg_y ->
1578 getNewRegNCG IntRep `thenNat` \ tmp ->
1580 c_x = amodeCode amode_x
1581 am_x = amodeAddr amode_x
1582 c_y = registerCode reg_y tmp
1583 r_y = registerName reg_y tmp
1584 sz = primRepToSize pk
1585 -- same optimisation and nagging doubts as previous clause
1586 code__2 | isNilOL c_x
1588 CMP sz (OpAddr am_x) (OpReg r_y)
1592 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1594 CMP sz (OpAddr am_x) (OpReg tmp)
1596 returnNat (CondCode False cond code__2)
1598 -- anything vs anything
1599 condIntCode cond x y
1600 = getRegister x `thenNat` \ register1 ->
1601 getRegister y `thenNat` \ register2 ->
1602 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1603 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1605 code1 = registerCode register1 tmp1
1606 src1 = registerName register1 tmp1
1607 code2 = registerCode register2 tmp2
1608 src2 = registerName register2 tmp2
1609 code__2 = code1 `snocOL`
1610 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1612 CMP L (OpReg src2) (OpReg tmp1)
1614 returnNat (CondCode False cond code__2)
1617 condFltCode cond x y
1618 = getRegister x `thenNat` \ register1 ->
1619 getRegister y `thenNat` \ register2 ->
1620 getNewRegNCG (registerRep register1)
1622 getNewRegNCG (registerRep register2)
1624 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1626 pk1 = registerRep register1
1627 code1 = registerCode register1 tmp1
1628 src1 = registerName register1 tmp1
1630 code2 = registerCode register2 tmp2
1631 src2 = registerName register2 tmp2
1633 code__2 | isAny register1
1634 = code1 `appOL` -- result in tmp1
1636 GCMP (primRepToSize pk1) tmp1 src2
1640 GMOV src1 tmp1 `appOL`
1642 GCMP (primRepToSize pk1) tmp1 src2
1644 {- On the 486, the flags set by FP compare are the unsigned ones!
1645 (This looks like a HACK to me. WDP 96/03)
1647 fix_FP_cond :: Cond -> Cond
1649 fix_FP_cond GE = GEU
1650 fix_FP_cond GTT = GU
1651 fix_FP_cond LTT = LU
1652 fix_FP_cond LE = LEU
1653 fix_FP_cond any = any
1655 returnNat (CondCode True (fix_FP_cond cond) code__2)
1659 #endif {- i386_TARGET_ARCH -}
1660 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1661 #if sparc_TARGET_ARCH
1663 condIntCode cond x (StInt y)
1665 = getRegister x `thenNat` \ register ->
1666 getNewRegNCG IntRep `thenNat` \ tmp ->
1668 code = registerCode register tmp
1669 src1 = registerName register tmp
1670 src2 = ImmInt (fromInteger y)
1671 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1673 returnNat (CondCode False cond code__2)
1675 condIntCode cond x y
1676 = getRegister x `thenNat` \ register1 ->
1677 getRegister y `thenNat` \ register2 ->
1678 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1679 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1681 code1 = registerCode register1 tmp1
1682 src1 = registerName register1 tmp1
1683 code2 = registerCode register2 tmp2
1684 src2 = registerName register2 tmp2
1685 code__2 = code1 `appOL` code2 `snocOL`
1686 SUB False True src1 (RIReg src2) g0
1688 returnNat (CondCode False cond code__2)
1691 condFltCode cond x y
1692 = getRegister x `thenNat` \ register1 ->
1693 getRegister y `thenNat` \ register2 ->
1694 getNewRegNCG (registerRep register1)
1696 getNewRegNCG (registerRep register2)
1698 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1700 promote x = FxTOy F DF x tmp
1702 pk1 = registerRep register1
1703 code1 = registerCode register1 tmp1
1704 src1 = registerName register1 tmp1
1706 pk2 = registerRep register2
1707 code2 = registerCode register2 tmp2
1708 src2 = registerName register2 tmp2
1712 code1 `appOL` code2 `snocOL`
1713 FCMP True (primRepToSize pk1) src1 src2
1714 else if pk1 == FloatRep then
1715 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1716 FCMP True DF tmp src2
1718 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1719 FCMP True DF src1 tmp
1721 returnNat (CondCode True cond code__2)
1723 #endif {- sparc_TARGET_ARCH -}
1726 %************************************************************************
1728 \subsection{Generating assignments}
1730 %************************************************************************
1732 Assignments are really at the heart of the whole code generation
1733 business. Almost all top-level nodes of any real importance are
1734 assignments, which correspond to loads, stores, or register transfers.
1735 If we're really lucky, some of the register transfers will go away,
1736 because we can use the destination register to complete the code
1737 generation for the right hand side. This only fails when the right
1738 hand side is forced into a fixed register (e.g. the result of a call).
1741 assignIntCode, assignFltCode
1742 :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1744 #if alpha_TARGET_ARCH
1746 assignIntCode pk (StInd _ dst) src
1747 = getNewRegNCG IntRep `thenNat` \ tmp ->
1748 getAmode dst `thenNat` \ amode ->
1749 getRegister src `thenNat` \ register ->
1751 code1 = amodeCode amode []
1752 dst__2 = amodeAddr amode
1753 code2 = registerCode register tmp []
1754 src__2 = registerName register tmp
1755 sz = primRepToSize pk
1756 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1760 assignIntCode pk dst src
1761 = getRegister dst `thenNat` \ register1 ->
1762 getRegister src `thenNat` \ register2 ->
1764 dst__2 = registerName register1 zeroh
1765 code = registerCode register2 dst__2
1766 src__2 = registerName register2 dst__2
1767 code__2 = if isFixed register2
1768 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1773 #endif {- alpha_TARGET_ARCH -}
1774 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1775 #if i386_TARGET_ARCH
1777 -- Destination of an assignment can only be reg or mem.
1778 -- This is the mem case.
1779 assignIntCode pk (StInd _ dst) src
1780 = getAmode dst `thenNat` \ amode ->
1781 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
1782 getNewRegNCG PtrRep `thenNat` \ tmp ->
1784 -- In general, if the address computation for dst may require
1785 -- some insns preceding the addressing mode itself. So there's
1786 -- no guarantee that the code for dst and the code for src won't
1787 -- write the same register. This means either the address or
1788 -- the value needs to be copied into a temporary. We detect the
1789 -- common case where the amode has no code, and elide the copy.
1790 codea = amodeCode amode
1791 dst__a = amodeAddr amode
1793 code | isNilOL codea
1795 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1799 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1801 MOV (primRepToSize pk) opsrc
1802 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1808 -> NatM (InstrBlock,Operand) -- code, operator
1812 = returnNat (nilOL, OpImm imm_op)
1815 imm_op = case imm of Just x -> x
1818 = getRegister op `thenNat` \ register ->
1819 getNewRegNCG (registerRep register)
1821 let code = registerCode register tmp
1822 reg = registerName register tmp
1824 returnNat (code, OpReg reg)
1826 -- Assign; dst is a reg, rhs is mem
1827 assignIntCode pk dst (StInd pks src)
1828 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1829 getAmode src `thenNat` \ amode ->
1830 getRegister dst `thenNat` \ reg_dst ->
1832 c_addr = amodeCode amode
1833 am_addr = amodeAddr amode
1835 c_dst = registerCode reg_dst tmp -- should be empty
1836 r_dst = registerName reg_dst tmp
1837 szs = primRepToSize pks
1846 code | isNilOL c_dst
1848 opc (OpAddr am_addr) (OpReg r_dst)
1850 = pprPanic "assignIntCode(x86): bad dst(2)" empty
1854 -- dst is a reg, but src could be anything
1855 assignIntCode pk dst src
1856 = getRegister dst `thenNat` \ registerd ->
1857 getRegister src `thenNat` \ registers ->
1858 getNewRegNCG IntRep `thenNat` \ tmp ->
1860 r_dst = registerName registerd tmp
1861 c_dst = registerCode registerd tmp -- should be empty
1862 r_src = registerName registers r_dst
1863 c_src = registerCode registers r_dst
1865 code | isNilOL c_dst
1867 MOV L (OpReg r_src) (OpReg r_dst)
1869 = pprPanic "assignIntCode(x86): bad dst(3)" empty
1873 #endif {- i386_TARGET_ARCH -}
1874 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1875 #if sparc_TARGET_ARCH
1877 assignIntCode pk (StInd _ dst) src
1878 = getNewRegNCG IntRep `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 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
1891 assignIntCode pk dst src
1892 = getRegister dst `thenNat` \ register1 ->
1893 getRegister src `thenNat` \ register2 ->
1895 dst__2 = registerName register1 g0
1896 code = registerCode register2 dst__2
1897 src__2 = registerName register2 dst__2
1898 code__2 = if isFixed register2
1899 then code `snocOL` OR False g0 (RIReg src__2) dst__2
1904 #endif {- sparc_TARGET_ARCH -}
1907 % --------------------------------
1908 Floating-point assignments:
1909 % --------------------------------
1911 #if alpha_TARGET_ARCH
1913 assignFltCode pk (StInd _ dst) src
1914 = getNewRegNCG pk `thenNat` \ tmp ->
1915 getAmode dst `thenNat` \ amode ->
1916 getRegister src `thenNat` \ register ->
1918 code1 = amodeCode amode []
1919 dst__2 = amodeAddr amode
1920 code2 = registerCode register tmp []
1921 src__2 = registerName register tmp
1922 sz = primRepToSize pk
1923 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1927 assignFltCode pk dst src
1928 = getRegister dst `thenNat` \ register1 ->
1929 getRegister src `thenNat` \ register2 ->
1931 dst__2 = registerName register1 zeroh
1932 code = registerCode register2 dst__2
1933 src__2 = registerName register2 dst__2
1934 code__2 = if isFixed register2
1935 then code . mkSeqInstr (FMOV src__2 dst__2)
1940 #endif {- alpha_TARGET_ARCH -}
1941 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1942 #if i386_TARGET_ARCH
1945 assignFltCode pk (StInd pk_dst addr) src
1947 = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
1949 = getRegister src `thenNat` \ reg_src ->
1950 getRegister addr `thenNat` \ reg_addr ->
1951 getNewRegNCG pk `thenNat` \ tmp_src ->
1952 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
1953 let r_src = registerName reg_src tmp_src
1954 c_src = registerCode reg_src tmp_src
1955 r_addr = registerName reg_addr tmp_addr
1956 c_addr = registerCode reg_addr tmp_addr
1957 sz = primRepToSize pk
1959 code = c_src `appOL`
1960 -- no need to preserve r_src across the addr computation,
1961 -- since r_src must be a float reg
1962 -- whilst r_addr is an int reg
1965 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1969 -- dst must be a (FP) register
1970 assignFltCode pk dst src
1971 = getRegister dst `thenNat` \ reg_dst ->
1972 getRegister src `thenNat` \ reg_src ->
1973 getNewRegNCG pk `thenNat` \ tmp ->
1975 r_dst = registerName reg_dst tmp
1976 c_dst = registerCode reg_dst tmp -- should be empty
1978 r_src = registerName reg_src r_dst
1979 c_src = registerCode reg_src r_dst
1981 code | isNilOL c_dst
1982 = if isFixed reg_src
1983 then c_src `snocOL` GMOV r_src r_dst
1986 = pprPanic "assignFltCode(x86): lhs is not mem or reg"
1992 #endif {- i386_TARGET_ARCH -}
1993 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1994 #if sparc_TARGET_ARCH
1996 assignFltCode pk (StInd _ dst) src
1997 = getNewRegNCG pk `thenNat` \ tmp1 ->
1998 getAmode dst `thenNat` \ amode ->
1999 getRegister src `thenNat` \ register ->
2001 sz = primRepToSize pk
2002 dst__2 = amodeAddr amode
2004 code1 = amodeCode amode
2005 code2 = registerCode register tmp1
2007 src__2 = registerName register tmp1
2008 pk__2 = registerRep register
2009 sz__2 = primRepToSize pk__2
2011 code__2 = code1 `appOL` code2 `appOL`
2013 then unitOL (ST sz src__2 dst__2)
2014 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2018 assignFltCode pk dst src
2019 = getRegister dst `thenNat` \ register1 ->
2020 getRegister src `thenNat` \ register2 ->
2022 pk__2 = registerRep register2
2023 sz__2 = primRepToSize pk__2
2025 getNewRegNCG pk__2 `thenNat` \ tmp ->
2027 sz = primRepToSize pk
2028 dst__2 = registerName register1 g0 -- must be Fixed
2031 reg__2 = if pk /= pk__2 then tmp else dst__2
2033 code = registerCode register2 reg__2
2035 src__2 = registerName register2 reg__2
2039 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2040 else if isFixed register2 then
2041 code `snocOL` FMOV sz src__2 dst__2
2047 #endif {- sparc_TARGET_ARCH -}
2050 %************************************************************************
2052 \subsection{Generating an unconditional branch}
2054 %************************************************************************
2056 We accept two types of targets: an immediate CLabel or a tree that
2057 gets evaluated into a register. Any CLabels which are AsmTemporaries
2058 are assumed to be in the local block of code, close enough for a
2059 branch instruction. Other CLabels are assumed to be far away.
2061 (If applicable) Do not fill the delay slots here; you will confuse the
2065 genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
2067 #if alpha_TARGET_ARCH
2069 genJump (StCLbl lbl)
2070 | isAsmTemp lbl = returnInstr (BR target)
2071 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2073 target = ImmCLbl lbl
2076 = getRegister tree `thenNat` \ register ->
2077 getNewRegNCG PtrRep `thenNat` \ tmp ->
2079 dst = registerName register pv
2080 code = registerCode register pv
2081 target = registerName register pv
2083 if isFixed register then
2084 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2086 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2088 #endif {- alpha_TARGET_ARCH -}
2089 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2090 #if i386_TARGET_ARCH
2092 genJump dsts (StInd pk mem)
2093 = getAmode mem `thenNat` \ amode ->
2095 code = amodeCode amode
2096 target = amodeAddr amode
2098 returnNat (code `snocOL` JMP dsts (OpAddr target))
2102 = returnNat (unitOL (JMP dsts (OpImm target)))
2105 = getRegister tree `thenNat` \ register ->
2106 getNewRegNCG PtrRep `thenNat` \ tmp ->
2108 code = registerCode register tmp
2109 target = registerName register tmp
2111 returnNat (code `snocOL` JMP dsts (OpReg target))
2114 target = case imm of Just x -> x
2116 #endif {- i386_TARGET_ARCH -}
2117 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2118 #if sparc_TARGET_ARCH
2120 genJump dsts (StCLbl lbl)
2121 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2122 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2123 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2125 target = ImmCLbl lbl
2128 = getRegister tree `thenNat` \ register ->
2129 getNewRegNCG PtrRep `thenNat` \ tmp ->
2131 code = registerCode register tmp
2132 target = registerName register tmp
2134 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2136 #endif {- sparc_TARGET_ARCH -}
2139 %************************************************************************
2141 \subsection{Conditional jumps}
2143 %************************************************************************
2145 Conditional jumps are always to local labels, so we can use branch
2146 instructions. We peek at the arguments to decide what kind of
2149 ALPHA: For comparisons with 0, we're laughing, because we can just do
2150 the desired conditional branch.
2152 I386: First, we have to ensure that the condition
2153 codes are set according to the supplied comparison operation.
2155 SPARC: First, we have to ensure that the condition codes are set
2156 according to the supplied comparison operation. We generate slightly
2157 different code for floating point comparisons, because a floating
2158 point operation cannot directly precede a @BF@. We assume the worst
2159 and fill that slot with a @NOP@.
2161 SPARC: Do not fill the delay slots here; you will confuse the register
2166 :: CLabel -- the branch target
2167 -> StixTree -- the condition on which to branch
2170 #if alpha_TARGET_ARCH
2172 genCondJump lbl (StPrim op [x, StInt 0])
2173 = getRegister x `thenNat` \ register ->
2174 getNewRegNCG (registerRep register)
2177 code = registerCode register tmp
2178 value = registerName register tmp
2179 pk = registerRep register
2180 target = ImmCLbl lbl
2182 returnSeq code [BI (cmpOp op) value target]
2184 cmpOp CharGtOp = GTT
2186 cmpOp CharEqOp = EQQ
2188 cmpOp CharLtOp = LTT
2197 cmpOp WordGeOp = ALWAYS
2198 cmpOp WordEqOp = EQQ
2200 cmpOp WordLtOp = NEVER
2201 cmpOp WordLeOp = EQQ
2203 cmpOp AddrGeOp = ALWAYS
2204 cmpOp AddrEqOp = EQQ
2206 cmpOp AddrLtOp = NEVER
2207 cmpOp AddrLeOp = EQQ
2209 genCondJump lbl (StPrim op [x, StDouble 0.0])
2210 = getRegister x `thenNat` \ register ->
2211 getNewRegNCG (registerRep register)
2214 code = registerCode register tmp
2215 value = registerName register tmp
2216 pk = registerRep register
2217 target = ImmCLbl lbl
2219 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2221 cmpOp FloatGtOp = GTT
2222 cmpOp FloatGeOp = GE
2223 cmpOp FloatEqOp = EQQ
2224 cmpOp FloatNeOp = NE
2225 cmpOp FloatLtOp = LTT
2226 cmpOp FloatLeOp = LE
2227 cmpOp DoubleGtOp = GTT
2228 cmpOp DoubleGeOp = GE
2229 cmpOp DoubleEqOp = EQQ
2230 cmpOp DoubleNeOp = NE
2231 cmpOp DoubleLtOp = LTT
2232 cmpOp DoubleLeOp = LE
2234 genCondJump lbl (StPrim op [x, y])
2236 = trivialFCode pr instr x y `thenNat` \ register ->
2237 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2239 code = registerCode register tmp
2240 result = registerName register tmp
2241 target = ImmCLbl lbl
2243 returnNat (code . mkSeqInstr (BF cond result target))
2245 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2247 fltCmpOp op = case op of
2261 (instr, cond) = case op of
2262 FloatGtOp -> (FCMP TF LE, EQQ)
2263 FloatGeOp -> (FCMP TF LTT, EQQ)
2264 FloatEqOp -> (FCMP TF EQQ, NE)
2265 FloatNeOp -> (FCMP TF EQQ, EQQ)
2266 FloatLtOp -> (FCMP TF LTT, NE)
2267 FloatLeOp -> (FCMP TF LE, NE)
2268 DoubleGtOp -> (FCMP TF LE, EQQ)
2269 DoubleGeOp -> (FCMP TF LTT, EQQ)
2270 DoubleEqOp -> (FCMP TF EQQ, NE)
2271 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2272 DoubleLtOp -> (FCMP TF LTT, NE)
2273 DoubleLeOp -> (FCMP TF LE, NE)
2275 genCondJump lbl (StPrim op [x, y])
2276 = trivialCode instr x y `thenNat` \ register ->
2277 getNewRegNCG IntRep `thenNat` \ tmp ->
2279 code = registerCode register tmp
2280 result = registerName register tmp
2281 target = ImmCLbl lbl
2283 returnNat (code . mkSeqInstr (BI cond result target))
2285 (instr, cond) = case op of
2286 CharGtOp -> (CMP LE, EQQ)
2287 CharGeOp -> (CMP LTT, EQQ)
2288 CharEqOp -> (CMP EQQ, NE)
2289 CharNeOp -> (CMP EQQ, EQQ)
2290 CharLtOp -> (CMP LTT, NE)
2291 CharLeOp -> (CMP LE, NE)
2292 IntGtOp -> (CMP LE, EQQ)
2293 IntGeOp -> (CMP LTT, EQQ)
2294 IntEqOp -> (CMP EQQ, NE)
2295 IntNeOp -> (CMP EQQ, EQQ)
2296 IntLtOp -> (CMP LTT, NE)
2297 IntLeOp -> (CMP LE, NE)
2298 WordGtOp -> (CMP ULE, EQQ)
2299 WordGeOp -> (CMP ULT, EQQ)
2300 WordEqOp -> (CMP EQQ, NE)
2301 WordNeOp -> (CMP EQQ, EQQ)
2302 WordLtOp -> (CMP ULT, NE)
2303 WordLeOp -> (CMP ULE, NE)
2304 AddrGtOp -> (CMP ULE, EQQ)
2305 AddrGeOp -> (CMP ULT, EQQ)
2306 AddrEqOp -> (CMP EQQ, NE)
2307 AddrNeOp -> (CMP EQQ, EQQ)
2308 AddrLtOp -> (CMP ULT, NE)
2309 AddrLeOp -> (CMP ULE, NE)
2311 #endif {- alpha_TARGET_ARCH -}
2312 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2313 #if i386_TARGET_ARCH
2315 genCondJump lbl bool
2316 = getCondCode bool `thenNat` \ condition ->
2318 code = condCode condition
2319 cond = condName condition
2321 returnNat (code `snocOL` JXX cond lbl)
2323 #endif {- i386_TARGET_ARCH -}
2324 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2325 #if sparc_TARGET_ARCH
2327 genCondJump lbl bool
2328 = getCondCode bool `thenNat` \ condition ->
2330 code = condCode condition
2331 cond = condName condition
2332 target = ImmCLbl lbl
2337 if condFloat condition
2338 then [NOP, BF cond False target, NOP]
2339 else [BI cond False target, NOP]
2343 #endif {- sparc_TARGET_ARCH -}
2346 %************************************************************************
2348 \subsection{Generating C calls}
2350 %************************************************************************
2352 Now the biggest nightmare---calls. Most of the nastiness is buried in
2353 @get_arg@, which moves the arguments to the correct registers/stack
2354 locations. Apart from that, the code is easy.
2356 (If applicable) Do not fill the delay slots here; you will confuse the
2361 :: FAST_STRING -- function to call
2363 -> PrimRep -- type of the result
2364 -> [StixTree] -- arguments (of mixed type)
2367 #if alpha_TARGET_ARCH
2369 genCCall fn cconv kind args
2370 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2371 `thenNat` \ ((unused,_), argCode) ->
2373 nRegs = length allArgRegs - length unused
2374 code = asmSeqThen (map ($ []) argCode)
2377 LDA pv (AddrImm (ImmLab (ptext fn))),
2378 JSR ra (AddrReg pv) nRegs,
2379 LDGP gp (AddrReg ra)]
2381 ------------------------
2382 {- Try to get a value into a specific register (or registers) for
2383 a call. The first 6 arguments go into the appropriate
2384 argument register (separate registers for integer and floating
2385 point arguments, but used in lock-step), and the remaining
2386 arguments are dumped to the stack, beginning at 0(sp). Our
2387 first argument is a pair of the list of remaining argument
2388 registers to be assigned for this call and the next stack
2389 offset to use for overflowing arguments. This way,
2390 @get_Arg@ can be applied to all of a call's arguments using
2394 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2395 -> StixTree -- Current argument
2396 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2398 -- We have to use up all of our argument registers first...
2400 get_arg ((iDst,fDst):dsts, offset) arg
2401 = getRegister arg `thenNat` \ register ->
2403 reg = if isFloatingRep pk then fDst else iDst
2404 code = registerCode register reg
2405 src = registerName register reg
2406 pk = registerRep register
2409 if isFloatingRep pk then
2410 ((dsts, offset), if isFixed register then
2411 code . mkSeqInstr (FMOV src fDst)
2414 ((dsts, offset), if isFixed register then
2415 code . mkSeqInstr (OR src (RIReg src) iDst)
2418 -- Once we have run out of argument registers, we move to the
2421 get_arg ([], offset) arg
2422 = getRegister arg `thenNat` \ register ->
2423 getNewRegNCG (registerRep register)
2426 code = registerCode register tmp
2427 src = registerName register tmp
2428 pk = registerRep register
2429 sz = primRepToSize pk
2431 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2433 #endif {- alpha_TARGET_ARCH -}
2434 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2435 #if i386_TARGET_ARCH
2437 genCCall fn cconv kind [StInt i]
2438 | fn == SLIT ("PerformGC_wrapper")
2440 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2441 CALL (ImmLit (ptext (if underscorePrefix
2442 then (SLIT ("_PerformGC_wrapper"))
2443 else (SLIT ("PerformGC_wrapper")))))
2449 genCCall fn cconv kind args
2450 = mapNat get_call_arg
2451 (reverse args) `thenNat` \ sizes_n_codes ->
2452 getDeltaNat `thenNat` \ delta ->
2453 let (sizes, codes) = unzip sizes_n_codes
2454 tot_arg_size = sum sizes
2455 code2 = concatOL codes
2457 [CALL (fn__2 tot_arg_size)]
2459 -- Deallocate parameters after call for ccall;
2460 -- but not for stdcall (callee does it)
2461 (if cconv == StdCallConv then [] else
2462 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2465 [DELTA (delta + tot_arg_size)]
2468 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2469 returnNat (code2 `appOL` call)
2472 -- function names that begin with '.' are assumed to be special
2473 -- internally generated names like '.mul,' which don't get an
2474 -- underscore prefix
2475 -- ToDo:needed (WDP 96/03) ???
2479 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2480 | otherwise -- General case
2481 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2483 stdcallsize tot_arg_size
2484 | cconv == StdCallConv = '@':show tot_arg_size
2492 get_call_arg :: StixTree{-current argument-}
2493 -> NatM (Int, InstrBlock) -- argsz, code
2496 = get_op arg `thenNat` \ (code, reg, sz) ->
2497 getDeltaNat `thenNat` \ delta ->
2498 arg_size sz `bind` \ size ->
2499 setDeltaNat (delta-size) `thenNat` \ _ ->
2500 if (case sz of DF -> True; F -> True; _ -> False)
2501 then returnNat (size,
2503 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2505 GST sz reg (AddrBaseIndex (Just esp)
2509 else returnNat (size,
2511 PUSH L (OpReg reg) `snocOL`
2517 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2520 = getRegister op `thenNat` \ register ->
2521 getNewRegNCG (registerRep register)
2524 code = registerCode register tmp
2525 reg = registerName register tmp
2526 pk = registerRep register
2527 sz = primRepToSize pk
2529 returnNat (code, reg, sz)
2531 #endif {- i386_TARGET_ARCH -}
2532 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2533 #if sparc_TARGET_ARCH
2535 The SPARC calling convention is an absolute
2536 nightmare. The first 6x32 bits of arguments are mapped into
2537 %o0 through %o5, and the remaining arguments are dumped to the
2538 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2540 If we have to put args on the stack, move %o6==%sp down by
2541 the number of words to go on the stack, to ensure there's enough space.
2543 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2544 16 words above the stack pointer is a word for the address of
2545 a structure return value. I use this as a temporary location
2546 for moving values from float to int regs. Certainly it isn't
2547 safe to put anything in the 16 words starting at %sp, since
2548 this area can get trashed at any time due to window overflows
2549 caused by signal handlers.
2551 A final complication (if the above isn't enough) is that
2552 we can't blithely calculate the arguments one by one into
2553 %o0 .. %o5. Consider the following nested calls:
2557 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2558 the inner call will itself use %o0, which trashes the value put there
2559 in preparation for the outer call. Upshot: we need to calculate the
2560 args into temporary regs, and move those to arg regs or onto the
2561 stack only immediately prior to the call proper. Sigh.
2564 genCCall fn cconv kind args
2565 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2566 let (argcodes, vregss) = unzip argcode_and_vregs
2567 argcode = concatOL argcodes
2568 vregs = concat vregss
2569 n_argRegs = length allArgRegs
2570 n_argRegs_used = min (length vregs) n_argRegs
2571 (move_sp_down, move_sp_up)
2572 = let nn = length vregs - n_argRegs
2573 + 1 -- (for the road)
2576 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2578 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2580 = unitOL (CALL fn__2 n_argRegs_used False)
2582 returnNat (argcode `appOL`
2583 move_sp_down `appOL`
2584 transfer_code `appOL`
2589 -- function names that begin with '.' are assumed to be special
2590 -- internally generated names like '.mul,' which don't get an
2591 -- underscore prefix
2592 -- ToDo:needed (WDP 96/03) ???
2593 fn__2 = case (_HEAD_ fn) of
2594 '.' -> ImmLit (ptext fn)
2595 _ -> ImmLab False (ptext fn)
2597 -- move args from the integer vregs into which they have been
2598 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2599 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2601 move_final [] _ offset -- all args done
2604 move_final (v:vs) [] offset -- out of aregs; move to stack
2605 = ST W v (spRel offset)
2606 : move_final vs [] (offset+1)
2608 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2609 = OR False g0 (RIReg v) a
2610 : move_final vs az offset
2612 -- generate code to calculate an argument, and move it into one
2613 -- or two integer vregs.
2614 arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
2615 arg_to_int_vregs arg
2616 = getRegister arg `thenNat` \ register ->
2617 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2618 let code = registerCode register tmp
2619 src = registerName register tmp
2620 pk = registerRep register
2622 -- the value is in src. Get it into 1 or 2 int vregs.
2625 getNewRegNCG WordRep `thenNat` \ v1 ->
2626 getNewRegNCG WordRep `thenNat` \ v2 ->
2629 FMOV DF src f0 `snocOL`
2630 ST F f0 (spRel 16) `snocOL`
2631 LD W (spRel 16) v1 `snocOL`
2632 ST F (fPair f0) (spRel 16) `snocOL`
2638 getNewRegNCG WordRep `thenNat` \ v1 ->
2641 ST F src (spRel 16) `snocOL`
2647 getNewRegNCG WordRep `thenNat` \ v1 ->
2649 code `snocOL` OR False g0 (RIReg src) v1
2653 #endif {- sparc_TARGET_ARCH -}
2656 %************************************************************************
2658 \subsection{Support bits}
2660 %************************************************************************
2662 %************************************************************************
2664 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2666 %************************************************************************
2668 Turn those condition codes into integers now (when they appear on
2669 the right hand side of an assignment).
2671 (If applicable) Do not fill the delay slots here; you will confuse the
2675 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2677 #if alpha_TARGET_ARCH
2678 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2679 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2680 #endif {- alpha_TARGET_ARCH -}
2682 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2683 #if i386_TARGET_ARCH
2686 = condIntCode cond x y `thenNat` \ condition ->
2687 getNewRegNCG IntRep `thenNat` \ tmp ->
2689 code = condCode condition
2690 cond = condName condition
2691 code__2 dst = code `appOL` toOL [
2692 SETCC cond (OpReg tmp),
2693 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2694 MOV L (OpReg tmp) (OpReg dst)]
2696 returnNat (Any IntRep code__2)
2699 = getNatLabelNCG `thenNat` \ lbl1 ->
2700 getNatLabelNCG `thenNat` \ lbl2 ->
2701 condFltCode cond x y `thenNat` \ condition ->
2703 code = condCode condition
2704 cond = condName condition
2705 code__2 dst = code `appOL` toOL [
2707 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2710 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2713 returnNat (Any IntRep code__2)
2715 #endif {- i386_TARGET_ARCH -}
2716 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2717 #if sparc_TARGET_ARCH
2719 condIntReg EQQ x (StInt 0)
2720 = getRegister x `thenNat` \ register ->
2721 getNewRegNCG IntRep `thenNat` \ tmp ->
2723 code = registerCode register tmp
2724 src = registerName register tmp
2725 code__2 dst = code `appOL` toOL [
2726 SUB False True g0 (RIReg src) g0,
2727 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2729 returnNat (Any IntRep code__2)
2732 = getRegister x `thenNat` \ register1 ->
2733 getRegister y `thenNat` \ register2 ->
2734 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2735 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2737 code1 = registerCode register1 tmp1
2738 src1 = registerName register1 tmp1
2739 code2 = registerCode register2 tmp2
2740 src2 = registerName register2 tmp2
2741 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2742 XOR False src1 (RIReg src2) dst,
2743 SUB False True g0 (RIReg dst) g0,
2744 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2746 returnNat (Any IntRep code__2)
2748 condIntReg NE x (StInt 0)
2749 = getRegister x `thenNat` \ register ->
2750 getNewRegNCG IntRep `thenNat` \ tmp ->
2752 code = registerCode register tmp
2753 src = registerName register tmp
2754 code__2 dst = code `appOL` toOL [
2755 SUB False True g0 (RIReg src) g0,
2756 ADD True False g0 (RIImm (ImmInt 0)) dst]
2758 returnNat (Any IntRep code__2)
2761 = getRegister x `thenNat` \ register1 ->
2762 getRegister y `thenNat` \ register2 ->
2763 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2764 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2766 code1 = registerCode register1 tmp1
2767 src1 = registerName register1 tmp1
2768 code2 = registerCode register2 tmp2
2769 src2 = registerName register2 tmp2
2770 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2771 XOR False src1 (RIReg src2) dst,
2772 SUB False True g0 (RIReg dst) g0,
2773 ADD True False g0 (RIImm (ImmInt 0)) dst]
2775 returnNat (Any IntRep code__2)
2778 = getNatLabelNCG `thenNat` \ lbl1 ->
2779 getNatLabelNCG `thenNat` \ lbl2 ->
2780 condIntCode cond x y `thenNat` \ condition ->
2782 code = condCode condition
2783 cond = condName condition
2784 code__2 dst = code `appOL` toOL [
2785 BI cond False (ImmCLbl lbl1), NOP,
2786 OR False g0 (RIImm (ImmInt 0)) dst,
2787 BI ALWAYS False (ImmCLbl lbl2), NOP,
2789 OR False g0 (RIImm (ImmInt 1)) dst,
2792 returnNat (Any IntRep code__2)
2795 = getNatLabelNCG `thenNat` \ lbl1 ->
2796 getNatLabelNCG `thenNat` \ lbl2 ->
2797 condFltCode cond x y `thenNat` \ condition ->
2799 code = condCode condition
2800 cond = condName condition
2801 code__2 dst = code `appOL` toOL [
2803 BF cond False (ImmCLbl lbl1), NOP,
2804 OR False g0 (RIImm (ImmInt 0)) dst,
2805 BI ALWAYS False (ImmCLbl lbl2), NOP,
2807 OR False g0 (RIImm (ImmInt 1)) dst,
2810 returnNat (Any IntRep code__2)
2812 #endif {- sparc_TARGET_ARCH -}
2815 %************************************************************************
2817 \subsubsection{@trivial*Code@: deal with trivial instructions}
2819 %************************************************************************
2821 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2822 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2823 for constants on the right hand side, because that's where the generic
2824 optimizer will have put them.
2826 Similarly, for unary instructions, we don't have to worry about
2827 matching an StInt as the argument, because genericOpt will already
2828 have handled the constant-folding.
2832 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2833 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2834 -> Maybe (Operand -> Operand -> Instr)
2835 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2837 -> StixTree -> StixTree -- the two arguments
2842 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2843 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2844 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2846 -> StixTree -> StixTree -- the two arguments
2850 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2851 ,IF_ARCH_i386 ((Operand -> Instr)
2852 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2854 -> StixTree -- the one argument
2859 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2860 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2861 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2863 -> StixTree -- the one argument
2866 #if alpha_TARGET_ARCH
2868 trivialCode instr x (StInt y)
2870 = getRegister x `thenNat` \ register ->
2871 getNewRegNCG IntRep `thenNat` \ tmp ->
2873 code = registerCode register tmp
2874 src1 = registerName register tmp
2875 src2 = ImmInt (fromInteger y)
2876 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2878 returnNat (Any IntRep code__2)
2880 trivialCode instr x y
2881 = getRegister x `thenNat` \ register1 ->
2882 getRegister y `thenNat` \ register2 ->
2883 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2884 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2886 code1 = registerCode register1 tmp1 []
2887 src1 = registerName register1 tmp1
2888 code2 = registerCode register2 tmp2 []
2889 src2 = registerName register2 tmp2
2890 code__2 dst = asmSeqThen [code1, code2] .
2891 mkSeqInstr (instr src1 (RIReg src2) dst)
2893 returnNat (Any IntRep code__2)
2896 trivialUCode instr x
2897 = getRegister x `thenNat` \ register ->
2898 getNewRegNCG IntRep `thenNat` \ tmp ->
2900 code = registerCode register tmp
2901 src = registerName register tmp
2902 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2904 returnNat (Any IntRep code__2)
2907 trivialFCode _ instr x y
2908 = getRegister x `thenNat` \ register1 ->
2909 getRegister y `thenNat` \ register2 ->
2910 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2911 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2913 code1 = registerCode register1 tmp1
2914 src1 = registerName register1 tmp1
2916 code2 = registerCode register2 tmp2
2917 src2 = registerName register2 tmp2
2919 code__2 dst = asmSeqThen [code1 [], code2 []] .
2920 mkSeqInstr (instr src1 src2 dst)
2922 returnNat (Any DoubleRep code__2)
2924 trivialUFCode _ instr x
2925 = getRegister x `thenNat` \ register ->
2926 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2928 code = registerCode register tmp
2929 src = registerName register tmp
2930 code__2 dst = code . mkSeqInstr (instr src dst)
2932 returnNat (Any DoubleRep code__2)
2934 #endif {- alpha_TARGET_ARCH -}
2935 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2936 #if i386_TARGET_ARCH
2938 The Rules of the Game are:
2940 * You cannot assume anything about the destination register dst;
2941 it may be anything, including a fixed reg.
2943 * You may compute an operand into a fixed reg, but you may not
2944 subsequently change the contents of that fixed reg. If you
2945 want to do so, first copy the value either to a temporary
2946 or into dst. You are free to modify dst even if it happens
2947 to be a fixed reg -- that's not your problem.
2949 * You cannot assume that a fixed reg will stay live over an
2950 arbitrary computation. The same applies to the dst reg.
2952 * Temporary regs obtained from getNewRegNCG are distinct from
2953 each other and from all other regs, and stay live over
2954 arbitrary computations.
2958 trivialCode instr maybe_revinstr a b
2961 = getRegister a `thenNat` \ rega ->
2964 then registerCode rega dst `bind` \ code_a ->
2966 instr (OpImm imm_b) (OpReg dst)
2967 else registerCodeF rega `bind` \ code_a ->
2968 registerNameF rega `bind` \ r_a ->
2970 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2971 instr (OpImm imm_b) (OpReg dst)
2973 returnNat (Any IntRep mkcode)
2976 = getRegister b `thenNat` \ regb ->
2977 getNewRegNCG IntRep `thenNat` \ tmp ->
2978 let revinstr_avail = maybeToBool maybe_revinstr
2979 revinstr = case maybe_revinstr of Just ri -> ri
2983 then registerCode regb dst `bind` \ code_b ->
2985 revinstr (OpImm imm_a) (OpReg dst)
2986 else registerCodeF regb `bind` \ code_b ->
2987 registerNameF regb `bind` \ r_b ->
2989 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2990 revinstr (OpImm imm_a) (OpReg dst)
2994 then registerCode regb tmp `bind` \ code_b ->
2996 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2997 instr (OpReg tmp) (OpReg dst)
2998 else registerCodeF regb `bind` \ code_b ->
2999 registerNameF regb `bind` \ r_b ->
3001 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3002 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3003 instr (OpReg tmp) (OpReg dst)
3005 returnNat (Any IntRep mkcode)
3008 = getRegister a `thenNat` \ rega ->
3009 getRegister b `thenNat` \ regb ->
3010 getNewRegNCG IntRep `thenNat` \ tmp ->
3012 = case (isAny rega, isAny regb) of
3014 -> registerCode regb tmp `bind` \ code_b ->
3015 registerCode rega dst `bind` \ code_a ->
3018 instr (OpReg tmp) (OpReg dst)
3020 -> registerCode rega tmp `bind` \ code_a ->
3021 registerCodeF regb `bind` \ code_b ->
3022 registerNameF regb `bind` \ r_b ->
3025 instr (OpReg r_b) (OpReg tmp) `snocOL`
3026 MOV L (OpReg tmp) (OpReg dst)
3028 -> registerCode regb tmp `bind` \ code_b ->
3029 registerCodeF rega `bind` \ code_a ->
3030 registerNameF rega `bind` \ r_a ->
3033 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3034 instr (OpReg tmp) (OpReg dst)
3036 -> registerCodeF rega `bind` \ code_a ->
3037 registerNameF rega `bind` \ r_a ->
3038 registerCodeF regb `bind` \ code_b ->
3039 registerNameF regb `bind` \ r_b ->
3041 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3043 instr (OpReg r_b) (OpReg tmp) `snocOL`
3044 MOV L (OpReg tmp) (OpReg dst)
3046 returnNat (Any IntRep mkcode)
3049 maybe_imm_a = maybeImm a
3050 is_imm_a = maybeToBool maybe_imm_a
3051 imm_a = case maybe_imm_a of Just imm -> imm
3053 maybe_imm_b = maybeImm b
3054 is_imm_b = maybeToBool maybe_imm_b
3055 imm_b = case maybe_imm_b of Just imm -> imm
3059 trivialUCode instr x
3060 = getRegister x `thenNat` \ register ->
3062 code__2 dst = let code = registerCode register dst
3063 src = registerName register dst
3065 if isFixed register && dst /= src
3066 then toOL [MOV L (OpReg src) (OpReg dst),
3068 else unitOL (instr (OpReg src))
3070 returnNat (Any IntRep code__2)
3073 trivialFCode pk instr x y
3074 = getRegister x `thenNat` \ register1 ->
3075 getRegister y `thenNat` \ register2 ->
3076 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3077 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3079 code1 = registerCode register1 tmp1
3080 src1 = registerName register1 tmp1
3082 code2 = registerCode register2 tmp2
3083 src2 = registerName register2 tmp2
3086 -- treat the common case specially: both operands in
3088 | isAny register1 && isAny register2
3091 instr (primRepToSize pk) src1 src2 dst
3093 -- be paranoid (and inefficient)
3095 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3097 instr (primRepToSize pk) tmp1 src2 dst
3099 returnNat (Any pk code__2)
3103 trivialUFCode pk instr x
3104 = getRegister x `thenNat` \ register ->
3105 getNewRegNCG pk `thenNat` \ tmp ->
3107 code = registerCode register tmp
3108 src = registerName register tmp
3109 code__2 dst = code `snocOL` instr src dst
3111 returnNat (Any pk code__2)
3113 #endif {- i386_TARGET_ARCH -}
3114 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3115 #if sparc_TARGET_ARCH
3117 trivialCode instr x (StInt y)
3119 = getRegister x `thenNat` \ register ->
3120 getNewRegNCG IntRep `thenNat` \ tmp ->
3122 code = registerCode register tmp
3123 src1 = registerName register tmp
3124 src2 = ImmInt (fromInteger y)
3125 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3127 returnNat (Any IntRep code__2)
3129 trivialCode instr x y
3130 = getRegister x `thenNat` \ register1 ->
3131 getRegister y `thenNat` \ register2 ->
3132 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3133 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3135 code1 = registerCode register1 tmp1
3136 src1 = registerName register1 tmp1
3137 code2 = registerCode register2 tmp2
3138 src2 = registerName register2 tmp2
3139 code__2 dst = code1 `appOL` code2 `snocOL`
3140 instr src1 (RIReg src2) dst
3142 returnNat (Any IntRep code__2)
3145 trivialFCode pk instr x y
3146 = getRegister x `thenNat` \ register1 ->
3147 getRegister y `thenNat` \ register2 ->
3148 getNewRegNCG (registerRep register1)
3150 getNewRegNCG (registerRep register2)
3152 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3154 promote x = FxTOy F DF x tmp
3156 pk1 = registerRep register1
3157 code1 = registerCode register1 tmp1
3158 src1 = registerName register1 tmp1
3160 pk2 = registerRep register2
3161 code2 = registerCode register2 tmp2
3162 src2 = registerName register2 tmp2
3166 code1 `appOL` code2 `snocOL`
3167 instr (primRepToSize pk) src1 src2 dst
3168 else if pk1 == FloatRep then
3169 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3170 instr DF tmp src2 dst
3172 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3173 instr DF src1 tmp dst
3175 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3178 trivialUCode instr x
3179 = getRegister x `thenNat` \ register ->
3180 getNewRegNCG IntRep `thenNat` \ tmp ->
3182 code = registerCode register tmp
3183 src = registerName register tmp
3184 code__2 dst = code `snocOL` instr (RIReg src) dst
3186 returnNat (Any IntRep code__2)
3189 trivialUFCode pk instr x
3190 = getRegister x `thenNat` \ register ->
3191 getNewRegNCG pk `thenNat` \ tmp ->
3193 code = registerCode register tmp
3194 src = registerName register tmp
3195 code__2 dst = code `snocOL` instr src dst
3197 returnNat (Any pk code__2)
3199 #endif {- sparc_TARGET_ARCH -}
3202 %************************************************************************
3204 \subsubsection{Coercing to/from integer/floating-point...}
3206 %************************************************************************
3208 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3209 to be generated. Here we just change the type on the Register passed
3210 on up. The code is machine-independent.
3212 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3213 conversions. We have to store temporaries in memory to move
3214 between the integer and the floating point register sets.
3217 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3218 coerceFltCode :: StixTree -> NatM Register
3220 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3221 coerceFP2Int :: StixTree -> NatM Register
3224 = getRegister x `thenNat` \ register ->
3227 Fixed _ reg code -> Fixed pk reg code
3228 Any _ code -> Any pk code
3233 = getRegister x `thenNat` \ register ->
3236 Fixed _ reg code -> Fixed DoubleRep reg code
3237 Any _ code -> Any DoubleRep code
3242 #if alpha_TARGET_ARCH
3245 = getRegister x `thenNat` \ register ->
3246 getNewRegNCG IntRep `thenNat` \ reg ->
3248 code = registerCode register reg
3249 src = registerName register reg
3251 code__2 dst = code . mkSeqInstrs [
3253 LD TF dst (spRel 0),
3256 returnNat (Any DoubleRep code__2)
3260 = getRegister x `thenNat` \ register ->
3261 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3263 code = registerCode register tmp
3264 src = registerName register tmp
3266 code__2 dst = code . mkSeqInstrs [
3268 ST TF tmp (spRel 0),
3271 returnNat (Any IntRep code__2)
3273 #endif {- alpha_TARGET_ARCH -}
3274 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3275 #if i386_TARGET_ARCH
3278 = getRegister x `thenNat` \ register ->
3279 getNewRegNCG IntRep `thenNat` \ reg ->
3281 code = registerCode register reg
3282 src = registerName register reg
3283 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3284 code__2 dst = code `snocOL` opc src dst
3286 returnNat (Any pk code__2)
3290 = getRegister x `thenNat` \ register ->
3291 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3293 code = registerCode register tmp
3294 src = registerName register tmp
3295 pk = registerRep register
3297 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3298 code__2 dst = code `snocOL` opc src dst
3300 returnNat (Any IntRep code__2)
3302 #endif {- i386_TARGET_ARCH -}
3303 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3304 #if sparc_TARGET_ARCH
3307 = getRegister x `thenNat` \ register ->
3308 getNewRegNCG IntRep `thenNat` \ reg ->
3310 code = registerCode register reg
3311 src = registerName register reg
3313 code__2 dst = code `appOL` toOL [
3314 ST W src (spRel (-2)),
3315 LD W (spRel (-2)) dst,
3316 FxTOy W (primRepToSize pk) dst dst]
3318 returnNat (Any pk code__2)
3322 = getRegister x `thenNat` \ register ->
3323 getNewRegNCG IntRep `thenNat` \ reg ->
3324 getNewRegNCG FloatRep `thenNat` \ tmp ->
3326 code = registerCode register reg
3327 src = registerName register reg
3328 pk = registerRep register
3330 code__2 dst = code `appOL` toOL [
3331 FxTOy (primRepToSize pk) W src tmp,
3332 ST W tmp (spRel (-2)),
3333 LD W (spRel (-2)) dst]
3335 returnNat (Any IntRep code__2)
3337 #endif {- sparc_TARGET_ARCH -}
3340 %************************************************************************
3342 \subsubsection{Coercing integer to @Char@...}
3344 %************************************************************************
3346 Integer to character conversion.
3349 chrCode :: StixTree -> NatM Register
3351 #if alpha_TARGET_ARCH
3353 -- TODO: This is probably wrong, but I don't know Alpha assembler.
3354 -- It should coerce a 64-bit value to a 32-bit value.
3357 = getRegister x `thenNat` \ register ->
3358 getNewRegNCG IntRep `thenNat` \ reg ->
3360 code = registerCode register reg
3361 src = registerName register reg
3362 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3364 returnNat (Any IntRep code__2)
3366 #endif {- alpha_TARGET_ARCH -}
3367 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3368 #if i386_TARGET_ARCH
3371 = getRegister x `thenNat` \ register ->
3374 Fixed _ reg code -> Fixed IntRep reg code
3375 Any _ code -> Any IntRep code
3378 #endif {- i386_TARGET_ARCH -}
3379 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3380 #if sparc_TARGET_ARCH
3383 = getRegister x `thenNat` \ register ->
3386 Fixed _ reg code -> Fixed IntRep reg code
3387 Any _ code -> Any IntRep code
3390 #endif {- sparc_TARGET_ARCH -}