2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[MachCode]{Generating machine code}
6 This is a big module, but, if you pay attention to
7 (a) the sectioning, (b) the type signatures, and
8 (c) the \tr{#if blah_TARGET_ARCH} things, the
9 structure should not be too overwhelming.
12 module MachCode ( stmtsToInstrs, InstrBlock ) where
14 #include "HsVersions.h"
15 #include "nativeGen/NCG.h"
17 import MachMisc -- may differ per-platform
19 import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
20 snocOL, consOL, concatOL )
21 import AbsCUtils ( magicIdPrimRep )
22 import CallConv ( CallConv )
23 import CLabel ( isAsmTemp, CLabel, labelDynamic )
24 import Maybes ( maybeToBool, expectJust )
25 import PrimRep ( isFloatingRep, PrimRep(..) )
26 import PrimOp ( PrimOp(..) )
27 import CallConv ( cCallConv, stdCallConv )
28 import Stix ( getNatLabelNCG, StixTree(..),
29 StixReg(..), CodeSegment(..),
30 DestInfo, hasDestInfo,
32 NatM, thenNat, returnNat, mapNat,
33 mapAndUnzipNat, mapAccumLNat,
34 getDeltaNat, setDeltaNat
37 import CmdLineOpts ( opt_Static )
43 @InstrBlock@s are the insn sequences generated by the insn selectors.
44 They are really trees of insns to facilitate fast appending, where a
45 left-to-right traversal (pre-order?) yields the insns in the correct
50 type InstrBlock = OrdList Instr
56 Code extractor for an entire stix tree---stix statement level.
59 stmtsToInstrs :: [StixTree] -> NatM InstrBlock
61 = liftStrings stmts [] [] `thenNat` \ lifted ->
62 mapNat stmtToInstrs lifted `thenNat` \ instrss ->
63 returnNat (concatOL instrss)
66 -- Lift StStrings out of top-level StDatas, putting them at the end of
67 -- the block, and replacing them with StCLbls which refer to the lifted-out strings.
68 {- Motivation for this hackery provided by the following bug:
72 (Data P_ Addr.A#_static_info)
73 (Data StgAddr (Str `alalal'))
78 .global Bogon_ping_closure
80 .long Addr_Azh_static_info
91 ie, the Str is planted in-line, when what we really meant was to place
92 a _reference_ to the string there. liftStrings will lift out all such
93 strings in top-level data and place them at the end of the block.
95 This is still a rather half-baked solution -- to do the job entirely right
96 would mean a complete traversal of all the Stixes, but there's currently no
97 real need for it, and it would be slow. Also, potentially there could be
98 literal types other than strings which need lifting out?
101 liftStrings :: [StixTree] -- originals
102 -> [StixTree] -- (reverse) originals with strings lifted out
103 -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels
106 -- First, examine the original trees and lift out strings in top-level StDatas.
107 liftStrings (st:sts) acc_stix acc_strs
110 -> lift datas acc_strs `thenNat` \ (datas_done, acc_strs1) ->
111 liftStrings sts ((StData sz datas_done):acc_stix) acc_strs1
113 -> liftStrings sts (other:acc_stix) acc_strs
115 -- Handle a top-level StData
116 lift [] acc_strs = returnNat ([], acc_strs)
118 = lift ds acc_strs `thenNat` \ (ds_done, acc_strs1) ->
121 -> getNatLabelNCG `thenNat` \ lbl ->
122 returnNat ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
124 -> returnNat (other:ds_done, acc_strs1)
126 -- When we've run out of original trees, emit the lifted strings.
127 liftStrings [] acc_stix acc_strs
128 = returnNat (reverse acc_stix ++ concatMap f acc_strs)
130 f (lbl,str) = [StSegment RoDataSegment,
133 StSegment TextSegment]
136 stmtToInstrs :: StixTree {- a stix statement -} -> NatM InstrBlock
137 stmtToInstrs stmt = case stmt of
138 StComment s -> returnNat (unitOL (COMMENT s))
139 StSegment seg -> returnNat (unitOL (SEGMENT seg))
141 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
143 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
146 StLabel lab -> returnNat (unitOL (LABEL lab))
148 StJump dsts arg -> genJump dsts (derefDLL arg)
149 StCondJump lab arg -> genCondJump lab (derefDLL arg)
151 -- A call returning void, ie one done for its side-effects
152 StCall fn cconv VoidRep args -> genCCall fn
153 cconv VoidRep (map derefDLL args)
156 | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
157 | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
160 -- When falling through on the Alpha, we still have to load pv
161 -- with the address of the next routine, so that it can load gp.
162 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
166 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
167 returnNat (DATA (primRepToSize kind) imms
168 `consOL` concatOL codes)
170 getData :: StixTree -> NatM (InstrBlock, Imm)
171 getData (StInt i) = returnNat (nilOL, ImmInteger i)
172 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
173 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
174 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
175 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
176 -- the linker can handle simple arithmetic...
177 getData (StIndex rep (StCLbl lbl) (StInt off)) =
179 ImmIndex lbl (fromInteger off * sizeOf rep))
181 -- Top-level lifted-out string. The segment will already have been set
182 -- (see liftStrings above).
184 -> returnNat (unitOL (ASCII True (_UNPK_ str)))
187 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
188 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
189 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
191 derefDLL :: StixTree -> StixTree
193 | opt_Static -- short out the entire deal if not doing DLLs
200 StCLbl lbl -> if labelDynamic lbl
201 then StInd PtrRep (StCLbl lbl)
203 -- all the rest are boring
204 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
205 StPrim pk args -> StPrim pk (map qq args)
206 StInd pk addr -> StInd pk (qq addr)
207 StCall who cc pk args -> StCall who cc pk (map qq args)
214 _ -> pprPanic "derefDLL: unhandled case"
218 %************************************************************************
220 \subsection{General things for putting together code sequences}
222 %************************************************************************
225 mangleIndexTree :: StixTree -> StixTree
227 mangleIndexTree (StIndex pk base (StInt i))
228 = StPrim IntAddOp [base, off]
230 off = StInt (i * toInteger (sizeOf pk))
232 mangleIndexTree (StIndex pk base off)
236 in if s == 0 then off else StPrim SllOp [off, StInt (toInteger s)]
239 shift :: PrimRep -> Int
240 shift rep = case sizeOf rep of
245 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
250 maybeImm :: StixTree -> Maybe Imm
254 maybeImm (StIndex rep (StCLbl l) (StInt off))
255 = Just (ImmIndex l (fromInteger off * sizeOf rep))
257 | i >= toInteger minInt && i <= toInteger maxInt
258 = Just (ImmInt (fromInteger i))
260 = Just (ImmInteger i)
265 %************************************************************************
267 \subsection{The @Register@ type}
269 %************************************************************************
271 @Register@s passed up the tree. If the stix code forces the register
272 to live in a pre-decided machine register, it comes out as @Fixed@;
273 otherwise, it comes out as @Any@, and the parent can decide which
274 register to put it in.
278 = Fixed PrimRep Reg InstrBlock
279 | Any PrimRep (Reg -> InstrBlock)
281 registerCode :: Register -> Reg -> InstrBlock
282 registerCode (Fixed _ _ code) reg = code
283 registerCode (Any _ code) reg = code reg
285 registerCodeF (Fixed _ _ code) = code
286 registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
288 registerCodeA (Any _ code) = code
289 registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
291 registerName :: Register -> Reg -> Reg
292 registerName (Fixed _ reg _) _ = reg
293 registerName (Any _ _) reg = reg
295 registerNameF (Fixed _ reg _) = reg
296 registerNameF (Any _ _) = pprPanic "registerNameF" empty
298 registerRep :: Register -> PrimRep
299 registerRep (Fixed pk _ _) = pk
300 registerRep (Any pk _) = pk
302 {-# INLINE registerCode #-}
303 {-# INLINE registerCodeF #-}
304 {-# INLINE registerName #-}
305 {-# INLINE registerNameF #-}
306 {-# INLINE registerRep #-}
307 {-# INLINE isFixed #-}
310 isFixed, isAny :: Register -> Bool
311 isFixed (Fixed _ _ _) = True
312 isFixed (Any _ _) = False
314 isAny = not . isFixed
317 Generate code to get a subtree into a @Register@:
319 getRegister :: StixTree -> NatM Register
321 getRegister (StReg (StixMagicId stgreg))
322 = case (magicIdRegMaybe stgreg) of
323 Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
326 getRegister (StReg (StixTemp u pk))
327 = returnNat (Fixed pk (mkVReg u pk) nilOL)
329 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
331 getRegister (StCall fn cconv kind args)
332 = genCCall fn cconv kind args `thenNat` \ call ->
333 returnNat (Fixed kind reg call)
335 reg = if isFloatingRep kind
336 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
337 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
339 getRegister (StString s)
340 = getNatLabelNCG `thenNat` \ lbl ->
342 imm_lbl = ImmCLbl lbl
345 SEGMENT RoDataSegment,
347 ASCII True (_UNPK_ s),
349 #if alpha_TARGET_ARCH
350 LDA dst (AddrImm imm_lbl)
353 MOV L (OpImm imm_lbl) (OpReg dst)
355 #if sparc_TARGET_ARCH
356 SETHI (HI imm_lbl) dst,
357 OR False dst (RIImm (LO imm_lbl)) dst
361 returnNat (Any PtrRep code)
365 -- end of machine-"independent" bit; here we go on the rest...
367 #if alpha_TARGET_ARCH
369 getRegister (StDouble d)
370 = getNatLabelNCG `thenNat` \ lbl ->
371 getNewRegNCG PtrRep `thenNat` \ tmp ->
372 let code dst = mkSeqInstrs [
375 DATA TF [ImmLab (rational d)],
377 LDA tmp (AddrImm (ImmCLbl lbl)),
378 LD TF dst (AddrReg tmp)]
380 returnNat (Any DoubleRep code)
382 getRegister (StPrim primop [x]) -- unary PrimOps
384 IntNegOp -> trivialUCode (NEG Q False) x
386 NotOp -> trivialUCode NOT x
388 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
389 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
391 OrdOp -> coerceIntCode IntRep x
394 Float2IntOp -> coerceFP2Int x
395 Int2FloatOp -> coerceInt2FP pr x
396 Double2IntOp -> coerceFP2Int x
397 Int2DoubleOp -> coerceInt2FP pr x
399 Double2FloatOp -> coerceFltCode x
400 Float2DoubleOp -> coerceFltCode x
402 other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
404 fn = case other_op of
405 FloatExpOp -> SLIT("exp")
406 FloatLogOp -> SLIT("log")
407 FloatSqrtOp -> SLIT("sqrt")
408 FloatSinOp -> SLIT("sin")
409 FloatCosOp -> SLIT("cos")
410 FloatTanOp -> SLIT("tan")
411 FloatAsinOp -> SLIT("asin")
412 FloatAcosOp -> SLIT("acos")
413 FloatAtanOp -> SLIT("atan")
414 FloatSinhOp -> SLIT("sinh")
415 FloatCoshOp -> SLIT("cosh")
416 FloatTanhOp -> SLIT("tanh")
417 DoubleExpOp -> SLIT("exp")
418 DoubleLogOp -> SLIT("log")
419 DoubleSqrtOp -> SLIT("sqrt")
420 DoubleSinOp -> SLIT("sin")
421 DoubleCosOp -> SLIT("cos")
422 DoubleTanOp -> SLIT("tan")
423 DoubleAsinOp -> SLIT("asin")
424 DoubleAcosOp -> SLIT("acos")
425 DoubleAtanOp -> SLIT("atan")
426 DoubleSinhOp -> SLIT("sinh")
427 DoubleCoshOp -> SLIT("cosh")
428 DoubleTanhOp -> SLIT("tanh")
430 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
432 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
434 CharGtOp -> trivialCode (CMP LTT) y x
435 CharGeOp -> trivialCode (CMP LE) y x
436 CharEqOp -> trivialCode (CMP EQQ) x y
437 CharNeOp -> int_NE_code x y
438 CharLtOp -> trivialCode (CMP LTT) x y
439 CharLeOp -> trivialCode (CMP LE) x y
441 IntGtOp -> trivialCode (CMP LTT) y x
442 IntGeOp -> trivialCode (CMP LE) y x
443 IntEqOp -> trivialCode (CMP EQQ) x y
444 IntNeOp -> int_NE_code x y
445 IntLtOp -> trivialCode (CMP LTT) x y
446 IntLeOp -> trivialCode (CMP LE) x y
448 WordGtOp -> trivialCode (CMP ULT) y x
449 WordGeOp -> trivialCode (CMP ULE) x y
450 WordEqOp -> trivialCode (CMP EQQ) x y
451 WordNeOp -> int_NE_code x y
452 WordLtOp -> trivialCode (CMP ULT) x y
453 WordLeOp -> trivialCode (CMP ULE) x y
455 AddrGtOp -> trivialCode (CMP ULT) y x
456 AddrGeOp -> trivialCode (CMP ULE) y x
457 AddrEqOp -> trivialCode (CMP EQQ) x y
458 AddrNeOp -> int_NE_code x y
459 AddrLtOp -> trivialCode (CMP ULT) x y
460 AddrLeOp -> trivialCode (CMP ULE) x y
462 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
463 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
464 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
465 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
466 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
467 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
469 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
470 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
471 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
472 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
473 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
474 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
476 IntAddOp -> trivialCode (ADD Q False) x y
477 IntSubOp -> trivialCode (SUB Q False) x y
478 IntMulOp -> trivialCode (MUL Q False) x y
479 IntQuotOp -> trivialCode (DIV Q False) x y
480 IntRemOp -> trivialCode (REM Q False) x y
482 WordAddOp -> trivialCode (ADD Q False) x y
483 WordSubOp -> trivialCode (SUB Q False) x y
484 WordMulOp -> trivialCode (MUL Q False) x y
485 WordQuotOp -> trivialCode (DIV Q True) x y
486 WordRemOp -> trivialCode (REM Q True) x y
488 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
489 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
490 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
491 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
493 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
494 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
495 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
496 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
498 AndOp -> trivialCode AND x y
499 OrOp -> trivialCode OR x y
500 XorOp -> trivialCode XOR x y
501 SllOp -> trivialCode SLL x y
502 SrlOp -> trivialCode SRL x y
504 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
505 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
506 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
508 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
509 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
511 {- ------------------------------------------------------------
512 Some bizarre special code for getting condition codes into
513 registers. Integer non-equality is a test for equality
514 followed by an XOR with 1. (Integer comparisons always set
515 the result register to 0 or 1.) Floating point comparisons of
516 any kind leave the result in a floating point register, so we
517 need to wrangle an integer register out of things.
519 int_NE_code :: StixTree -> StixTree -> NatM Register
522 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
523 getNewRegNCG IntRep `thenNat` \ tmp ->
525 code = registerCode register tmp
526 src = registerName register tmp
527 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
529 returnNat (Any IntRep code__2)
531 {- ------------------------------------------------------------
532 Comments for int_NE_code also apply to cmpF_code
535 :: (Reg -> Reg -> Reg -> Instr)
537 -> StixTree -> StixTree
540 cmpF_code instr cond x y
541 = trivialFCode pr instr x y `thenNat` \ register ->
542 getNewRegNCG DoubleRep `thenNat` \ tmp ->
543 getNatLabelNCG `thenNat` \ lbl ->
545 code = registerCode register tmp
546 result = registerName register tmp
548 code__2 dst = code . mkSeqInstrs [
549 OR zeroh (RIImm (ImmInt 1)) dst,
550 BF cond result (ImmCLbl lbl),
551 OR zeroh (RIReg zeroh) dst,
554 returnNat (Any IntRep code__2)
556 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
557 ------------------------------------------------------------
559 getRegister (StInd pk mem)
560 = getAmode mem `thenNat` \ amode ->
562 code = amodeCode amode
563 src = amodeAddr amode
564 size = primRepToSize pk
565 code__2 dst = code . mkSeqInstr (LD size dst src)
567 returnNat (Any pk code__2)
569 getRegister (StInt i)
572 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
574 returnNat (Any IntRep code)
577 code dst = mkSeqInstr (LDI Q dst src)
579 returnNat (Any IntRep code)
581 src = ImmInt (fromInteger i)
586 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
588 returnNat (Any PtrRep code)
591 imm__2 = case imm of Just x -> x
593 #endif {- alpha_TARGET_ARCH -}
594 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
597 getRegister (StFloat f)
598 = getNatLabelNCG `thenNat` \ lbl ->
599 let code dst = toOL [
604 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
607 returnNat (Any FloatRep code)
610 getRegister (StDouble d)
613 = let code dst = unitOL (GLDZ dst)
614 in returnNat (Any DoubleRep code)
617 = let code dst = unitOL (GLD1 dst)
618 in returnNat (Any DoubleRep code)
621 = getNatLabelNCG `thenNat` \ lbl ->
622 let code dst = toOL [
625 DATA DF [ImmDouble d],
627 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
630 returnNat (Any DoubleRep code)
632 -- Calculate the offset for (i+1) words above the _initial_
633 -- %esp value by first determining the current offset of it.
634 getRegister (StScratchWord i)
636 = getDeltaNat `thenNat` \ current_stack_offset ->
637 let j = i+1 - (current_stack_offset `div` 4)
639 = unitOL (LEA L (OpAddr (spRel j)) (OpReg dst))
641 returnNat (Any PtrRep code)
643 getRegister (StPrim primop [x]) -- unary PrimOps
645 IntNegOp -> trivialUCode (NEGI L) x
646 NotOp -> trivialUCode (NOT L) x
648 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
649 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
651 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
652 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
654 FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
655 DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
657 FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
658 DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
660 FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
661 DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
663 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
664 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
666 OrdOp -> coerceIntCode IntRep x
669 Float2IntOp -> coerceFP2Int x
670 Int2FloatOp -> coerceInt2FP FloatRep x
671 Double2IntOp -> coerceFP2Int x
672 Int2DoubleOp -> coerceInt2FP DoubleRep x
674 IntToInt8Op -> extendIntCode Int8Rep IntRep x
675 IntToInt16Op -> extendIntCode Int16Rep IntRep x
676 IntToInt32Op -> getRegister x
677 WordToWord8Op -> extendIntCode Word8Rep WordRep x
678 WordToWord16Op -> extendIntCode Word16Rep WordRep x
679 WordToWord32Op -> getRegister x
682 getRegister (StCall fn cCallConv DoubleRep [x])
686 FloatExpOp -> (True, SLIT("exp"))
687 FloatLogOp -> (True, SLIT("log"))
689 FloatAsinOp -> (True, SLIT("asin"))
690 FloatAcosOp -> (True, SLIT("acos"))
691 FloatAtanOp -> (True, SLIT("atan"))
693 FloatSinhOp -> (True, SLIT("sinh"))
694 FloatCoshOp -> (True, SLIT("cosh"))
695 FloatTanhOp -> (True, SLIT("tanh"))
697 DoubleExpOp -> (False, SLIT("exp"))
698 DoubleLogOp -> (False, SLIT("log"))
700 DoubleAsinOp -> (False, SLIT("asin"))
701 DoubleAcosOp -> (False, SLIT("acos"))
702 DoubleAtanOp -> (False, SLIT("atan"))
704 DoubleSinhOp -> (False, SLIT("sinh"))
705 DoubleCoshOp -> (False, SLIT("cosh"))
706 DoubleTanhOp -> (False, SLIT("tanh"))
709 -> pprPanic "getRegister(x86,unary primop)"
710 (pprStixTree (StPrim primop [x]))
712 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
714 CharGtOp -> condIntReg GTT x y
715 CharGeOp -> condIntReg GE x y
716 CharEqOp -> condIntReg EQQ x y
717 CharNeOp -> condIntReg NE x y
718 CharLtOp -> condIntReg LTT x y
719 CharLeOp -> condIntReg LE x y
721 IntGtOp -> condIntReg GTT x y
722 IntGeOp -> condIntReg GE x y
723 IntEqOp -> condIntReg EQQ x y
724 IntNeOp -> condIntReg NE x y
725 IntLtOp -> condIntReg LTT x y
726 IntLeOp -> condIntReg LE x y
728 WordGtOp -> condIntReg GU x y
729 WordGeOp -> condIntReg GEU x y
730 WordEqOp -> condIntReg EQQ x y
731 WordNeOp -> condIntReg NE x y
732 WordLtOp -> condIntReg LU x y
733 WordLeOp -> condIntReg LEU x y
735 AddrGtOp -> condIntReg GU x y
736 AddrGeOp -> condIntReg GEU x y
737 AddrEqOp -> condIntReg EQQ x y
738 AddrNeOp -> condIntReg NE x y
739 AddrLtOp -> condIntReg LU x y
740 AddrLeOp -> condIntReg LEU x y
742 FloatGtOp -> condFltReg GTT x y
743 FloatGeOp -> condFltReg GE x y
744 FloatEqOp -> condFltReg EQQ x y
745 FloatNeOp -> condFltReg NE x y
746 FloatLtOp -> condFltReg LTT x y
747 FloatLeOp -> condFltReg LE x y
749 DoubleGtOp -> condFltReg GTT x y
750 DoubleGeOp -> condFltReg GE x y
751 DoubleEqOp -> condFltReg EQQ x y
752 DoubleNeOp -> condFltReg NE x y
753 DoubleLtOp -> condFltReg LTT x y
754 DoubleLeOp -> condFltReg LE x y
756 IntAddOp -> add_code L x y
757 IntSubOp -> sub_code L x y
758 IntQuotOp -> trivialCode (IQUOT L) Nothing x y
759 IntRemOp -> trivialCode (IREM L) Nothing x y
760 IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
762 WordAddOp -> add_code L x y
763 WordSubOp -> sub_code L x y
764 WordMulOp -> let op = IMUL L in trivialCode op (Just op) x y
766 FloatAddOp -> trivialFCode FloatRep GADD x y
767 FloatSubOp -> trivialFCode FloatRep GSUB x y
768 FloatMulOp -> trivialFCode FloatRep GMUL x y
769 FloatDivOp -> trivialFCode FloatRep GDIV x y
771 DoubleAddOp -> trivialFCode DoubleRep GADD x y
772 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
773 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
774 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
776 AndOp -> let op = AND L in trivialCode op (Just op) x y
777 OrOp -> let op = OR L in trivialCode op (Just op) x y
778 XorOp -> let op = XOR L in trivialCode op (Just op) x y
780 {- Shift ops on x86s have constraints on their source, it
781 either has to be Imm, CL or 1
782 => trivialCode's is not restrictive enough (sigh.)
785 SllOp -> shift_code (SHL L) x y {-False-}
786 SrlOp -> shift_code (SHR L) x y {-False-}
787 ISllOp -> shift_code (SHL L) x y {-False-}
788 ISraOp -> shift_code (SAR L) x y {-False-}
789 ISrlOp -> shift_code (SHR L) x y {-False-}
791 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
792 [promote x, promote y])
793 where promote x = StPrim Float2DoubleOp [x]
794 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
797 -> pprPanic "getRegister(x86,dyadic primop)"
798 (pprStixTree (StPrim primop [x, y]))
802 shift_code :: (Imm -> Operand -> Instr)
807 {- Case1: shift length as immediate -}
808 -- Code is the same as the first eq. for trivialCode -- sigh.
809 shift_code instr x y{-amount-}
811 = getRegister x `thenNat` \ regx ->
814 then registerCodeA regx dst `bind` \ code_x ->
816 instr imm__2 (OpReg dst)
817 else registerCodeF regx `bind` \ code_x ->
818 registerNameF regx `bind` \ r_x ->
820 MOV L (OpReg r_x) (OpReg dst) `snocOL`
821 instr imm__2 (OpReg dst)
823 returnNat (Any IntRep mkcode)
826 imm__2 = case imm of Just x -> x
828 {- Case2: shift length is complex (non-immediate) -}
829 -- Since ECX is always used as a spill temporary, we can't
830 -- use it here to do non-immediate shifts. No big deal --
831 -- they are only very rare, and we can use an equivalent
832 -- test-and-jump sequence which doesn't use ECX.
833 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
834 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
835 shift_code instr x y{-amount-}
836 = getRegister x `thenNat` \ register1 ->
837 getRegister y `thenNat` \ register2 ->
838 getNatLabelNCG `thenNat` \ lbl_test3 ->
839 getNatLabelNCG `thenNat` \ lbl_test2 ->
840 getNatLabelNCG `thenNat` \ lbl_test1 ->
841 getNatLabelNCG `thenNat` \ lbl_test0 ->
842 getNatLabelNCG `thenNat` \ lbl_after ->
843 getNewRegNCG IntRep `thenNat` \ tmp ->
845 = let src_val = registerName register1 dst
846 code_val = registerCode register1 dst
847 src_amt = registerName register2 tmp
848 code_amt = registerCode register2 tmp
853 MOV L (OpReg src_amt) r_tmp `appOL`
855 MOV L (OpReg src_val) r_dst `appOL`
857 COMMENT (_PK_ "begin shift sequence"),
858 MOV L (OpReg src_val) r_dst,
859 MOV L (OpReg src_amt) r_tmp,
861 BT L (ImmInt 4) r_tmp,
863 instr (ImmInt 16) r_dst,
866 BT L (ImmInt 3) r_tmp,
868 instr (ImmInt 8) r_dst,
871 BT L (ImmInt 2) r_tmp,
873 instr (ImmInt 4) r_dst,
876 BT L (ImmInt 1) r_tmp,
878 instr (ImmInt 2) r_dst,
881 BT L (ImmInt 0) r_tmp,
883 instr (ImmInt 1) r_dst,
886 COMMENT (_PK_ "end shift sequence")
889 returnNat (Any IntRep code__2)
892 add_code :: Size -> StixTree -> StixTree -> NatM Register
894 add_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 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
911 sub_code :: Size -> StixTree -> StixTree -> NatM Register
913 sub_code sz x (StInt y)
914 = getRegister x `thenNat` \ register ->
915 getNewRegNCG IntRep `thenNat` \ tmp ->
917 code = registerCode register tmp
918 src1 = registerName register tmp
919 src2 = ImmInt (-(fromInteger y))
922 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
925 returnNat (Any IntRep code__2)
927 sub_code sz x y = trivialCode (SUB sz) Nothing x y
930 getRegister (StInd pk mem)
931 = getAmode mem `thenNat` \ amode ->
933 code = amodeCode amode
934 src = amodeAddr amode
935 size = primRepToSize pk
936 code__2 dst = code `snocOL`
937 if pk == DoubleRep || pk == FloatRep
938 then GLD size src dst
946 (OpAddr src) (OpReg dst)
948 returnNat (Any pk code__2)
950 getRegister (StInt i)
952 src = ImmInt (fromInteger i)
955 = unitOL (XOR L (OpReg dst) (OpReg dst))
957 = unitOL (MOV L (OpImm src) (OpReg dst))
959 returnNat (Any IntRep code)
963 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
965 returnNat (Any PtrRep code)
967 = pprPanic "getRegister(x86)" (pprStixTree leaf)
970 imm__2 = case imm of Just x -> x
972 #endif {- i386_TARGET_ARCH -}
973 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
974 #if sparc_TARGET_ARCH
976 getRegister (StFloat d)
977 = getNatLabelNCG `thenNat` \ lbl ->
978 getNewRegNCG PtrRep `thenNat` \ tmp ->
979 let code dst = toOL [
984 SETHI (HI (ImmCLbl lbl)) tmp,
985 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
987 returnNat (Any FloatRep code)
989 getRegister (StDouble d)
990 = getNatLabelNCG `thenNat` \ lbl ->
991 getNewRegNCG PtrRep `thenNat` \ tmp ->
992 let code dst = toOL [
995 DATA DF [ImmDouble d],
997 SETHI (HI (ImmCLbl lbl)) tmp,
998 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1000 returnNat (Any DoubleRep code)
1002 -- The 6-word scratch area is immediately below the frame pointer.
1003 -- Below that is the spill area.
1004 getRegister (StScratchWord i)
1007 code dst = unitOL (fpRelEA (i-6) dst)
1009 returnNat (Any PtrRep code)
1012 getRegister (StPrim primop [x]) -- unary PrimOps
1014 IntNegOp -> trivialUCode (SUB False False g0) x
1015 NotOp -> trivialUCode (XNOR False g0) x
1017 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
1018 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
1020 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
1021 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
1023 OrdOp -> coerceIntCode IntRep x
1026 Float2IntOp -> coerceFP2Int x
1027 Int2FloatOp -> coerceInt2FP FloatRep x
1028 Double2IntOp -> coerceFP2Int x
1029 Int2DoubleOp -> coerceInt2FP DoubleRep x
1033 fixed_x = if is_float_op -- promote to double
1034 then StPrim Float2DoubleOp [x]
1037 getRegister (StCall fn cCallConv DoubleRep [fixed_x])
1041 FloatExpOp -> (True, SLIT("exp"))
1042 FloatLogOp -> (True, SLIT("log"))
1043 FloatSqrtOp -> (True, SLIT("sqrt"))
1045 FloatSinOp -> (True, SLIT("sin"))
1046 FloatCosOp -> (True, SLIT("cos"))
1047 FloatTanOp -> (True, SLIT("tan"))
1049 FloatAsinOp -> (True, SLIT("asin"))
1050 FloatAcosOp -> (True, SLIT("acos"))
1051 FloatAtanOp -> (True, SLIT("atan"))
1053 FloatSinhOp -> (True, SLIT("sinh"))
1054 FloatCoshOp -> (True, SLIT("cosh"))
1055 FloatTanhOp -> (True, SLIT("tanh"))
1057 DoubleExpOp -> (False, SLIT("exp"))
1058 DoubleLogOp -> (False, SLIT("log"))
1059 DoubleSqrtOp -> (False, SLIT("sqrt"))
1061 DoubleSinOp -> (False, SLIT("sin"))
1062 DoubleCosOp -> (False, SLIT("cos"))
1063 DoubleTanOp -> (False, SLIT("tan"))
1065 DoubleAsinOp -> (False, SLIT("asin"))
1066 DoubleAcosOp -> (False, SLIT("acos"))
1067 DoubleAtanOp -> (False, SLIT("atan"))
1069 DoubleSinhOp -> (False, SLIT("sinh"))
1070 DoubleCoshOp -> (False, SLIT("cosh"))
1071 DoubleTanhOp -> (False, SLIT("tanh"))
1074 -> pprPanic "getRegister(sparc,monadicprimop)"
1075 (pprStixTree (StPrim primop [x]))
1077 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
1079 CharGtOp -> condIntReg GTT x y
1080 CharGeOp -> condIntReg GE x y
1081 CharEqOp -> condIntReg EQQ x y
1082 CharNeOp -> condIntReg NE x y
1083 CharLtOp -> condIntReg LTT x y
1084 CharLeOp -> condIntReg LE x y
1086 IntGtOp -> condIntReg GTT x y
1087 IntGeOp -> condIntReg GE x y
1088 IntEqOp -> condIntReg EQQ x y
1089 IntNeOp -> condIntReg NE x y
1090 IntLtOp -> condIntReg LTT x y
1091 IntLeOp -> condIntReg LE x y
1093 WordGtOp -> condIntReg GU x y
1094 WordGeOp -> condIntReg GEU x y
1095 WordEqOp -> condIntReg EQQ x y
1096 WordNeOp -> condIntReg NE x y
1097 WordLtOp -> condIntReg LU x y
1098 WordLeOp -> condIntReg LEU x y
1100 AddrGtOp -> condIntReg GU x y
1101 AddrGeOp -> condIntReg GEU x y
1102 AddrEqOp -> condIntReg EQQ x y
1103 AddrNeOp -> condIntReg NE x y
1104 AddrLtOp -> condIntReg LU x y
1105 AddrLeOp -> condIntReg LEU x y
1107 FloatGtOp -> condFltReg GTT x y
1108 FloatGeOp -> condFltReg GE x y
1109 FloatEqOp -> condFltReg EQQ x y
1110 FloatNeOp -> condFltReg NE x y
1111 FloatLtOp -> condFltReg LTT x y
1112 FloatLeOp -> condFltReg LE x y
1114 DoubleGtOp -> condFltReg GTT x y
1115 DoubleGeOp -> condFltReg GE x y
1116 DoubleEqOp -> condFltReg EQQ x y
1117 DoubleNeOp -> condFltReg NE x y
1118 DoubleLtOp -> condFltReg LTT x y
1119 DoubleLeOp -> condFltReg LE x y
1121 IntAddOp -> trivialCode (ADD False False) x y
1122 IntSubOp -> trivialCode (SUB False False) x y
1124 -- ToDo: teach about V8+ SPARC mul/div instructions
1125 IntMulOp -> imul_div SLIT(".umul") x y
1126 IntQuotOp -> imul_div SLIT(".div") x y
1127 IntRemOp -> imul_div SLIT(".rem") x y
1129 WordAddOp -> trivialCode (ADD False False) x y
1130 WordSubOp -> trivialCode (SUB False False) x y
1131 WordMulOp -> imul_div SLIT(".umul") x y
1133 FloatAddOp -> trivialFCode FloatRep FADD x y
1134 FloatSubOp -> trivialFCode FloatRep FSUB x y
1135 FloatMulOp -> trivialFCode FloatRep FMUL x y
1136 FloatDivOp -> trivialFCode FloatRep FDIV x y
1138 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1139 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1140 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1141 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1143 AndOp -> trivialCode (AND False) x y
1144 OrOp -> trivialCode (OR False) x y
1145 XorOp -> trivialCode (XOR False) x y
1146 SllOp -> trivialCode SLL x y
1147 SrlOp -> trivialCode SRL x y
1149 ISllOp -> trivialCode SLL x y
1150 ISraOp -> trivialCode SRA x y
1151 ISrlOp -> trivialCode SRL x y
1153 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1154 [promote x, promote y])
1155 where promote x = StPrim Float2DoubleOp [x]
1156 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1160 -> pprPanic "getRegister(sparc,dyadic primop)"
1161 (pprStixTree (StPrim primop [x, y]))
1164 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1166 getRegister (StInd pk mem)
1167 = getAmode mem `thenNat` \ amode ->
1169 code = amodeCode amode
1170 src = amodeAddr amode
1171 size = primRepToSize pk
1172 code__2 dst = code `snocOL` LD size src dst
1174 returnNat (Any pk code__2)
1176 getRegister (StInt i)
1179 src = ImmInt (fromInteger i)
1180 code dst = unitOL (OR False g0 (RIImm src) dst)
1182 returnNat (Any IntRep code)
1188 SETHI (HI imm__2) dst,
1189 OR False dst (RIImm (LO imm__2)) dst]
1191 returnNat (Any PtrRep code)
1193 = pprPanic "getRegister(sparc)" (pprStixTree leaf)
1196 imm__2 = case imm of Just x -> x
1198 #endif {- sparc_TARGET_ARCH -}
1201 %************************************************************************
1203 \subsection{The @Amode@ type}
1205 %************************************************************************
1207 @Amode@s: Memory addressing modes passed up the tree.
1209 data Amode = Amode MachRegsAddr InstrBlock
1211 amodeAddr (Amode addr _) = addr
1212 amodeCode (Amode _ code) = code
1215 Now, given a tree (the argument to an StInd) that references memory,
1216 produce a suitable addressing mode.
1218 A Rule of the Game (tm) for Amodes: use of the addr bit must
1219 immediately follow use of the code part, since the code part puts
1220 values in registers which the addr then refers to. So you can't put
1221 anything in between, lest it overwrite some of those registers. If
1222 you need to do some other computation between the code part and use of
1223 the addr bit, first store the effective address from the amode in a
1224 temporary, then do the other computation, and then use the temporary:
1228 ... other computation ...
1232 getAmode :: StixTree -> NatM Amode
1234 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1236 #if alpha_TARGET_ARCH
1238 getAmode (StPrim IntSubOp [x, StInt i])
1239 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1240 getRegister x `thenNat` \ register ->
1242 code = registerCode register tmp
1243 reg = registerName register tmp
1244 off = ImmInt (-(fromInteger i))
1246 returnNat (Amode (AddrRegImm reg off) code)
1248 getAmode (StPrim IntAddOp [x, StInt i])
1249 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1250 getRegister x `thenNat` \ register ->
1252 code = registerCode register tmp
1253 reg = registerName register tmp
1254 off = ImmInt (fromInteger i)
1256 returnNat (Amode (AddrRegImm reg off) code)
1260 = returnNat (Amode (AddrImm imm__2) id)
1263 imm__2 = case imm of Just x -> x
1266 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1267 getRegister other `thenNat` \ register ->
1269 code = registerCode register tmp
1270 reg = registerName register tmp
1272 returnNat (Amode (AddrReg reg) code)
1274 #endif {- alpha_TARGET_ARCH -}
1275 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1276 #if i386_TARGET_ARCH
1278 getAmode (StPrim IntSubOp [x, StInt i])
1279 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1280 getRegister x `thenNat` \ register ->
1282 code = registerCode register tmp
1283 reg = registerName register tmp
1284 off = ImmInt (-(fromInteger i))
1286 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1288 getAmode (StPrim IntAddOp [x, StInt i])
1290 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1293 imm__2 = case imm of Just x -> x
1295 getAmode (StPrim IntAddOp [x, StInt i])
1296 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1297 getRegister x `thenNat` \ register ->
1299 code = registerCode register tmp
1300 reg = registerName register tmp
1301 off = ImmInt (fromInteger i)
1303 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1305 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1306 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1307 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1308 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1309 getRegister x `thenNat` \ register1 ->
1310 getRegister y `thenNat` \ register2 ->
1312 code1 = registerCode register1 tmp1
1313 reg1 = registerName register1 tmp1
1314 code2 = registerCode register2 tmp2
1315 reg2 = registerName register2 tmp2
1316 code__2 = code1 `appOL` code2
1317 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1319 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1324 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1327 imm__2 = case imm of Just x -> x
1330 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1331 getRegister other `thenNat` \ register ->
1333 code = registerCode register tmp
1334 reg = registerName register tmp
1336 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1338 #endif {- i386_TARGET_ARCH -}
1339 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1340 #if sparc_TARGET_ARCH
1342 getAmode (StPrim IntSubOp [x, StInt i])
1344 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1345 getRegister x `thenNat` \ register ->
1347 code = registerCode register tmp
1348 reg = registerName register tmp
1349 off = ImmInt (-(fromInteger i))
1351 returnNat (Amode (AddrRegImm reg off) code)
1354 getAmode (StPrim IntAddOp [x, StInt i])
1356 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1357 getRegister x `thenNat` \ register ->
1359 code = registerCode register tmp
1360 reg = registerName register tmp
1361 off = ImmInt (fromInteger i)
1363 returnNat (Amode (AddrRegImm reg off) code)
1365 getAmode (StPrim IntAddOp [x, y])
1366 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1367 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1368 getRegister x `thenNat` \ register1 ->
1369 getRegister y `thenNat` \ register2 ->
1371 code1 = registerCode register1 tmp1
1372 reg1 = registerName register1 tmp1
1373 code2 = registerCode register2 tmp2
1374 reg2 = registerName register2 tmp2
1375 code__2 = code1 `appOL` code2
1377 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1381 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1383 code = unitOL (SETHI (HI imm__2) tmp)
1385 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1388 imm__2 = case imm of Just x -> x
1391 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1392 getRegister other `thenNat` \ register ->
1394 code = registerCode register tmp
1395 reg = registerName register tmp
1398 returnNat (Amode (AddrRegImm reg off) code)
1400 #endif {- sparc_TARGET_ARCH -}
1403 %************************************************************************
1405 \subsection{The @CondCode@ type}
1407 %************************************************************************
1409 Condition codes passed up the tree.
1411 data CondCode = CondCode Bool Cond InstrBlock
1413 condName (CondCode _ cond _) = cond
1414 condFloat (CondCode is_float _ _) = is_float
1415 condCode (CondCode _ _ code) = code
1418 Set up a condition code for a conditional branch.
1421 getCondCode :: StixTree -> NatM CondCode
1423 #if alpha_TARGET_ARCH
1424 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1425 #endif {- alpha_TARGET_ARCH -}
1426 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1428 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1429 -- yes, they really do seem to want exactly the same!
1431 getCondCode (StPrim primop [x, y])
1433 CharGtOp -> condIntCode GTT x y
1434 CharGeOp -> condIntCode GE x y
1435 CharEqOp -> condIntCode EQQ x y
1436 CharNeOp -> condIntCode NE x y
1437 CharLtOp -> condIntCode LTT x y
1438 CharLeOp -> condIntCode LE x y
1440 IntGtOp -> condIntCode GTT x y
1441 IntGeOp -> condIntCode GE x y
1442 IntEqOp -> condIntCode EQQ x y
1443 IntNeOp -> condIntCode NE x y
1444 IntLtOp -> condIntCode LTT x y
1445 IntLeOp -> condIntCode LE x y
1447 WordGtOp -> condIntCode GU x y
1448 WordGeOp -> condIntCode GEU x y
1449 WordEqOp -> condIntCode EQQ x y
1450 WordNeOp -> condIntCode NE x y
1451 WordLtOp -> condIntCode LU x y
1452 WordLeOp -> condIntCode LEU x y
1454 AddrGtOp -> condIntCode GU x y
1455 AddrGeOp -> condIntCode GEU x y
1456 AddrEqOp -> condIntCode EQQ x y
1457 AddrNeOp -> condIntCode NE x y
1458 AddrLtOp -> condIntCode LU x y
1459 AddrLeOp -> condIntCode LEU x y
1461 FloatGtOp -> condFltCode GTT x y
1462 FloatGeOp -> condFltCode GE x y
1463 FloatEqOp -> condFltCode EQQ x y
1464 FloatNeOp -> condFltCode NE x y
1465 FloatLtOp -> condFltCode LTT x y
1466 FloatLeOp -> condFltCode LE x y
1468 DoubleGtOp -> condFltCode GTT x y
1469 DoubleGeOp -> condFltCode GE x y
1470 DoubleEqOp -> condFltCode EQQ x y
1471 DoubleNeOp -> condFltCode NE x y
1472 DoubleLtOp -> condFltCode LTT x y
1473 DoubleLeOp -> condFltCode LE x y
1475 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1480 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1481 passed back up the tree.
1484 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1486 #if alpha_TARGET_ARCH
1487 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1488 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1489 #endif {- alpha_TARGET_ARCH -}
1491 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1492 #if i386_TARGET_ARCH
1494 -- memory vs immediate
1495 condIntCode cond (StInd pk x) y
1497 = getAmode x `thenNat` \ amode ->
1499 code1 = amodeCode amode
1500 x__2 = amodeAddr amode
1501 sz = primRepToSize pk
1502 code__2 = code1 `snocOL`
1503 CMP sz (OpImm imm__2) (OpAddr x__2)
1505 returnNat (CondCode False cond code__2)
1508 imm__2 = case imm of Just x -> x
1511 condIntCode cond x (StInt 0)
1512 = getRegister x `thenNat` \ register1 ->
1513 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1515 code1 = registerCode register1 tmp1
1516 src1 = registerName register1 tmp1
1517 code__2 = code1 `snocOL`
1518 TEST L (OpReg src1) (OpReg src1)
1520 returnNat (CondCode False cond code__2)
1522 -- anything vs immediate
1523 condIntCode cond x y
1525 = getRegister x `thenNat` \ register1 ->
1526 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1528 code1 = registerCode register1 tmp1
1529 src1 = registerName register1 tmp1
1530 code__2 = code1 `snocOL`
1531 CMP L (OpImm imm__2) (OpReg src1)
1533 returnNat (CondCode False cond code__2)
1536 imm__2 = case imm of Just x -> x
1538 -- memory vs anything
1539 condIntCode cond (StInd pk x) y
1540 = getAmode x `thenNat` \ amode_x ->
1541 getRegister y `thenNat` \ reg_y ->
1542 getNewRegNCG IntRep `thenNat` \ tmp ->
1544 c_x = amodeCode amode_x
1545 am_x = amodeAddr amode_x
1546 c_y = registerCode reg_y tmp
1547 r_y = registerName reg_y tmp
1548 sz = primRepToSize pk
1550 -- optimisation: if there's no code for x, just an amode,
1551 -- use whatever reg y winds up in. Assumes that c_y doesn't
1552 -- clobber any regs in the amode am_x, which I'm not sure is
1553 -- justified. The otherwise clause makes the same assumption.
1554 code__2 | isNilOL c_x
1556 CMP sz (OpReg r_y) (OpAddr am_x)
1560 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1562 CMP sz (OpReg tmp) (OpAddr am_x)
1564 returnNat (CondCode False cond code__2)
1566 -- anything vs memory
1568 condIntCode cond y (StInd pk x)
1569 = getAmode x `thenNat` \ amode_x ->
1570 getRegister y `thenNat` \ reg_y ->
1571 getNewRegNCG IntRep `thenNat` \ tmp ->
1573 c_x = amodeCode amode_x
1574 am_x = amodeAddr amode_x
1575 c_y = registerCode reg_y tmp
1576 r_y = registerName reg_y tmp
1577 sz = primRepToSize pk
1578 -- same optimisation and nagging doubts as previous clause
1579 code__2 | isNilOL c_x
1581 CMP sz (OpAddr am_x) (OpReg r_y)
1585 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1587 CMP sz (OpAddr am_x) (OpReg tmp)
1589 returnNat (CondCode False cond code__2)
1591 -- anything vs anything
1592 condIntCode cond x y
1593 = getRegister x `thenNat` \ register1 ->
1594 getRegister y `thenNat` \ register2 ->
1595 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1596 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1598 code1 = registerCode register1 tmp1
1599 src1 = registerName register1 tmp1
1600 code2 = registerCode register2 tmp2
1601 src2 = registerName register2 tmp2
1602 code__2 = code1 `snocOL`
1603 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1605 CMP L (OpReg src2) (OpReg tmp1)
1607 returnNat (CondCode False cond code__2)
1610 condFltCode cond x y
1611 = getRegister x `thenNat` \ register1 ->
1612 getRegister y `thenNat` \ register2 ->
1613 getNewRegNCG (registerRep register1)
1615 getNewRegNCG (registerRep register2)
1617 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1619 pk1 = registerRep register1
1620 code1 = registerCode register1 tmp1
1621 src1 = registerName register1 tmp1
1623 code2 = registerCode register2 tmp2
1624 src2 = registerName register2 tmp2
1626 code__2 | isAny register1
1627 = code1 `appOL` -- result in tmp1
1629 GCMP (primRepToSize pk1) tmp1 src2
1633 GMOV src1 tmp1 `appOL`
1635 GCMP (primRepToSize pk1) tmp1 src2
1637 {- On the 486, the flags set by FP compare are the unsigned ones!
1638 (This looks like a HACK to me. WDP 96/03)
1640 fix_FP_cond :: Cond -> Cond
1642 fix_FP_cond GE = GEU
1643 fix_FP_cond GTT = GU
1644 fix_FP_cond LTT = LU
1645 fix_FP_cond LE = LEU
1646 fix_FP_cond any = any
1648 returnNat (CondCode True (fix_FP_cond cond) code__2)
1652 #endif {- i386_TARGET_ARCH -}
1653 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1654 #if sparc_TARGET_ARCH
1656 condIntCode cond x (StInt y)
1658 = getRegister x `thenNat` \ register ->
1659 getNewRegNCG IntRep `thenNat` \ tmp ->
1661 code = registerCode register tmp
1662 src1 = registerName register tmp
1663 src2 = ImmInt (fromInteger y)
1664 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1666 returnNat (CondCode False cond code__2)
1668 condIntCode cond x y
1669 = getRegister x `thenNat` \ register1 ->
1670 getRegister y `thenNat` \ register2 ->
1671 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1672 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1674 code1 = registerCode register1 tmp1
1675 src1 = registerName register1 tmp1
1676 code2 = registerCode register2 tmp2
1677 src2 = registerName register2 tmp2
1678 code__2 = code1 `appOL` code2 `snocOL`
1679 SUB False True src1 (RIReg src2) g0
1681 returnNat (CondCode False cond code__2)
1684 condFltCode cond x y
1685 = getRegister x `thenNat` \ register1 ->
1686 getRegister y `thenNat` \ register2 ->
1687 getNewRegNCG (registerRep register1)
1689 getNewRegNCG (registerRep register2)
1691 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1693 promote x = FxTOy F DF x tmp
1695 pk1 = registerRep register1
1696 code1 = registerCode register1 tmp1
1697 src1 = registerName register1 tmp1
1699 pk2 = registerRep register2
1700 code2 = registerCode register2 tmp2
1701 src2 = registerName register2 tmp2
1705 code1 `appOL` code2 `snocOL`
1706 FCMP True (primRepToSize pk1) src1 src2
1707 else if pk1 == FloatRep then
1708 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1709 FCMP True DF tmp src2
1711 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1712 FCMP True DF src1 tmp
1714 returnNat (CondCode True cond code__2)
1716 #endif {- sparc_TARGET_ARCH -}
1719 %************************************************************************
1721 \subsection{Generating assignments}
1723 %************************************************************************
1725 Assignments are really at the heart of the whole code generation
1726 business. Almost all top-level nodes of any real importance are
1727 assignments, which correspond to loads, stores, or register transfers.
1728 If we're really lucky, some of the register transfers will go away,
1729 because we can use the destination register to complete the code
1730 generation for the right hand side. This only fails when the right
1731 hand side is forced into a fixed register (e.g. the result of a call).
1734 assignIntCode, assignFltCode
1735 :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1737 #if alpha_TARGET_ARCH
1739 assignIntCode pk (StInd _ dst) src
1740 = getNewRegNCG IntRep `thenNat` \ tmp ->
1741 getAmode dst `thenNat` \ amode ->
1742 getRegister src `thenNat` \ register ->
1744 code1 = amodeCode amode []
1745 dst__2 = amodeAddr amode
1746 code2 = registerCode register tmp []
1747 src__2 = registerName register tmp
1748 sz = primRepToSize pk
1749 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1753 assignIntCode pk dst src
1754 = getRegister dst `thenNat` \ register1 ->
1755 getRegister src `thenNat` \ register2 ->
1757 dst__2 = registerName register1 zeroh
1758 code = registerCode register2 dst__2
1759 src__2 = registerName register2 dst__2
1760 code__2 = if isFixed register2
1761 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1766 #endif {- alpha_TARGET_ARCH -}
1767 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1768 #if i386_TARGET_ARCH
1770 -- Destination of an assignment can only be reg or mem.
1771 -- This is the mem case.
1772 assignIntCode pk (StInd _ dst) src
1773 = getAmode dst `thenNat` \ amode ->
1774 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
1775 getNewRegNCG PtrRep `thenNat` \ tmp ->
1777 -- In general, if the address computation for dst may require
1778 -- some insns preceding the addressing mode itself. So there's
1779 -- no guarantee that the code for dst and the code for src won't
1780 -- write the same register. This means either the address or
1781 -- the value needs to be copied into a temporary. We detect the
1782 -- common case where the amode has no code, and elide the copy.
1783 codea = amodeCode amode
1784 dst__a = amodeAddr amode
1786 code | isNilOL codea
1788 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1792 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1794 MOV (primRepToSize pk) opsrc
1795 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1801 -> NatM (InstrBlock,Operand) -- code, operator
1805 = returnNat (nilOL, OpImm imm_op)
1808 imm_op = case imm of Just x -> x
1811 = getRegister op `thenNat` \ register ->
1812 getNewRegNCG (registerRep register)
1814 let code = registerCode register tmp
1815 reg = registerName register tmp
1817 returnNat (code, OpReg reg)
1819 -- Assign; dst is a reg, rhs is mem
1820 assignIntCode pk dst (StInd pks src)
1821 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1822 getAmode src `thenNat` \ amode ->
1823 getRegister dst `thenNat` \ reg_dst ->
1825 c_addr = amodeCode amode
1826 am_addr = amodeAddr amode
1828 c_dst = registerCode reg_dst tmp -- should be empty
1829 r_dst = registerName reg_dst tmp
1830 szs = primRepToSize pks
1839 code | isNilOL c_dst
1841 opc (OpAddr am_addr) (OpReg r_dst)
1843 = pprPanic "assignIntCode(x86): bad dst(2)" empty
1847 -- dst is a reg, but src could be anything
1848 assignIntCode pk dst src
1849 = getRegister dst `thenNat` \ registerd ->
1850 getRegister src `thenNat` \ registers ->
1851 getNewRegNCG IntRep `thenNat` \ tmp ->
1853 r_dst = registerName registerd tmp
1854 c_dst = registerCode registerd tmp -- should be empty
1855 r_src = registerName registers r_dst
1856 c_src = registerCode registers r_dst
1858 code | isNilOL c_dst
1860 MOV L (OpReg r_src) (OpReg r_dst)
1862 = pprPanic "assignIntCode(x86): bad dst(3)" empty
1866 #endif {- i386_TARGET_ARCH -}
1867 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1868 #if sparc_TARGET_ARCH
1870 assignIntCode pk (StInd _ dst) src
1871 = getNewRegNCG IntRep `thenNat` \ tmp ->
1872 getAmode dst `thenNat` \ amode ->
1873 getRegister src `thenNat` \ register ->
1875 code1 = amodeCode amode
1876 dst__2 = amodeAddr amode
1877 code2 = registerCode register tmp
1878 src__2 = registerName register tmp
1879 sz = primRepToSize pk
1880 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
1884 assignIntCode pk dst src
1885 = getRegister dst `thenNat` \ register1 ->
1886 getRegister src `thenNat` \ register2 ->
1888 dst__2 = registerName register1 g0
1889 code = registerCode register2 dst__2
1890 src__2 = registerName register2 dst__2
1891 code__2 = if isFixed register2
1892 then code `snocOL` OR False g0 (RIReg src__2) dst__2
1897 #endif {- sparc_TARGET_ARCH -}
1900 % --------------------------------
1901 Floating-point assignments:
1902 % --------------------------------
1904 #if alpha_TARGET_ARCH
1906 assignFltCode pk (StInd _ dst) src
1907 = getNewRegNCG pk `thenNat` \ tmp ->
1908 getAmode dst `thenNat` \ amode ->
1909 getRegister src `thenNat` \ register ->
1911 code1 = amodeCode amode []
1912 dst__2 = amodeAddr amode
1913 code2 = registerCode register tmp []
1914 src__2 = registerName register tmp
1915 sz = primRepToSize pk
1916 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1920 assignFltCode pk dst src
1921 = getRegister dst `thenNat` \ register1 ->
1922 getRegister src `thenNat` \ register2 ->
1924 dst__2 = registerName register1 zeroh
1925 code = registerCode register2 dst__2
1926 src__2 = registerName register2 dst__2
1927 code__2 = if isFixed register2
1928 then code . mkSeqInstr (FMOV src__2 dst__2)
1933 #endif {- alpha_TARGET_ARCH -}
1934 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1935 #if i386_TARGET_ARCH
1938 assignFltCode pk (StInd pk_dst addr) src
1940 = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
1942 = getRegister src `thenNat` \ reg_src ->
1943 getRegister addr `thenNat` \ reg_addr ->
1944 getNewRegNCG pk `thenNat` \ tmp_src ->
1945 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
1946 let r_src = registerName reg_src tmp_src
1947 c_src = registerCode reg_src tmp_src
1948 r_addr = registerName reg_addr tmp_addr
1949 c_addr = registerCode reg_addr tmp_addr
1950 sz = primRepToSize pk
1952 code = c_src `appOL`
1953 -- no need to preserve r_src across the addr computation,
1954 -- since r_src must be a float reg
1955 -- whilst r_addr is an int reg
1958 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1962 -- dst must be a (FP) register
1963 assignFltCode pk dst src
1964 = getRegister dst `thenNat` \ reg_dst ->
1965 getRegister src `thenNat` \ reg_src ->
1966 getNewRegNCG pk `thenNat` \ tmp ->
1968 r_dst = registerName reg_dst tmp
1969 c_dst = registerCode reg_dst tmp -- should be empty
1971 r_src = registerName reg_src r_dst
1972 c_src = registerCode reg_src r_dst
1974 code | isNilOL c_dst
1975 = if isFixed reg_src
1976 then c_src `snocOL` GMOV r_src r_dst
1979 = pprPanic "assignFltCode(x86): lhs is not mem or reg"
1985 #endif {- i386_TARGET_ARCH -}
1986 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1987 #if sparc_TARGET_ARCH
1989 assignFltCode pk (StInd _ dst) src
1990 = getNewRegNCG pk `thenNat` \ tmp1 ->
1991 getAmode dst `thenNat` \ amode ->
1992 getRegister src `thenNat` \ register ->
1994 sz = primRepToSize pk
1995 dst__2 = amodeAddr amode
1997 code1 = amodeCode amode
1998 code2 = registerCode register tmp1
2000 src__2 = registerName register tmp1
2001 pk__2 = registerRep register
2002 sz__2 = primRepToSize pk__2
2004 code__2 = code1 `appOL` code2 `appOL`
2006 then unitOL (ST sz src__2 dst__2)
2007 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2011 assignFltCode pk dst src
2012 = getRegister dst `thenNat` \ register1 ->
2013 getRegister src `thenNat` \ register2 ->
2015 pk__2 = registerRep register2
2016 sz__2 = primRepToSize pk__2
2018 getNewRegNCG pk__2 `thenNat` \ tmp ->
2020 sz = primRepToSize pk
2021 dst__2 = registerName register1 g0 -- must be Fixed
2024 reg__2 = if pk /= pk__2 then tmp else dst__2
2026 code = registerCode register2 reg__2
2028 src__2 = registerName register2 reg__2
2032 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2033 else if isFixed register2 then
2034 code `snocOL` FMOV sz src__2 dst__2
2040 #endif {- sparc_TARGET_ARCH -}
2043 %************************************************************************
2045 \subsection{Generating an unconditional branch}
2047 %************************************************************************
2049 We accept two types of targets: an immediate CLabel or a tree that
2050 gets evaluated into a register. Any CLabels which are AsmTemporaries
2051 are assumed to be in the local block of code, close enough for a
2052 branch instruction. Other CLabels are assumed to be far away.
2054 (If applicable) Do not fill the delay slots here; you will confuse the
2058 genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
2060 #if alpha_TARGET_ARCH
2062 genJump (StCLbl lbl)
2063 | isAsmTemp lbl = returnInstr (BR target)
2064 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2066 target = ImmCLbl lbl
2069 = getRegister tree `thenNat` \ register ->
2070 getNewRegNCG PtrRep `thenNat` \ tmp ->
2072 dst = registerName register pv
2073 code = registerCode register pv
2074 target = registerName register pv
2076 if isFixed register then
2077 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2079 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2081 #endif {- alpha_TARGET_ARCH -}
2082 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2083 #if i386_TARGET_ARCH
2085 genJump dsts (StInd pk mem)
2086 = getAmode mem `thenNat` \ amode ->
2088 code = amodeCode amode
2089 target = amodeAddr amode
2091 returnNat (code `snocOL` JMP dsts (OpAddr target))
2095 = returnNat (unitOL (JMP dsts (OpImm target)))
2098 = getRegister tree `thenNat` \ register ->
2099 getNewRegNCG PtrRep `thenNat` \ tmp ->
2101 code = registerCode register tmp
2102 target = registerName register tmp
2104 returnNat (code `snocOL` JMP dsts (OpReg target))
2107 target = case imm of Just x -> x
2109 #endif {- i386_TARGET_ARCH -}
2110 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2111 #if sparc_TARGET_ARCH
2113 genJump dsts (StCLbl lbl)
2114 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2115 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2116 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2118 target = ImmCLbl lbl
2121 = getRegister tree `thenNat` \ register ->
2122 getNewRegNCG PtrRep `thenNat` \ tmp ->
2124 code = registerCode register tmp
2125 target = registerName register tmp
2127 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2129 #endif {- sparc_TARGET_ARCH -}
2132 %************************************************************************
2134 \subsection{Conditional jumps}
2136 %************************************************************************
2138 Conditional jumps are always to local labels, so we can use branch
2139 instructions. We peek at the arguments to decide what kind of
2142 ALPHA: For comparisons with 0, we're laughing, because we can just do
2143 the desired conditional branch.
2145 I386: First, we have to ensure that the condition
2146 codes are set according to the supplied comparison operation.
2148 SPARC: First, we have to ensure that the condition codes are set
2149 according to the supplied comparison operation. We generate slightly
2150 different code for floating point comparisons, because a floating
2151 point operation cannot directly precede a @BF@. We assume the worst
2152 and fill that slot with a @NOP@.
2154 SPARC: Do not fill the delay slots here; you will confuse the register
2159 :: CLabel -- the branch target
2160 -> StixTree -- the condition on which to branch
2163 #if alpha_TARGET_ARCH
2165 genCondJump lbl (StPrim op [x, StInt 0])
2166 = getRegister x `thenNat` \ register ->
2167 getNewRegNCG (registerRep register)
2170 code = registerCode register tmp
2171 value = registerName register tmp
2172 pk = registerRep register
2173 target = ImmCLbl lbl
2175 returnSeq code [BI (cmpOp op) value target]
2177 cmpOp CharGtOp = GTT
2179 cmpOp CharEqOp = EQQ
2181 cmpOp CharLtOp = LTT
2190 cmpOp WordGeOp = ALWAYS
2191 cmpOp WordEqOp = EQQ
2193 cmpOp WordLtOp = NEVER
2194 cmpOp WordLeOp = EQQ
2196 cmpOp AddrGeOp = ALWAYS
2197 cmpOp AddrEqOp = EQQ
2199 cmpOp AddrLtOp = NEVER
2200 cmpOp AddrLeOp = EQQ
2202 genCondJump lbl (StPrim op [x, StDouble 0.0])
2203 = getRegister x `thenNat` \ register ->
2204 getNewRegNCG (registerRep register)
2207 code = registerCode register tmp
2208 value = registerName register tmp
2209 pk = registerRep register
2210 target = ImmCLbl lbl
2212 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2214 cmpOp FloatGtOp = GTT
2215 cmpOp FloatGeOp = GE
2216 cmpOp FloatEqOp = EQQ
2217 cmpOp FloatNeOp = NE
2218 cmpOp FloatLtOp = LTT
2219 cmpOp FloatLeOp = LE
2220 cmpOp DoubleGtOp = GTT
2221 cmpOp DoubleGeOp = GE
2222 cmpOp DoubleEqOp = EQQ
2223 cmpOp DoubleNeOp = NE
2224 cmpOp DoubleLtOp = LTT
2225 cmpOp DoubleLeOp = LE
2227 genCondJump lbl (StPrim op [x, y])
2229 = trivialFCode pr instr x y `thenNat` \ register ->
2230 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2232 code = registerCode register tmp
2233 result = registerName register tmp
2234 target = ImmCLbl lbl
2236 returnNat (code . mkSeqInstr (BF cond result target))
2238 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2240 fltCmpOp op = case op of
2254 (instr, cond) = case op of
2255 FloatGtOp -> (FCMP TF LE, EQQ)
2256 FloatGeOp -> (FCMP TF LTT, EQQ)
2257 FloatEqOp -> (FCMP TF EQQ, NE)
2258 FloatNeOp -> (FCMP TF EQQ, EQQ)
2259 FloatLtOp -> (FCMP TF LTT, NE)
2260 FloatLeOp -> (FCMP TF LE, NE)
2261 DoubleGtOp -> (FCMP TF LE, EQQ)
2262 DoubleGeOp -> (FCMP TF LTT, EQQ)
2263 DoubleEqOp -> (FCMP TF EQQ, NE)
2264 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2265 DoubleLtOp -> (FCMP TF LTT, NE)
2266 DoubleLeOp -> (FCMP TF LE, NE)
2268 genCondJump lbl (StPrim op [x, y])
2269 = trivialCode instr x y `thenNat` \ register ->
2270 getNewRegNCG IntRep `thenNat` \ tmp ->
2272 code = registerCode register tmp
2273 result = registerName register tmp
2274 target = ImmCLbl lbl
2276 returnNat (code . mkSeqInstr (BI cond result target))
2278 (instr, cond) = case op of
2279 CharGtOp -> (CMP LE, EQQ)
2280 CharGeOp -> (CMP LTT, EQQ)
2281 CharEqOp -> (CMP EQQ, NE)
2282 CharNeOp -> (CMP EQQ, EQQ)
2283 CharLtOp -> (CMP LTT, NE)
2284 CharLeOp -> (CMP LE, NE)
2285 IntGtOp -> (CMP LE, EQQ)
2286 IntGeOp -> (CMP LTT, EQQ)
2287 IntEqOp -> (CMP EQQ, NE)
2288 IntNeOp -> (CMP EQQ, EQQ)
2289 IntLtOp -> (CMP LTT, NE)
2290 IntLeOp -> (CMP LE, NE)
2291 WordGtOp -> (CMP ULE, EQQ)
2292 WordGeOp -> (CMP ULT, EQQ)
2293 WordEqOp -> (CMP EQQ, NE)
2294 WordNeOp -> (CMP EQQ, EQQ)
2295 WordLtOp -> (CMP ULT, NE)
2296 WordLeOp -> (CMP ULE, NE)
2297 AddrGtOp -> (CMP ULE, EQQ)
2298 AddrGeOp -> (CMP ULT, EQQ)
2299 AddrEqOp -> (CMP EQQ, NE)
2300 AddrNeOp -> (CMP EQQ, EQQ)
2301 AddrLtOp -> (CMP ULT, NE)
2302 AddrLeOp -> (CMP ULE, NE)
2304 #endif {- alpha_TARGET_ARCH -}
2305 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2306 #if i386_TARGET_ARCH
2308 genCondJump lbl bool
2309 = getCondCode bool `thenNat` \ condition ->
2311 code = condCode condition
2312 cond = condName condition
2314 returnNat (code `snocOL` JXX cond lbl)
2316 #endif {- i386_TARGET_ARCH -}
2317 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2318 #if sparc_TARGET_ARCH
2320 genCondJump lbl bool
2321 = getCondCode bool `thenNat` \ condition ->
2323 code = condCode condition
2324 cond = condName condition
2325 target = ImmCLbl lbl
2330 if condFloat condition
2331 then [NOP, BF cond False target, NOP]
2332 else [BI cond False target, NOP]
2336 #endif {- sparc_TARGET_ARCH -}
2339 %************************************************************************
2341 \subsection{Generating C calls}
2343 %************************************************************************
2345 Now the biggest nightmare---calls. Most of the nastiness is buried in
2346 @get_arg@, which moves the arguments to the correct registers/stack
2347 locations. Apart from that, the code is easy.
2349 (If applicable) Do not fill the delay slots here; you will confuse the
2354 :: FAST_STRING -- function to call
2356 -> PrimRep -- type of the result
2357 -> [StixTree] -- arguments (of mixed type)
2360 #if alpha_TARGET_ARCH
2362 genCCall fn cconv kind args
2363 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2364 `thenNat` \ ((unused,_), argCode) ->
2366 nRegs = length allArgRegs - length unused
2367 code = asmSeqThen (map ($ []) argCode)
2370 LDA pv (AddrImm (ImmLab (ptext fn))),
2371 JSR ra (AddrReg pv) nRegs,
2372 LDGP gp (AddrReg ra)]
2374 ------------------------
2375 {- Try to get a value into a specific register (or registers) for
2376 a call. The first 6 arguments go into the appropriate
2377 argument register (separate registers for integer and floating
2378 point arguments, but used in lock-step), and the remaining
2379 arguments are dumped to the stack, beginning at 0(sp). Our
2380 first argument is a pair of the list of remaining argument
2381 registers to be assigned for this call and the next stack
2382 offset to use for overflowing arguments. This way,
2383 @get_Arg@ can be applied to all of a call's arguments using
2387 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2388 -> StixTree -- Current argument
2389 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2391 -- We have to use up all of our argument registers first...
2393 get_arg ((iDst,fDst):dsts, offset) arg
2394 = getRegister arg `thenNat` \ register ->
2396 reg = if isFloatingRep pk then fDst else iDst
2397 code = registerCode register reg
2398 src = registerName register reg
2399 pk = registerRep register
2402 if isFloatingRep pk then
2403 ((dsts, offset), if isFixed register then
2404 code . mkSeqInstr (FMOV src fDst)
2407 ((dsts, offset), if isFixed register then
2408 code . mkSeqInstr (OR src (RIReg src) iDst)
2411 -- Once we have run out of argument registers, we move to the
2414 get_arg ([], offset) arg
2415 = getRegister arg `thenNat` \ register ->
2416 getNewRegNCG (registerRep register)
2419 code = registerCode register tmp
2420 src = registerName register tmp
2421 pk = registerRep register
2422 sz = primRepToSize pk
2424 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2426 #endif {- alpha_TARGET_ARCH -}
2427 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2428 #if i386_TARGET_ARCH
2430 genCCall fn cconv kind [StInt i]
2431 | fn == SLIT ("PerformGC_wrapper")
2433 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2434 CALL (ImmLit (ptext (if underscorePrefix
2435 then (SLIT ("_PerformGC_wrapper"))
2436 else (SLIT ("PerformGC_wrapper")))))
2442 genCCall fn cconv kind args
2443 = mapNat get_call_arg
2444 (reverse args) `thenNat` \ sizes_n_codes ->
2445 getDeltaNat `thenNat` \ delta ->
2446 let (sizes, codes) = unzip sizes_n_codes
2447 tot_arg_size = sum sizes
2448 code2 = concatOL codes
2450 [CALL (fn__2 tot_arg_size)]
2452 (if cconv == stdCallConv then [] else
2453 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2455 [DELTA (delta + tot_arg_size)]
2458 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2459 returnNat (code2 `appOL` call)
2462 -- function names that begin with '.' are assumed to be special
2463 -- internally generated names like '.mul,' which don't get an
2464 -- underscore prefix
2465 -- ToDo:needed (WDP 96/03) ???
2469 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2471 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2473 stdcallsize tot_arg_size
2474 | cconv == stdCallConv = '@':show tot_arg_size
2482 get_call_arg :: StixTree{-current argument-}
2483 -> NatM (Int, InstrBlock) -- argsz, code
2486 = get_op arg `thenNat` \ (code, reg, sz) ->
2487 getDeltaNat `thenNat` \ delta ->
2488 arg_size sz `bind` \ size ->
2489 setDeltaNat (delta-size) `thenNat` \ _ ->
2490 if (case sz of DF -> True; F -> True; _ -> False)
2491 then returnNat (size,
2493 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2495 GST sz reg (AddrBaseIndex (Just esp)
2499 else returnNat (size,
2501 PUSH L (OpReg reg) `snocOL`
2507 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2510 = getRegister op `thenNat` \ register ->
2511 getNewRegNCG (registerRep register)
2514 code = registerCode register tmp
2515 reg = registerName register tmp
2516 pk = registerRep register
2517 sz = primRepToSize pk
2519 returnNat (code, reg, sz)
2521 #endif {- i386_TARGET_ARCH -}
2522 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2523 #if sparc_TARGET_ARCH
2525 The SPARC calling convention is an absolute
2526 nightmare. The first 6x32 bits of arguments are mapped into
2527 %o0 through %o5, and the remaining arguments are dumped to the
2528 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2530 If we have to put args on the stack, move %o6==%sp down by
2531 the number of words to go on the stack, to ensure there's enough space.
2533 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2534 16 words above the stack pointer is a word for the address of
2535 a structure return value. I use this as a temporary location
2536 for moving values from float to int regs. Certainly it isn't
2537 safe to put anything in the 16 words starting at %sp, since
2538 this area can get trashed at any time due to window overflows
2539 caused by signal handlers.
2541 A final complication (if the above isn't enough) is that
2542 we can't blithely calculate the arguments one by one into
2543 %o0 .. %o5. Consider the following nested calls:
2547 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2548 the inner call will itself use %o0, which trashes the value put there
2549 in preparation for the outer call. Upshot: we need to calculate the
2550 args into temporary regs, and move those to arg regs or onto the
2551 stack only immediately prior to the call proper. Sigh.
2554 genCCall fn cconv kind args
2555 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2556 let (argcodes, vregss) = unzip argcode_and_vregs
2557 argcode = concatOL argcodes
2558 vregs = concat vregss
2559 n_argRegs = length allArgRegs
2560 n_argRegs_used = min (length vregs) n_argRegs
2561 (move_sp_down, move_sp_up)
2562 = let nn = length vregs - n_argRegs
2563 + 1 -- (for the road)
2566 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2568 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2570 = unitOL (CALL fn__2 n_argRegs_used False)
2572 returnNat (argcode `appOL`
2573 move_sp_down `appOL`
2574 transfer_code `appOL`
2579 -- function names that begin with '.' are assumed to be special
2580 -- internally generated names like '.mul,' which don't get an
2581 -- underscore prefix
2582 -- ToDo:needed (WDP 96/03) ???
2583 fn__2 = case (_HEAD_ fn) of
2584 '.' -> ImmLit (ptext fn)
2585 _ -> ImmLab False (ptext fn)
2587 -- move args from the integer vregs into which they have been
2588 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2589 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2591 move_final [] _ offset -- all args done
2594 move_final (v:vs) [] offset -- out of aregs; move to stack
2595 = ST W v (spRel offset)
2596 : move_final vs [] (offset+1)
2598 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2599 = OR False g0 (RIReg v) a
2600 : move_final vs az offset
2602 -- generate code to calculate an argument, and move it into one
2603 -- or two integer vregs.
2604 arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
2605 arg_to_int_vregs arg
2606 = getRegister arg `thenNat` \ register ->
2607 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2608 let code = registerCode register tmp
2609 src = registerName register tmp
2610 pk = registerRep register
2612 -- the value is in src. Get it into 1 or 2 int vregs.
2615 getNewRegNCG WordRep `thenNat` \ v1 ->
2616 getNewRegNCG WordRep `thenNat` \ v2 ->
2619 FMOV DF src f0 `snocOL`
2620 ST F f0 (spRel 16) `snocOL`
2621 LD W (spRel 16) v1 `snocOL`
2622 ST F (fPair f0) (spRel 16) `snocOL`
2628 getNewRegNCG WordRep `thenNat` \ v1 ->
2631 ST F src (spRel 16) `snocOL`
2637 getNewRegNCG WordRep `thenNat` \ v1 ->
2639 code `snocOL` OR False g0 (RIReg src) v1
2643 #endif {- sparc_TARGET_ARCH -}
2646 %************************************************************************
2648 \subsection{Support bits}
2650 %************************************************************************
2652 %************************************************************************
2654 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2656 %************************************************************************
2658 Turn those condition codes into integers now (when they appear on
2659 the right hand side of an assignment).
2661 (If applicable) Do not fill the delay slots here; you will confuse the
2665 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2667 #if alpha_TARGET_ARCH
2668 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2669 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2670 #endif {- alpha_TARGET_ARCH -}
2672 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2673 #if i386_TARGET_ARCH
2676 = condIntCode cond x y `thenNat` \ condition ->
2677 getNewRegNCG IntRep `thenNat` \ tmp ->
2679 code = condCode condition
2680 cond = condName condition
2681 code__2 dst = code `appOL` toOL [
2682 SETCC cond (OpReg tmp),
2683 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2684 MOV L (OpReg tmp) (OpReg dst)]
2686 returnNat (Any IntRep code__2)
2689 = getNatLabelNCG `thenNat` \ lbl1 ->
2690 getNatLabelNCG `thenNat` \ lbl2 ->
2691 condFltCode cond x y `thenNat` \ condition ->
2693 code = condCode condition
2694 cond = condName condition
2695 code__2 dst = code `appOL` toOL [
2697 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2700 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2703 returnNat (Any IntRep code__2)
2705 #endif {- i386_TARGET_ARCH -}
2706 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2707 #if sparc_TARGET_ARCH
2709 condIntReg EQQ x (StInt 0)
2710 = getRegister x `thenNat` \ register ->
2711 getNewRegNCG IntRep `thenNat` \ tmp ->
2713 code = registerCode register tmp
2714 src = registerName register tmp
2715 code__2 dst = code `appOL` toOL [
2716 SUB False True g0 (RIReg src) g0,
2717 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2719 returnNat (Any IntRep code__2)
2722 = getRegister x `thenNat` \ register1 ->
2723 getRegister y `thenNat` \ register2 ->
2724 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2725 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2727 code1 = registerCode register1 tmp1
2728 src1 = registerName register1 tmp1
2729 code2 = registerCode register2 tmp2
2730 src2 = registerName register2 tmp2
2731 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2732 XOR False src1 (RIReg src2) dst,
2733 SUB False True g0 (RIReg dst) g0,
2734 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2736 returnNat (Any IntRep code__2)
2738 condIntReg NE x (StInt 0)
2739 = getRegister x `thenNat` \ register ->
2740 getNewRegNCG IntRep `thenNat` \ tmp ->
2742 code = registerCode register tmp
2743 src = registerName register tmp
2744 code__2 dst = code `appOL` toOL [
2745 SUB False True g0 (RIReg src) g0,
2746 ADD True False g0 (RIImm (ImmInt 0)) dst]
2748 returnNat (Any IntRep code__2)
2751 = getRegister x `thenNat` \ register1 ->
2752 getRegister y `thenNat` \ register2 ->
2753 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2754 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2756 code1 = registerCode register1 tmp1
2757 src1 = registerName register1 tmp1
2758 code2 = registerCode register2 tmp2
2759 src2 = registerName register2 tmp2
2760 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2761 XOR False src1 (RIReg src2) dst,
2762 SUB False True g0 (RIReg dst) g0,
2763 ADD True False g0 (RIImm (ImmInt 0)) dst]
2765 returnNat (Any IntRep code__2)
2768 = getNatLabelNCG `thenNat` \ lbl1 ->
2769 getNatLabelNCG `thenNat` \ lbl2 ->
2770 condIntCode cond x y `thenNat` \ condition ->
2772 code = condCode condition
2773 cond = condName condition
2774 code__2 dst = code `appOL` toOL [
2775 BI cond False (ImmCLbl lbl1), NOP,
2776 OR False g0 (RIImm (ImmInt 0)) dst,
2777 BI ALWAYS False (ImmCLbl lbl2), NOP,
2779 OR False g0 (RIImm (ImmInt 1)) dst,
2782 returnNat (Any IntRep code__2)
2785 = getNatLabelNCG `thenNat` \ lbl1 ->
2786 getNatLabelNCG `thenNat` \ lbl2 ->
2787 condFltCode cond x y `thenNat` \ condition ->
2789 code = condCode condition
2790 cond = condName condition
2791 code__2 dst = code `appOL` toOL [
2793 BF cond False (ImmCLbl lbl1), NOP,
2794 OR False g0 (RIImm (ImmInt 0)) dst,
2795 BI ALWAYS False (ImmCLbl lbl2), NOP,
2797 OR False g0 (RIImm (ImmInt 1)) dst,
2800 returnNat (Any IntRep code__2)
2802 #endif {- sparc_TARGET_ARCH -}
2805 %************************************************************************
2807 \subsubsection{@trivial*Code@: deal with trivial instructions}
2809 %************************************************************************
2811 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2812 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2813 for constants on the right hand side, because that's where the generic
2814 optimizer will have put them.
2816 Similarly, for unary instructions, we don't have to worry about
2817 matching an StInt as the argument, because genericOpt will already
2818 have handled the constant-folding.
2822 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2823 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2824 -> Maybe (Operand -> Operand -> Instr)
2825 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2827 -> StixTree -> StixTree -- the two arguments
2832 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2833 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2834 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2836 -> StixTree -> StixTree -- the two arguments
2840 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2841 ,IF_ARCH_i386 ((Operand -> Instr)
2842 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2844 -> StixTree -- the one argument
2849 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2850 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2851 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2853 -> StixTree -- the one argument
2856 #if alpha_TARGET_ARCH
2858 trivialCode instr x (StInt y)
2860 = getRegister x `thenNat` \ register ->
2861 getNewRegNCG IntRep `thenNat` \ tmp ->
2863 code = registerCode register tmp
2864 src1 = registerName register tmp
2865 src2 = ImmInt (fromInteger y)
2866 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2868 returnNat (Any IntRep code__2)
2870 trivialCode instr x y
2871 = getRegister x `thenNat` \ register1 ->
2872 getRegister y `thenNat` \ register2 ->
2873 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2874 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2876 code1 = registerCode register1 tmp1 []
2877 src1 = registerName register1 tmp1
2878 code2 = registerCode register2 tmp2 []
2879 src2 = registerName register2 tmp2
2880 code__2 dst = asmSeqThen [code1, code2] .
2881 mkSeqInstr (instr src1 (RIReg src2) dst)
2883 returnNat (Any IntRep code__2)
2886 trivialUCode instr x
2887 = getRegister x `thenNat` \ register ->
2888 getNewRegNCG IntRep `thenNat` \ tmp ->
2890 code = registerCode register tmp
2891 src = registerName register tmp
2892 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2894 returnNat (Any IntRep code__2)
2897 trivialFCode _ instr x y
2898 = getRegister x `thenNat` \ register1 ->
2899 getRegister y `thenNat` \ register2 ->
2900 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2901 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2903 code1 = registerCode register1 tmp1
2904 src1 = registerName register1 tmp1
2906 code2 = registerCode register2 tmp2
2907 src2 = registerName register2 tmp2
2909 code__2 dst = asmSeqThen [code1 [], code2 []] .
2910 mkSeqInstr (instr src1 src2 dst)
2912 returnNat (Any DoubleRep code__2)
2914 trivialUFCode _ instr x
2915 = getRegister x `thenNat` \ register ->
2916 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2918 code = registerCode register tmp
2919 src = registerName register tmp
2920 code__2 dst = code . mkSeqInstr (instr src dst)
2922 returnNat (Any DoubleRep code__2)
2924 #endif {- alpha_TARGET_ARCH -}
2925 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2926 #if i386_TARGET_ARCH
2928 The Rules of the Game are:
2930 * You cannot assume anything about the destination register dst;
2931 it may be anything, including a fixed reg.
2933 * You may compute an operand into a fixed reg, but you may not
2934 subsequently change the contents of that fixed reg. If you
2935 want to do so, first copy the value either to a temporary
2936 or into dst. You are free to modify dst even if it happens
2937 to be a fixed reg -- that's not your problem.
2939 * You cannot assume that a fixed reg will stay live over an
2940 arbitrary computation. The same applies to the dst reg.
2942 * Temporary regs obtained from getNewRegNCG are distinct from
2943 each other and from all other regs, and stay live over
2944 arbitrary computations.
2948 trivialCode instr maybe_revinstr a b
2951 = getRegister a `thenNat` \ rega ->
2954 then registerCode rega dst `bind` \ code_a ->
2956 instr (OpImm imm_b) (OpReg dst)
2957 else registerCodeF rega `bind` \ code_a ->
2958 registerNameF rega `bind` \ r_a ->
2960 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2961 instr (OpImm imm_b) (OpReg dst)
2963 returnNat (Any IntRep mkcode)
2966 = getRegister b `thenNat` \ regb ->
2967 getNewRegNCG IntRep `thenNat` \ tmp ->
2968 let revinstr_avail = maybeToBool maybe_revinstr
2969 revinstr = case maybe_revinstr of Just ri -> ri
2973 then registerCode regb dst `bind` \ code_b ->
2975 revinstr (OpImm imm_a) (OpReg dst)
2976 else registerCodeF regb `bind` \ code_b ->
2977 registerNameF regb `bind` \ r_b ->
2979 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2980 revinstr (OpImm imm_a) (OpReg dst)
2984 then registerCode regb tmp `bind` \ code_b ->
2986 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2987 instr (OpReg tmp) (OpReg dst)
2988 else registerCodeF regb `bind` \ code_b ->
2989 registerNameF regb `bind` \ r_b ->
2991 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2992 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2993 instr (OpReg tmp) (OpReg dst)
2995 returnNat (Any IntRep mkcode)
2998 = getRegister a `thenNat` \ rega ->
2999 getRegister b `thenNat` \ regb ->
3000 getNewRegNCG IntRep `thenNat` \ tmp ->
3002 = case (isAny rega, isAny regb) of
3004 -> registerCode regb tmp `bind` \ code_b ->
3005 registerCode rega dst `bind` \ code_a ->
3008 instr (OpReg tmp) (OpReg dst)
3010 -> registerCode rega tmp `bind` \ code_a ->
3011 registerCodeF regb `bind` \ code_b ->
3012 registerNameF regb `bind` \ r_b ->
3015 instr (OpReg r_b) (OpReg tmp) `snocOL`
3016 MOV L (OpReg tmp) (OpReg dst)
3018 -> registerCode regb tmp `bind` \ code_b ->
3019 registerCodeF rega `bind` \ code_a ->
3020 registerNameF rega `bind` \ r_a ->
3023 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3024 instr (OpReg tmp) (OpReg dst)
3026 -> registerCodeF rega `bind` \ code_a ->
3027 registerNameF rega `bind` \ r_a ->
3028 registerCodeF regb `bind` \ code_b ->
3029 registerNameF regb `bind` \ r_b ->
3031 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3033 instr (OpReg r_b) (OpReg tmp) `snocOL`
3034 MOV L (OpReg tmp) (OpReg dst)
3036 returnNat (Any IntRep mkcode)
3039 maybe_imm_a = maybeImm a
3040 is_imm_a = maybeToBool maybe_imm_a
3041 imm_a = case maybe_imm_a of Just imm -> imm
3043 maybe_imm_b = maybeImm b
3044 is_imm_b = maybeToBool maybe_imm_b
3045 imm_b = case maybe_imm_b of Just imm -> imm
3049 trivialUCode instr x
3050 = getRegister x `thenNat` \ register ->
3052 code__2 dst = let code = registerCode register dst
3053 src = registerName register dst
3055 if isFixed register && dst /= src
3056 then toOL [MOV L (OpReg src) (OpReg dst),
3058 else unitOL (instr (OpReg src))
3060 returnNat (Any IntRep code__2)
3063 trivialFCode pk instr x y
3064 = getRegister x `thenNat` \ register1 ->
3065 getRegister y `thenNat` \ register2 ->
3066 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3067 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3069 code1 = registerCode register1 tmp1
3070 src1 = registerName register1 tmp1
3072 code2 = registerCode register2 tmp2
3073 src2 = registerName register2 tmp2
3076 -- treat the common case specially: both operands in
3078 | isAny register1 && isAny register2
3081 instr (primRepToSize pk) src1 src2 dst
3083 -- be paranoid (and inefficient)
3085 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3087 instr (primRepToSize pk) tmp1 src2 dst
3089 returnNat (Any pk code__2)
3093 trivialUFCode pk instr x
3094 = getRegister x `thenNat` \ register ->
3095 getNewRegNCG pk `thenNat` \ tmp ->
3097 code = registerCode register tmp
3098 src = registerName register tmp
3099 code__2 dst = code `snocOL` instr src dst
3101 returnNat (Any pk code__2)
3103 #endif {- i386_TARGET_ARCH -}
3104 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3105 #if sparc_TARGET_ARCH
3107 trivialCode instr x (StInt y)
3109 = getRegister x `thenNat` \ register ->
3110 getNewRegNCG IntRep `thenNat` \ tmp ->
3112 code = registerCode register tmp
3113 src1 = registerName register tmp
3114 src2 = ImmInt (fromInteger y)
3115 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3117 returnNat (Any IntRep code__2)
3119 trivialCode instr x y
3120 = getRegister x `thenNat` \ register1 ->
3121 getRegister y `thenNat` \ register2 ->
3122 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3123 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3125 code1 = registerCode register1 tmp1
3126 src1 = registerName register1 tmp1
3127 code2 = registerCode register2 tmp2
3128 src2 = registerName register2 tmp2
3129 code__2 dst = code1 `appOL` code2 `snocOL`
3130 instr src1 (RIReg src2) dst
3132 returnNat (Any IntRep code__2)
3135 trivialFCode pk instr x y
3136 = getRegister x `thenNat` \ register1 ->
3137 getRegister y `thenNat` \ register2 ->
3138 getNewRegNCG (registerRep register1)
3140 getNewRegNCG (registerRep register2)
3142 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3144 promote x = FxTOy F DF x tmp
3146 pk1 = registerRep register1
3147 code1 = registerCode register1 tmp1
3148 src1 = registerName register1 tmp1
3150 pk2 = registerRep register2
3151 code2 = registerCode register2 tmp2
3152 src2 = registerName register2 tmp2
3156 code1 `appOL` code2 `snocOL`
3157 instr (primRepToSize pk) src1 src2 dst
3158 else if pk1 == FloatRep then
3159 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3160 instr DF tmp src2 dst
3162 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3163 instr DF src1 tmp dst
3165 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3168 trivialUCode instr x
3169 = getRegister x `thenNat` \ register ->
3170 getNewRegNCG IntRep `thenNat` \ tmp ->
3172 code = registerCode register tmp
3173 src = registerName register tmp
3174 code__2 dst = code `snocOL` instr (RIReg src) dst
3176 returnNat (Any IntRep code__2)
3179 trivialUFCode pk instr x
3180 = getRegister x `thenNat` \ register ->
3181 getNewRegNCG pk `thenNat` \ tmp ->
3183 code = registerCode register tmp
3184 src = registerName register tmp
3185 code__2 dst = code `snocOL` instr src dst
3187 returnNat (Any pk code__2)
3189 #endif {- sparc_TARGET_ARCH -}
3192 %************************************************************************
3194 \subsubsection{Coercing to/from integer/floating-point...}
3196 %************************************************************************
3198 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3199 to be generated. Here we just change the type on the Register passed
3200 on up. The code is machine-independent.
3202 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3203 conversions. We have to store temporaries in memory to move
3204 between the integer and the floating point register sets.
3207 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3208 coerceFltCode :: StixTree -> NatM Register
3210 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3211 coerceFP2Int :: StixTree -> NatM Register
3214 = getRegister x `thenNat` \ register ->
3217 Fixed _ reg code -> Fixed pk reg code
3218 Any _ code -> Any pk code
3223 = getRegister x `thenNat` \ register ->
3226 Fixed _ reg code -> Fixed DoubleRep reg code
3227 Any _ code -> Any DoubleRep code
3232 #if alpha_TARGET_ARCH
3235 = getRegister x `thenNat` \ register ->
3236 getNewRegNCG IntRep `thenNat` \ reg ->
3238 code = registerCode register reg
3239 src = registerName register reg
3241 code__2 dst = code . mkSeqInstrs [
3243 LD TF dst (spRel 0),
3246 returnNat (Any DoubleRep code__2)
3250 = getRegister x `thenNat` \ register ->
3251 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3253 code = registerCode register tmp
3254 src = registerName register tmp
3256 code__2 dst = code . mkSeqInstrs [
3258 ST TF tmp (spRel 0),
3261 returnNat (Any IntRep code__2)
3263 #endif {- alpha_TARGET_ARCH -}
3264 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3265 #if i386_TARGET_ARCH
3267 extendIntCode :: PrimRep -> PrimRep -> StixTree -> NatM Register
3268 extendIntCode pks pkd x
3269 = coerceIntCode pks x `thenNat` \ register ->
3270 getNewRegNCG pks `thenNat` \ reg ->
3272 code = registerCode register reg
3273 src = registerName register reg
3274 opc = case pkd of IntRep -> MOVSxL ; WordRep -> MOVZxL
3275 sz = primRepToSize pks
3276 code__2 dst = code `snocOL` opc sz (OpReg src) (OpReg dst)
3278 returnNat (Any pkd code__2)
3282 = getRegister x `thenNat` \ register ->
3283 getNewRegNCG IntRep `thenNat` \ reg ->
3285 code = registerCode register reg
3286 src = registerName register reg
3287 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3288 code__2 dst = code `snocOL` opc src dst
3290 returnNat (Any pk code__2)
3294 = getRegister x `thenNat` \ register ->
3295 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3297 code = registerCode register tmp
3298 src = registerName register tmp
3299 pk = registerRep register
3301 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3302 code__2 dst = code `snocOL` opc src dst
3304 returnNat (Any IntRep code__2)
3306 #endif {- i386_TARGET_ARCH -}
3307 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3308 #if sparc_TARGET_ARCH
3311 = getRegister x `thenNat` \ register ->
3312 getNewRegNCG IntRep `thenNat` \ reg ->
3314 code = registerCode register reg
3315 src = registerName register reg
3317 code__2 dst = code `appOL` toOL [
3318 ST W src (spRel (-2)),
3319 LD W (spRel (-2)) dst,
3320 FxTOy W (primRepToSize pk) dst dst]
3322 returnNat (Any pk code__2)
3326 = getRegister x `thenNat` \ register ->
3327 getNewRegNCG IntRep `thenNat` \ reg ->
3328 getNewRegNCG FloatRep `thenNat` \ tmp ->
3330 code = registerCode register reg
3331 src = registerName register reg
3332 pk = registerRep register
3334 code__2 dst = code `appOL` toOL [
3335 FxTOy (primRepToSize pk) W src tmp,
3336 ST W tmp (spRel (-2)),
3337 LD W (spRel (-2)) dst]
3339 returnNat (Any IntRep code__2)
3341 #endif {- sparc_TARGET_ARCH -}
3344 %************************************************************************
3346 \subsubsection{Coercing integer to @Char@...}
3348 %************************************************************************
3350 Integer to character conversion.
3353 chrCode :: StixTree -> NatM Register
3355 #if alpha_TARGET_ARCH
3357 -- TODO: This is probably wrong, but I don't know Alpha assembler.
3358 -- It should coerce a 64-bit value to a 32-bit value.
3361 = getRegister x `thenNat` \ register ->
3362 getNewRegNCG IntRep `thenNat` \ reg ->
3364 code = registerCode register reg
3365 src = registerName register reg
3366 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3368 returnNat (Any IntRep code__2)
3370 #endif {- alpha_TARGET_ARCH -}
3371 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3372 #if i386_TARGET_ARCH
3375 = getRegister x `thenNat` \ register ->
3378 Fixed _ reg code -> Fixed IntRep reg code
3379 Any _ code -> Any IntRep code
3382 #endif {- i386_TARGET_ARCH -}
3383 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3384 #if sparc_TARGET_ARCH
3387 = getRegister x `thenNat` \ register ->
3390 Fixed _ reg code -> Fixed IntRep reg code
3391 Any _ code -> Any IntRep code
3394 #endif {- sparc_TARGET_ARCH -}