2 % (c) The AQUA Project, Glasgow University, 1996
4 \section[MachCode]{Generating machine code}
6 This is a big module, but, if you pay attention to
7 (a) the sectioning, (b) the type signatures, and
8 (c) the \tr{#if blah_TARGET_ARCH} things, the
9 structure should not be too overwhelming.
12 module MachCode ( stmt2Instrs, asmVoid, InstrList ) where
14 #include "HsVersions.h"
15 #include "nativeGen/NCG.h"
17 import MachMisc -- may differ per-platform
20 import AbsCSyn ( MagicId )
21 import AbsCUtils ( magicIdPrimRep )
22 import CallConv ( CallConv )
23 import CLabel ( isAsmTemp, CLabel )
24 import Maybes ( maybeToBool, expectJust )
25 import OrdList -- quite a bit of it
26 import PrimRep ( isFloatingRep, PrimRep(..) )
27 import PrimOp ( PrimOp(..), showPrimOp )
28 import CallConv ( cCallConv )
29 import Stix ( getUniqLabelNCG, StixTree(..),
30 StixReg(..), CodeSegment(..)
32 import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
38 Code extractor for an entire stix tree---stix statement level.
41 stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock
43 stmt2Instrs stmt = case stmt of
44 StComment s -> returnInstr (COMMENT s)
45 StSegment seg -> returnInstr (SEGMENT seg)
46 StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab))
47 StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id)
48 StLabel lab -> returnInstr (LABEL lab)
50 StJump arg -> genJump arg
51 StCondJump lab arg -> genCondJump lab arg
52 StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args
55 | isFloatingRep pk -> assignFltCode pk dst src
56 | otherwise -> assignIntCode pk dst src
59 -- When falling through on the Alpha, we still have to load pv
60 -- with the address of the next routine, so that it can load gp.
61 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
65 -> mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
66 returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms))
67 (foldr1 (.) codes xs))
69 getData :: StixTree -> UniqSM (InstrBlock, Imm)
71 getData (StInt i) = returnUs (id, ImmInteger i)
72 getData (StDouble d) = returnUs (id, dblImmLit d)
73 getData (StLitLbl s) = returnUs (id, ImmLab s)
74 getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
75 getData (StCLbl l) = returnUs (id, ImmCLbl l)
76 getData (StString s) =
77 getUniqLabelNCG `thenUs` \ lbl ->
78 returnUs (mkSeqInstrs [LABEL lbl,
79 ASCII True (_UNPK_ s)],
83 %************************************************************************
85 \subsection{General things for putting together code sequences}
87 %************************************************************************
90 type InstrList = OrdList Instr
91 type InstrBlock = InstrList -> InstrList
96 asmInstr :: Instr -> InstrList
97 asmInstr i = mkUnitList i
99 asmSeq :: [Instr] -> InstrList
100 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
102 asmParThen :: [InstrList] -> InstrBlock
103 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
105 returnInstr :: Instr -> UniqSM InstrBlock
106 returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
108 returnInstrs :: [Instr] -> UniqSM InstrBlock
109 returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
111 returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock
112 returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
114 mkSeqInstr :: Instr -> InstrBlock
115 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
117 mkSeqInstrs :: [Instr] -> InstrBlock
118 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
122 mangleIndexTree :: StixTree -> StixTree
124 mangleIndexTree (StIndex pk base (StInt i))
125 = StPrim IntAddOp [base, off]
127 off = StInt (i * sizeOf pk)
129 #ifndef i386_TARGET_ARCH
130 mangleIndexTree (StIndex pk base off)
131 = StPrim IntAddOp [base,
137 ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
138 StPrim SllOp [off, StInt s]
141 shift DoubleRep = 3::Integer
142 shift _ = IF_ARCH_alpha(3,2)
144 -- Hmm..this is an attempt at fixing Adress amodes (i.e., *[disp](base,index,<n>),
145 -- that do include the size of the primitive kind we're addressing. When StIndex
146 -- is expanded to actual code, the index (in units) is by the above code approp.
147 -- shifted to get the no. of bytes. Since Address amodes do contain size info
148 -- explicitly, we disable the shifting for x86s.
149 mangleIndexTree (StIndex pk base off) = StPrim IntAddOp [base, off]
155 maybeImm :: StixTree -> Maybe Imm
157 maybeImm (StLitLbl s) = Just (ImmLab s)
158 maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
159 maybeImm (StCLbl l) = Just (ImmCLbl l)
162 | i >= toInteger minInt && i <= toInteger maxInt
163 = Just (ImmInt (fromInteger i))
165 = Just (ImmInteger i)
170 %************************************************************************
172 \subsection{The @Register@ type}
174 %************************************************************************
176 @Register@s passed up the tree. If the stix code forces the register
177 to live in a pre-decided machine register, it comes out as @Fixed@;
178 otherwise, it comes out as @Any@, and the parent can decide which
179 register to put it in.
183 = Fixed PrimRep Reg InstrBlock
184 | Any PrimRep (Reg -> InstrBlock)
186 registerCode :: Register -> Reg -> InstrBlock
187 registerCode (Fixed _ _ code) reg = code
188 registerCode (Any _ code) reg = code reg
190 registerName :: Register -> Reg -> Reg
191 registerName (Fixed _ reg _) _ = reg
192 registerName (Any _ _) reg = reg
194 registerRep :: Register -> PrimRep
195 registerRep (Fixed pk _ _) = pk
196 registerRep (Any pk _) = pk
198 isFixed :: Register -> Bool
199 isFixed (Fixed _ _ _) = True
200 isFixed (Any _ _) = False
203 Generate code to get a subtree into a @Register@:
205 getRegister :: StixTree -> UniqSM Register
207 getRegister (StReg (StixMagicId stgreg))
208 = case (magicIdRegMaybe stgreg) of
209 Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id)
212 getRegister (StReg (StixTemp u pk))
213 = returnUs (Fixed pk (UnmappedReg u pk) id)
215 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
217 getRegister (StCall fn cconv kind args)
218 = genCCall fn cconv kind args `thenUs` \ call ->
219 returnUs (Fixed kind reg call)
221 reg = if isFloatingRep kind
222 then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,)))
223 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
225 getRegister (StString s)
226 = getUniqLabelNCG `thenUs` \ lbl ->
228 imm_lbl = ImmCLbl lbl
230 code dst = mkSeqInstrs [
233 ASCII True (_UNPK_ s),
235 #if alpha_TARGET_ARCH
236 LDA dst (AddrImm imm_lbl)
239 MOV L (OpImm imm_lbl) (OpReg dst)
241 #if sparc_TARGET_ARCH
242 SETHI (HI imm_lbl) dst,
243 OR False dst (RIImm (LO imm_lbl)) dst
247 returnUs (Any PtrRep code)
249 getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"'
250 = getUniqLabelNCG `thenUs` \ lbl ->
252 imm_lbl = ImmCLbl lbl
254 code dst = mkSeqInstrs [
257 ASCII False (init xs),
259 #if alpha_TARGET_ARCH
260 LDA dst (AddrImm imm_lbl)
263 MOV L (OpImm imm_lbl) (OpReg dst)
265 #if sparc_TARGET_ARCH
266 SETHI (HI imm_lbl) dst,
267 OR False dst (RIImm (LO imm_lbl)) dst
271 returnUs (Any PtrRep code)
273 xs = _UNPK_ (_TAIL_ s)
275 -- end of machine-"independent" bit; here we go on the rest...
277 #if alpha_TARGET_ARCH
279 getRegister (StDouble d)
280 = getUniqLabelNCG `thenUs` \ lbl ->
281 getNewRegNCG PtrRep `thenUs` \ tmp ->
282 let code dst = mkSeqInstrs [
285 DATA TF [ImmLab (rational d)],
287 LDA tmp (AddrImm (ImmCLbl lbl)),
288 LD TF dst (AddrReg tmp)]
290 returnUs (Any DoubleRep code)
292 getRegister (StPrim primop [x]) -- unary PrimOps
294 IntNegOp -> trivialUCode (NEG Q False) x
295 IntAbsOp -> trivialUCode (ABS Q) x
297 NotOp -> trivialUCode NOT x
299 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
300 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
302 OrdOp -> coerceIntCode IntRep x
305 Float2IntOp -> coerceFP2Int x
306 Int2FloatOp -> coerceInt2FP pr x
307 Double2IntOp -> coerceFP2Int x
308 Int2DoubleOp -> coerceInt2FP pr x
310 Double2FloatOp -> coerceFltCode x
311 Float2DoubleOp -> coerceFltCode x
313 other_op -> getRegister (StCall fn cconv DoubleRep [x])
315 fn = case other_op of
316 FloatExpOp -> SLIT("exp")
317 FloatLogOp -> SLIT("log")
318 FloatSqrtOp -> SLIT("sqrt")
319 FloatSinOp -> SLIT("sin")
320 FloatCosOp -> SLIT("cos")
321 FloatTanOp -> SLIT("tan")
322 FloatAsinOp -> SLIT("asin")
323 FloatAcosOp -> SLIT("acos")
324 FloatAtanOp -> SLIT("atan")
325 FloatSinhOp -> SLIT("sinh")
326 FloatCoshOp -> SLIT("cosh")
327 FloatTanhOp -> SLIT("tanh")
328 DoubleExpOp -> SLIT("exp")
329 DoubleLogOp -> SLIT("log")
330 DoubleSqrtOp -> SLIT("sqrt")
331 DoubleSinOp -> SLIT("sin")
332 DoubleCosOp -> SLIT("cos")
333 DoubleTanOp -> SLIT("tan")
334 DoubleAsinOp -> SLIT("asin")
335 DoubleAcosOp -> SLIT("acos")
336 DoubleAtanOp -> SLIT("atan")
337 DoubleSinhOp -> SLIT("sinh")
338 DoubleCoshOp -> SLIT("cosh")
339 DoubleTanhOp -> SLIT("tanh")
341 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
343 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
345 CharGtOp -> trivialCode (CMP LTT) y x
346 CharGeOp -> trivialCode (CMP LE) y x
347 CharEqOp -> trivialCode (CMP EQQ) x y
348 CharNeOp -> int_NE_code x y
349 CharLtOp -> trivialCode (CMP LTT) x y
350 CharLeOp -> trivialCode (CMP LE) x y
352 IntGtOp -> trivialCode (CMP LTT) y x
353 IntGeOp -> trivialCode (CMP LE) y x
354 IntEqOp -> trivialCode (CMP EQQ) x y
355 IntNeOp -> int_NE_code x y
356 IntLtOp -> trivialCode (CMP LTT) x y
357 IntLeOp -> trivialCode (CMP LE) x y
359 WordGtOp -> trivialCode (CMP ULT) y x
360 WordGeOp -> trivialCode (CMP ULE) x y
361 WordEqOp -> trivialCode (CMP EQQ) x y
362 WordNeOp -> int_NE_code x y
363 WordLtOp -> trivialCode (CMP ULT) x y
364 WordLeOp -> trivialCode (CMP ULE) x y
366 AddrGtOp -> trivialCode (CMP ULT) y x
367 AddrGeOp -> trivialCode (CMP ULE) y x
368 AddrEqOp -> trivialCode (CMP EQQ) x y
369 AddrNeOp -> int_NE_code x y
370 AddrLtOp -> trivialCode (CMP ULT) x y
371 AddrLeOp -> trivialCode (CMP ULE) x y
373 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
374 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
375 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
376 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
377 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
378 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
380 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
381 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
382 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
383 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
384 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
385 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
387 IntAddOp -> trivialCode (ADD Q False) x y
388 IntSubOp -> trivialCode (SUB Q False) x y
389 IntMulOp -> trivialCode (MUL Q False) x y
390 IntQuotOp -> trivialCode (DIV Q False) x y
391 IntRemOp -> trivialCode (REM Q False) x y
393 WordQuotOp -> trivialCode (DIV Q True) x y
394 WordRemOp -> trivialCode (REM Q True) x y
396 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
397 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
398 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
399 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
401 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
402 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
403 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
404 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
406 AndOp -> trivialCode AND x y
407 OrOp -> trivialCode OR x y
408 XorOp -> trivialCode XOR x y
409 SllOp -> trivialCode SLL x y
410 SrlOp -> trivialCode SRL x y
412 ISllOp -> panic "AlphaGen:isll"
413 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
414 ISrlOp -> panic "AlphaGen:isrl"
416 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
417 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
419 {- ------------------------------------------------------------
420 Some bizarre special code for getting condition codes into
421 registers. Integer non-equality is a test for equality
422 followed by an XOR with 1. (Integer comparisons always set
423 the result register to 0 or 1.) Floating point comparisons of
424 any kind leave the result in a floating point register, so we
425 need to wrangle an integer register out of things.
427 int_NE_code :: StixTree -> StixTree -> UniqSM Register
430 = trivialCode (CMP EQQ) x y `thenUs` \ register ->
431 getNewRegNCG IntRep `thenUs` \ tmp ->
433 code = registerCode register tmp
434 src = registerName register tmp
435 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
437 returnUs (Any IntRep code__2)
439 {- ------------------------------------------------------------
440 Comments for int_NE_code also apply to cmpF_code
443 :: (Reg -> Reg -> Reg -> Instr)
445 -> StixTree -> StixTree
448 cmpF_code instr cond x y
449 = trivialFCode pr instr x y `thenUs` \ register ->
450 getNewRegNCG DoubleRep `thenUs` \ tmp ->
451 getUniqLabelNCG `thenUs` \ lbl ->
453 code = registerCode register tmp
454 result = registerName register tmp
456 code__2 dst = code . mkSeqInstrs [
457 OR zeroh (RIImm (ImmInt 1)) dst,
458 BF cond result (ImmCLbl lbl),
459 OR zeroh (RIReg zeroh) dst,
462 returnUs (Any IntRep code__2)
464 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
465 ------------------------------------------------------------
467 getRegister (StInd pk mem)
468 = getAmode mem `thenUs` \ amode ->
470 code = amodeCode amode
471 src = amodeAddr amode
472 size = primRepToSize pk
473 code__2 dst = code . mkSeqInstr (LD size dst src)
475 returnUs (Any pk code__2)
477 getRegister (StInt i)
480 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
482 returnUs (Any IntRep code)
485 code dst = mkSeqInstr (LDI Q dst src)
487 returnUs (Any IntRep code)
489 src = ImmInt (fromInteger i)
494 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
496 returnUs (Any PtrRep code)
499 imm__2 = case imm of Just x -> x
501 #endif {- alpha_TARGET_ARCH -}
502 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
505 getRegister (StDouble 0.0)
507 code dst = mkSeqInstrs [FLDZ]
509 returnUs (Any DoubleRep code)
511 getRegister (StDouble 1.0)
513 code dst = mkSeqInstrs [FLD1]
515 returnUs (Any DoubleRep code)
517 getRegister (StDouble d)
518 = getUniqLabelNCG `thenUs` \ lbl ->
519 --getNewRegNCG PtrRep `thenUs` \ tmp ->
520 let code dst = mkSeqInstrs [
523 DATA DF [dblImmLit d],
525 FLD DF (OpImm (ImmCLbl lbl))
528 returnUs (Any DoubleRep code)
530 getRegister (StPrim primop [x]) -- unary PrimOps
532 IntNegOp -> trivialUCode (NEGI L) x
533 IntAbsOp -> absIntCode x
535 NotOp -> trivialUCode (NOT L) x
537 FloatNegOp -> trivialUFCode FloatRep FCHS x
538 FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
539 DoubleNegOp -> trivialUFCode DoubleRep FCHS x
541 DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
543 OrdOp -> coerceIntCode IntRep x
546 Float2IntOp -> coerceFP2Int x
547 Int2FloatOp -> coerceInt2FP FloatRep x
548 Double2IntOp -> coerceFP2Int x
549 Int2DoubleOp -> coerceInt2FP DoubleRep x
551 Double2FloatOp -> coerceFltCode x
552 Float2DoubleOp -> coerceFltCode x
556 fixed_x = if is_float_op -- promote to double
557 then StPrim Float2DoubleOp [x]
560 getRegister (StCall fn cCallConv DoubleRep [x])
564 FloatExpOp -> (True, SLIT("exp"))
565 FloatLogOp -> (True, SLIT("log"))
567 FloatSinOp -> (True, SLIT("sin"))
568 FloatCosOp -> (True, SLIT("cos"))
569 FloatTanOp -> (True, SLIT("tan"))
571 FloatAsinOp -> (True, SLIT("asin"))
572 FloatAcosOp -> (True, SLIT("acos"))
573 FloatAtanOp -> (True, SLIT("atan"))
575 FloatSinhOp -> (True, SLIT("sinh"))
576 FloatCoshOp -> (True, SLIT("cosh"))
577 FloatTanhOp -> (True, SLIT("tanh"))
579 DoubleExpOp -> (False, SLIT("exp"))
580 DoubleLogOp -> (False, SLIT("log"))
582 DoubleSinOp -> (False, SLIT("sin"))
583 DoubleCosOp -> (False, SLIT("cos"))
584 DoubleTanOp -> (False, SLIT("tan"))
586 DoubleAsinOp -> (False, SLIT("asin"))
587 DoubleAcosOp -> (False, SLIT("acos"))
588 DoubleAtanOp -> (False, SLIT("atan"))
590 DoubleSinhOp -> (False, SLIT("sinh"))
591 DoubleCoshOp -> (False, SLIT("cosh"))
592 DoubleTanhOp -> (False, SLIT("tanh"))
594 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
596 CharGtOp -> condIntReg GTT x y
597 CharGeOp -> condIntReg GE x y
598 CharEqOp -> condIntReg EQQ x y
599 CharNeOp -> condIntReg NE x y
600 CharLtOp -> condIntReg LTT x y
601 CharLeOp -> condIntReg LE x y
603 IntGtOp -> condIntReg GTT x y
604 IntGeOp -> condIntReg GE x y
605 IntEqOp -> condIntReg EQQ x y
606 IntNeOp -> condIntReg NE x y
607 IntLtOp -> condIntReg LTT x y
608 IntLeOp -> condIntReg LE x y
610 WordGtOp -> condIntReg GU x y
611 WordGeOp -> condIntReg GEU x y
612 WordEqOp -> condIntReg EQQ x y
613 WordNeOp -> condIntReg NE x y
614 WordLtOp -> condIntReg LU x y
615 WordLeOp -> condIntReg LEU x y
617 AddrGtOp -> condIntReg GU x y
618 AddrGeOp -> condIntReg GEU x y
619 AddrEqOp -> condIntReg EQQ x y
620 AddrNeOp -> condIntReg NE x y
621 AddrLtOp -> condIntReg LU x y
622 AddrLeOp -> condIntReg LEU x y
624 FloatGtOp -> condFltReg GTT x y
625 FloatGeOp -> condFltReg GE x y
626 FloatEqOp -> condFltReg EQQ x y
627 FloatNeOp -> condFltReg NE x y
628 FloatLtOp -> condFltReg LTT x y
629 FloatLeOp -> condFltReg LE x y
631 DoubleGtOp -> condFltReg GTT x y
632 DoubleGeOp -> condFltReg GE x y
633 DoubleEqOp -> condFltReg EQQ x y
634 DoubleNeOp -> condFltReg NE x y
635 DoubleLtOp -> condFltReg LTT x y
636 DoubleLeOp -> condFltReg LE x y
638 IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)...
639 -- this should be optimised by the generic Opts,
640 -- I don't know why it is not (sometimes)!
642 [x, StInt 0] -> getRegister x
647 IntSubOp -> sub_code L x y
648 IntQuotOp -> quot_code L x y True{-division-}
649 IntRemOp -> quot_code L x y False{-remainder-}
650 IntMulOp -> trivialCode (IMUL L) x y {-True-}
652 FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y
653 FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y
654 FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y
655 FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y
657 DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y
658 DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y
659 DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y
660 DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y
662 AndOp -> trivialCode (AND L) x y {-True-}
663 OrOp -> trivialCode (OR L) x y {-True-}
664 XorOp -> trivialCode (XOR L) x y {-True-}
666 {- Shift ops on x86s have constraints on their source, it
667 either has to be Imm, CL or 1
668 => trivialCode's is not restrictive enough (sigh.)
671 SllOp -> shift_code (SHL L) x y {-False-}
672 SrlOp -> shift_code (SHR L) x y {-False-}
675 ISllOp -> panic "I386Gen:isll"
676 ISraOp -> shift_code (SAR L) x y {-False-} --panic "I386Gen:isra"
677 ISrlOp -> panic "I386Gen:isrl"
679 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
680 where promote x = StPrim Float2DoubleOp [x]
681 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
683 shift_code :: (Operand -> Operand -> Instr)
687 {- Case1: shift length as immediate -}
688 -- Code is the same as the first eq. for trivialCode -- sigh.
689 shift_code instr x y{-amount-}
691 = getRegister x `thenUs` \ register ->
693 op_imm = OpImm imm__2
696 code = registerCode register dst
697 src = registerName register dst
699 mkSeqInstr (COMMENT SLIT("shift_code")) .
701 if isFixed register && src /= dst
703 mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
704 instr op_imm (OpReg dst)]
706 mkSeqInstr (instr op_imm (OpReg src))
708 returnUs (Any IntRep code__2)
711 imm__2 = case imm of Just x -> x
713 {- Case2: shift length is complex (non-immediate) -}
714 shift_code instr x y{-amount-}
715 = getRegister y `thenUs` \ register1 ->
716 getRegister x `thenUs` \ register2 ->
717 -- getNewRegNCG IntRep `thenUs` \ dst ->
719 -- Note: we force the shift length to be loaded
720 -- into ECX, so that we can use CL when shifting.
721 -- (only register location we are allowed
722 -- to put shift amounts.)
724 -- The shift instruction is fed ECX as src reg,
725 -- but we coerce this into CL when printing out.
726 src1 = registerName register1 ecx
727 code1 = if src1 /= ecx then -- if it is not in ecx already, force it!
728 registerCode register1 ecx .
729 mkSeqInstr (MOV L (OpReg src1) (OpReg ecx))
731 registerCode register1 ecx
734 code2 = registerCode register2 eax
735 src2 = registerName register2 eax
738 mkSeqInstr (instr (OpReg ecx) (OpReg eax))
740 returnUs (Fixed IntRep eax code__2)
742 add_code :: Size -> StixTree -> StixTree -> UniqSM Register
744 add_code sz x (StInt y)
745 = getRegister x `thenUs` \ register ->
746 getNewRegNCG IntRep `thenUs` \ tmp ->
748 code = registerCode register tmp
749 src1 = registerName register tmp
750 src2 = ImmInt (fromInteger y)
752 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst))
754 returnUs (Any IntRep code__2)
756 add_code sz x (StInd _ mem)
757 = getRegister x `thenUs` \ register1 ->
758 --getNewRegNCG (registerRep register1)
759 -- `thenUs` \ tmp1 ->
760 getAmode mem `thenUs` \ amode ->
762 code2 = amodeCode amode
763 src2 = amodeAddr amode
765 -- fixedname = registerName register1 eax
766 code__2 dst = let code1 = registerCode register1 dst
767 src1 = registerName register1 dst
768 in asmParThen [code2 asmVoid,code1 asmVoid] .
769 if isFixed register1 && src1 /= dst
770 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
771 ADD sz (OpAddr src2) (OpReg dst)]
773 mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
775 returnUs (Any IntRep code__2)
777 add_code sz (StInd _ mem) y
778 = getRegister y `thenUs` \ register2 ->
779 --getNewRegNCG (registerRep register2)
780 -- `thenUs` \ tmp2 ->
781 getAmode mem `thenUs` \ amode ->
783 code1 = amodeCode amode
784 src1 = amodeAddr amode
786 -- fixedname = registerName register2 eax
787 code__2 dst = let code2 = registerCode register2 dst
788 src2 = registerName register2 dst
789 in asmParThen [code1 asmVoid,code2 asmVoid] .
790 if isFixed register2 && src2 /= dst
791 then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
792 ADD sz (OpAddr src1) (OpReg dst)]
794 mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
796 returnUs (Any IntRep code__2)
799 = getRegister x `thenUs` \ register1 ->
800 getRegister y `thenUs` \ register2 ->
801 getNewRegNCG IntRep `thenUs` \ tmp1 ->
802 getNewRegNCG IntRep `thenUs` \ tmp2 ->
804 code1 = registerCode register1 tmp1 asmVoid
805 src1 = registerName register1 tmp1
806 code2 = registerCode register2 tmp2 asmVoid
807 src2 = registerName register2 tmp2
808 code__2 dst = asmParThen [code1, code2] .
809 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
811 returnUs (Any IntRep code__2)
814 sub_code :: Size -> StixTree -> StixTree -> UniqSM Register
816 sub_code sz x (StInt y)
817 = getRegister x `thenUs` \ register ->
818 getNewRegNCG IntRep `thenUs` \ tmp ->
820 code = registerCode register tmp
821 src1 = registerName register tmp
822 src2 = ImmInt (-(fromInteger y))
824 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst))
826 returnUs (Any IntRep code__2)
828 sub_code sz x y = trivialCode (SUB sz) x y {-False-}
833 -> StixTree -> StixTree
834 -> Bool -- True => division, False => remainder operation
837 -- x must go into eax, edx must be a sign-extension of eax, and y
838 -- should go in some other register (or memory), so that we get
839 -- edx:eax / reg -> eax (remainder in edx) Currently we chose to
840 -- put y in memory (if it is not there already)
842 quot_code sz x (StInd pk mem) is_division
843 = getRegister x `thenUs` \ register1 ->
844 getNewRegNCG IntRep `thenUs` \ tmp1 ->
845 getAmode mem `thenUs` \ amode ->
847 code1 = registerCode register1 tmp1 asmVoid
848 src1 = registerName register1 tmp1
849 code2 = amodeCode amode asmVoid
850 src2 = amodeAddr amode
851 code__2 = asmParThen [code1, code2] .
852 mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
854 IDIV sz (OpAddr src2)]
856 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
858 quot_code sz x (StInt i) is_division
859 = getRegister x `thenUs` \ register1 ->
860 getNewRegNCG IntRep `thenUs` \ tmp1 ->
862 code1 = registerCode register1 tmp1 asmVoid
863 src1 = registerName register1 tmp1
864 src2 = ImmInt (fromInteger i)
865 code__2 = asmParThen [code1] .
866 mkSeqInstrs [-- we put src2 in (ebx)
867 MOV L (OpImm src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
868 MOV L (OpReg src1) (OpReg eax),
870 IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))]
872 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
874 quot_code sz x y is_division
875 = getRegister x `thenUs` \ register1 ->
876 getNewRegNCG IntRep `thenUs` \ tmp1 ->
877 getRegister y `thenUs` \ register2 ->
878 getNewRegNCG IntRep `thenUs` \ tmp2 ->
880 code1 = registerCode register1 tmp1 asmVoid
881 src1 = registerName register1 tmp1
882 code2 = registerCode register2 tmp2 asmVoid
883 src2 = registerName register2 tmp2
884 code__2 = asmParThen [code1, code2] .
885 if src2 == ecx || src2 == esi
886 then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
888 IDIV sz (OpReg src2)]
889 else mkSeqInstrs [ -- we put src2 in (ebx)
890 MOV L (OpReg src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
891 MOV L (OpReg src1) (OpReg eax),
893 IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))]
895 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
896 -----------------------
898 getRegister (StInd pk mem)
899 = getAmode mem `thenUs` \ amode ->
901 code = amodeCode amode
902 src = amodeAddr amode
903 size = primRepToSize pk
905 if pk == DoubleRep || pk == FloatRep
906 then mkSeqInstr (FLD {-DF-} size (OpAddr src))
907 else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
909 returnUs (Any pk code__2)
912 getRegister (StInt i)
914 src = ImmInt (fromInteger i)
915 code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
917 returnUs (Any IntRep code)
922 code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
924 returnUs (Any PtrRep code)
927 imm__2 = case imm of Just x -> x
929 #endif {- i386_TARGET_ARCH -}
930 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
931 #if sparc_TARGET_ARCH
933 getRegister (StDouble d)
934 = getUniqLabelNCG `thenUs` \ lbl ->
935 getNewRegNCG PtrRep `thenUs` \ tmp ->
936 let code dst = mkSeqInstrs [
939 DATA DF [dblImmLit d],
941 SETHI (HI (ImmCLbl lbl)) tmp,
942 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
944 returnUs (Any DoubleRep code)
946 getRegister (StPrim primop [x]) -- unary PrimOps
948 IntNegOp -> trivialUCode (SUB False False g0) x
949 IntAbsOp -> absIntCode x
950 NotOp -> trivialUCode (XNOR False g0) x
952 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
954 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
956 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
957 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
959 OrdOp -> coerceIntCode IntRep x
962 Float2IntOp -> coerceFP2Int x
963 Int2FloatOp -> coerceInt2FP FloatRep x
964 Double2IntOp -> coerceFP2Int x
965 Int2DoubleOp -> coerceInt2FP DoubleRep x
969 fixed_x = if is_float_op -- promote to double
970 then StPrim Float2DoubleOp [x]
973 getRegister (StCall fn cCallConv DoubleRep [x])
977 FloatExpOp -> (True, SLIT("exp"))
978 FloatLogOp -> (True, SLIT("log"))
979 FloatSqrtOp -> (True, SLIT("sqrt"))
981 FloatSinOp -> (True, SLIT("sin"))
982 FloatCosOp -> (True, SLIT("cos"))
983 FloatTanOp -> (True, SLIT("tan"))
985 FloatAsinOp -> (True, SLIT("asin"))
986 FloatAcosOp -> (True, SLIT("acos"))
987 FloatAtanOp -> (True, SLIT("atan"))
989 FloatSinhOp -> (True, SLIT("sinh"))
990 FloatCoshOp -> (True, SLIT("cosh"))
991 FloatTanhOp -> (True, SLIT("tanh"))
993 DoubleExpOp -> (False, SLIT("exp"))
994 DoubleLogOp -> (False, SLIT("log"))
995 DoubleSqrtOp -> (True, SLIT("sqrt"))
997 DoubleSinOp -> (False, SLIT("sin"))
998 DoubleCosOp -> (False, SLIT("cos"))
999 DoubleTanOp -> (False, SLIT("tan"))
1001 DoubleAsinOp -> (False, SLIT("asin"))
1002 DoubleAcosOp -> (False, SLIT("acos"))
1003 DoubleAtanOp -> (False, SLIT("atan"))
1005 DoubleSinhOp -> (False, SLIT("sinh"))
1006 DoubleCoshOp -> (False, SLIT("cosh"))
1007 DoubleTanhOp -> (False, SLIT("tanh"))
1008 _ -> panic ("Monadic PrimOp not handled: " ++ showPrimOp primop)
1010 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
1012 CharGtOp -> condIntReg GTT x y
1013 CharGeOp -> condIntReg GE x y
1014 CharEqOp -> condIntReg EQQ x y
1015 CharNeOp -> condIntReg NE x y
1016 CharLtOp -> condIntReg LTT x y
1017 CharLeOp -> condIntReg LE x y
1019 IntGtOp -> condIntReg GTT x y
1020 IntGeOp -> condIntReg GE x y
1021 IntEqOp -> condIntReg EQQ x y
1022 IntNeOp -> condIntReg NE x y
1023 IntLtOp -> condIntReg LTT x y
1024 IntLeOp -> condIntReg LE x y
1026 WordGtOp -> condIntReg GU x y
1027 WordGeOp -> condIntReg GEU x y
1028 WordEqOp -> condIntReg EQQ x y
1029 WordNeOp -> condIntReg NE x y
1030 WordLtOp -> condIntReg LU x y
1031 WordLeOp -> condIntReg LEU x y
1033 AddrGtOp -> condIntReg GU x y
1034 AddrGeOp -> condIntReg GEU x y
1035 AddrEqOp -> condIntReg EQQ x y
1036 AddrNeOp -> condIntReg NE x y
1037 AddrLtOp -> condIntReg LU x y
1038 AddrLeOp -> condIntReg LEU x y
1040 FloatGtOp -> condFltReg GTT x y
1041 FloatGeOp -> condFltReg GE x y
1042 FloatEqOp -> condFltReg EQQ x y
1043 FloatNeOp -> condFltReg NE x y
1044 FloatLtOp -> condFltReg LTT x y
1045 FloatLeOp -> condFltReg LE x y
1047 DoubleGtOp -> condFltReg GTT x y
1048 DoubleGeOp -> condFltReg GE x y
1049 DoubleEqOp -> condFltReg EQQ x y
1050 DoubleNeOp -> condFltReg NE x y
1051 DoubleLtOp -> condFltReg LTT x y
1052 DoubleLeOp -> condFltReg LE x y
1054 IntAddOp -> trivialCode (ADD False False) x y
1055 IntSubOp -> trivialCode (SUB False False) x y
1057 -- ToDo: teach about V8+ SPARC mul/div instructions
1058 IntMulOp -> imul_div SLIT(".umul") x y
1059 IntQuotOp -> imul_div SLIT(".div") x y
1060 IntRemOp -> imul_div SLIT(".rem") x y
1062 FloatAddOp -> trivialFCode FloatRep FADD x y
1063 FloatSubOp -> trivialFCode FloatRep FSUB x y
1064 FloatMulOp -> trivialFCode FloatRep FMUL x y
1065 FloatDivOp -> trivialFCode FloatRep FDIV x y
1067 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1068 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1069 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1070 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1072 AndOp -> trivialCode (AND False) x y
1073 OrOp -> trivialCode (OR False) x y
1074 XorOp -> trivialCode (XOR False) x y
1075 SllOp -> trivialCode SLL x y
1076 SrlOp -> trivialCode SRL x y
1078 ISllOp -> panic "SparcGen:isll"
1079 ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
1080 ISrlOp -> panic "SparcGen:isrl"
1082 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
1083 where promote x = StPrim Float2DoubleOp [x]
1084 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
1085 -- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
1087 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1089 getRegister (StInd pk mem)
1090 = getAmode mem `thenUs` \ amode ->
1092 code = amodeCode amode
1093 src = amodeAddr amode
1094 size = primRepToSize pk
1095 code__2 dst = code . mkSeqInstr (LD size src dst)
1097 returnUs (Any pk code__2)
1099 getRegister (StInt i)
1102 src = ImmInt (fromInteger i)
1103 code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
1105 returnUs (Any IntRep code)
1110 code dst = mkSeqInstrs [
1111 SETHI (HI imm__2) dst,
1112 OR False dst (RIImm (LO imm__2)) dst]
1114 returnUs (Any PtrRep code)
1117 imm__2 = case imm of Just x -> x
1119 #endif {- sparc_TARGET_ARCH -}
1122 %************************************************************************
1124 \subsection{The @Amode@ type}
1126 %************************************************************************
1128 @Amode@s: Memory addressing modes passed up the tree.
1130 data Amode = Amode MachRegsAddr InstrBlock
1132 amodeAddr (Amode addr _) = addr
1133 amodeCode (Amode _ code) = code
1136 Now, given a tree (the argument to an StInd) that references memory,
1137 produce a suitable addressing mode.
1140 getAmode :: StixTree -> UniqSM Amode
1142 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1144 #if alpha_TARGET_ARCH
1146 getAmode (StPrim IntSubOp [x, StInt i])
1147 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1148 getRegister x `thenUs` \ register ->
1150 code = registerCode register tmp
1151 reg = registerName register tmp
1152 off = ImmInt (-(fromInteger i))
1154 returnUs (Amode (AddrRegImm reg off) code)
1156 getAmode (StPrim IntAddOp [x, StInt i])
1157 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1158 getRegister x `thenUs` \ register ->
1160 code = registerCode register tmp
1161 reg = registerName register tmp
1162 off = ImmInt (fromInteger i)
1164 returnUs (Amode (AddrRegImm reg off) code)
1168 = returnUs (Amode (AddrImm imm__2) id)
1171 imm__2 = case imm of Just x -> x
1174 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1175 getRegister other `thenUs` \ register ->
1177 code = registerCode register tmp
1178 reg = registerName register tmp
1180 returnUs (Amode (AddrReg reg) code)
1182 #endif {- alpha_TARGET_ARCH -}
1183 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1184 #if i386_TARGET_ARCH
1186 getAmode (StPrim IntSubOp [x, StInt i])
1187 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1188 getRegister x `thenUs` \ register ->
1190 code = registerCode register tmp
1191 reg = registerName register tmp
1192 off = ImmInt (-(fromInteger i))
1194 returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1196 getAmode (StPrim IntAddOp [x, StInt i])
1199 code = mkSeqInstrs []
1201 returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
1204 imm__2 = case imm of Just x -> x
1206 getAmode (StPrim IntAddOp [x, StInt i])
1207 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1208 getRegister x `thenUs` \ register ->
1210 code = registerCode register tmp
1211 reg = registerName register tmp
1212 off = ImmInt (fromInteger i)
1214 returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1216 getAmode (StPrim IntAddOp [x, y])
1217 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1218 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1219 getRegister x `thenUs` \ register1 ->
1220 getRegister y `thenUs` \ register2 ->
1222 code1 = registerCode register1 tmp1 asmVoid
1223 reg1 = registerName register1 tmp1
1224 code2 = registerCode register2 tmp2 asmVoid
1225 reg2 = registerName register2 tmp2
1226 code__2 = asmParThen [code1, code2]
1228 returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
1233 code = mkSeqInstrs []
1235 returnUs (Amode (ImmAddr imm__2 0) code)
1238 imm__2 = case imm of Just x -> x
1241 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1242 getRegister other `thenUs` \ register ->
1244 code = registerCode register tmp
1245 reg = registerName register tmp
1248 returnUs (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1250 #endif {- i386_TARGET_ARCH -}
1251 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1252 #if sparc_TARGET_ARCH
1254 getAmode (StPrim IntSubOp [x, StInt i])
1256 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1257 getRegister x `thenUs` \ register ->
1259 code = registerCode register tmp
1260 reg = registerName register tmp
1261 off = ImmInt (-(fromInteger i))
1263 returnUs (Amode (AddrRegImm reg off) code)
1266 getAmode (StPrim IntAddOp [x, StInt i])
1268 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1269 getRegister x `thenUs` \ register ->
1271 code = registerCode register tmp
1272 reg = registerName register tmp
1273 off = ImmInt (fromInteger i)
1275 returnUs (Amode (AddrRegImm reg off) code)
1277 getAmode (StPrim IntAddOp [x, y])
1278 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1279 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1280 getRegister x `thenUs` \ register1 ->
1281 getRegister y `thenUs` \ register2 ->
1283 code1 = registerCode register1 tmp1 asmVoid
1284 reg1 = registerName register1 tmp1
1285 code2 = registerCode register2 tmp2 asmVoid
1286 reg2 = registerName register2 tmp2
1287 code__2 = asmParThen [code1, code2]
1289 returnUs (Amode (AddrRegReg reg1 reg2) code__2)
1293 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1295 code = mkSeqInstr (SETHI (HI imm__2) tmp)
1297 returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
1300 imm__2 = case imm of Just x -> x
1303 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1304 getRegister other `thenUs` \ register ->
1306 code = registerCode register tmp
1307 reg = registerName register tmp
1310 returnUs (Amode (AddrRegImm reg off) code)
1312 #endif {- sparc_TARGET_ARCH -}
1315 %************************************************************************
1317 \subsection{The @CondCode@ type}
1319 %************************************************************************
1321 Condition codes passed up the tree.
1323 data CondCode = CondCode Bool Cond InstrBlock
1325 condName (CondCode _ cond _) = cond
1326 condFloat (CondCode is_float _ _) = is_float
1327 condCode (CondCode _ _ code) = code
1330 Set up a condition code for a conditional branch.
1333 getCondCode :: StixTree -> UniqSM CondCode
1335 #if alpha_TARGET_ARCH
1336 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1337 #endif {- alpha_TARGET_ARCH -}
1338 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1340 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1341 -- yes, they really do seem to want exactly the same!
1343 getCondCode (StPrim primop [x, y])
1345 CharGtOp -> condIntCode GTT x y
1346 CharGeOp -> condIntCode GE x y
1347 CharEqOp -> condIntCode EQQ x y
1348 CharNeOp -> condIntCode NE x y
1349 CharLtOp -> condIntCode LTT x y
1350 CharLeOp -> condIntCode LE x y
1352 IntGtOp -> condIntCode GTT x y
1353 IntGeOp -> condIntCode GE x y
1354 IntEqOp -> condIntCode EQQ x y
1355 IntNeOp -> condIntCode NE x y
1356 IntLtOp -> condIntCode LTT x y
1357 IntLeOp -> condIntCode LE x y
1359 WordGtOp -> condIntCode GU x y
1360 WordGeOp -> condIntCode GEU x y
1361 WordEqOp -> condIntCode EQQ x y
1362 WordNeOp -> condIntCode NE x y
1363 WordLtOp -> condIntCode LU x y
1364 WordLeOp -> condIntCode LEU x y
1366 AddrGtOp -> condIntCode GU x y
1367 AddrGeOp -> condIntCode GEU x y
1368 AddrEqOp -> condIntCode EQQ x y
1369 AddrNeOp -> condIntCode NE x y
1370 AddrLtOp -> condIntCode LU x y
1371 AddrLeOp -> condIntCode LEU x y
1373 FloatGtOp -> condFltCode GTT x y
1374 FloatGeOp -> condFltCode GE x y
1375 FloatEqOp -> condFltCode EQQ x y
1376 FloatNeOp -> condFltCode NE x y
1377 FloatLtOp -> condFltCode LTT x y
1378 FloatLeOp -> condFltCode LE x y
1380 DoubleGtOp -> condFltCode GTT x y
1381 DoubleGeOp -> condFltCode GE x y
1382 DoubleEqOp -> condFltCode EQQ x y
1383 DoubleNeOp -> condFltCode NE x y
1384 DoubleLtOp -> condFltCode LTT x y
1385 DoubleLeOp -> condFltCode LE x y
1387 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1392 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1393 passed back up the tree.
1396 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode
1398 #if alpha_TARGET_ARCH
1399 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1400 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1401 #endif {- alpha_TARGET_ARCH -}
1403 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1404 #if i386_TARGET_ARCH
1406 condIntCode cond (StInd _ x) y
1408 = getAmode x `thenUs` \ amode ->
1410 code1 = amodeCode amode asmVoid
1411 y__2 = amodeAddr amode
1412 code__2 = asmParThen [code1] .
1413 mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
1415 returnUs (CondCode False cond code__2)
1418 imm__2 = case imm of Just x -> x
1420 condIntCode cond x (StInt 0)
1421 = getRegister x `thenUs` \ register1 ->
1422 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1424 code1 = registerCode register1 tmp1 asmVoid
1425 src1 = registerName register1 tmp1
1426 code__2 = asmParThen [code1] .
1427 mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
1429 returnUs (CondCode False cond code__2)
1431 condIntCode cond x y
1433 = getRegister x `thenUs` \ register1 ->
1434 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1436 code1 = registerCode register1 tmp1 asmVoid
1437 src1 = registerName register1 tmp1
1438 code__2 = asmParThen [code1] .
1439 mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
1441 returnUs (CondCode False cond code__2)
1444 imm__2 = case imm of Just x -> x
1446 condIntCode cond (StInd _ x) y
1447 = getAmode x `thenUs` \ amode ->
1448 getRegister y `thenUs` \ register2 ->
1449 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1451 code1 = amodeCode amode asmVoid
1452 src1 = amodeAddr amode
1453 code2 = registerCode register2 tmp2 asmVoid
1454 src2 = registerName register2 tmp2
1455 code__2 = asmParThen [code1, code2] .
1456 mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
1458 returnUs (CondCode False cond code__2)
1460 condIntCode cond y (StInd _ x)
1461 = getAmode x `thenUs` \ amode ->
1462 getRegister y `thenUs` \ register2 ->
1463 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1465 code1 = amodeCode amode asmVoid
1466 src1 = amodeAddr amode
1467 code2 = registerCode register2 tmp2 asmVoid
1468 src2 = registerName register2 tmp2
1469 code__2 = asmParThen [code1, code2] .
1470 mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
1472 returnUs (CondCode False cond code__2)
1474 condIntCode cond x y
1475 = getRegister x `thenUs` \ register1 ->
1476 getRegister y `thenUs` \ register2 ->
1477 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1478 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1480 code1 = registerCode register1 tmp1 asmVoid
1481 src1 = registerName register1 tmp1
1482 code2 = registerCode register2 tmp2 asmVoid
1483 src2 = registerName register2 tmp2
1484 code__2 = asmParThen [code1, code2] .
1485 mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
1487 returnUs (CondCode False cond code__2)
1491 condFltCode cond x (StDouble 0.0)
1492 = getRegister x `thenUs` \ register1 ->
1493 getNewRegNCG (registerRep register1)
1496 pk1 = registerRep register1
1497 code1 = registerCode register1 tmp1
1498 src1 = registerName register1 tmp1
1500 code__2 = asmParThen [code1 asmVoid] .
1501 mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ?
1503 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1504 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1508 returnUs (CondCode True (fix_FP_cond cond) code__2)
1510 condFltCode cond x y
1511 = getRegister x `thenUs` \ register1 ->
1512 getRegister y `thenUs` \ register2 ->
1513 getNewRegNCG (registerRep register1)
1515 getNewRegNCG (registerRep register2)
1518 pk1 = registerRep register1
1519 code1 = registerCode register1 tmp1
1520 src1 = registerName register1 tmp1
1522 code2 = registerCode register2 tmp2
1523 src2 = registerName register2 tmp2
1525 code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
1526 mkSeqInstrs [FUCOMPP,
1528 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1529 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1533 returnUs (CondCode True (fix_FP_cond cond) code__2)
1535 {- On the 486, the flags set by FP compare are the unsigned ones!
1536 (This looks like a HACK to me. WDP 96/03)
1539 fix_FP_cond :: Cond -> Cond
1541 fix_FP_cond GE = GEU
1542 fix_FP_cond GTT = GU
1543 fix_FP_cond LTT = LU
1544 fix_FP_cond LE = LEU
1545 fix_FP_cond any = any
1547 #endif {- i386_TARGET_ARCH -}
1548 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1549 #if sparc_TARGET_ARCH
1551 condIntCode cond x (StInt y)
1553 = getRegister x `thenUs` \ register ->
1554 getNewRegNCG IntRep `thenUs` \ tmp ->
1556 code = registerCode register tmp
1557 src1 = registerName register tmp
1558 src2 = ImmInt (fromInteger y)
1559 code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
1561 returnUs (CondCode False cond code__2)
1563 condIntCode cond x y
1564 = getRegister x `thenUs` \ register1 ->
1565 getRegister y `thenUs` \ register2 ->
1566 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1567 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1569 code1 = registerCode register1 tmp1 asmVoid
1570 src1 = registerName register1 tmp1
1571 code2 = registerCode register2 tmp2 asmVoid
1572 src2 = registerName register2 tmp2
1573 code__2 = asmParThen [code1, code2] .
1574 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
1576 returnUs (CondCode False cond code__2)
1579 condFltCode cond x y
1580 = getRegister x `thenUs` \ register1 ->
1581 getRegister y `thenUs` \ register2 ->
1582 getNewRegNCG (registerRep register1)
1584 getNewRegNCG (registerRep register2)
1586 getNewRegNCG DoubleRep `thenUs` \ tmp ->
1588 promote x = asmInstr (FxTOy F DF x tmp)
1590 pk1 = registerRep register1
1591 code1 = registerCode register1 tmp1
1592 src1 = registerName register1 tmp1
1594 pk2 = registerRep register2
1595 code2 = registerCode register2 tmp2
1596 src2 = registerName register2 tmp2
1600 asmParThen [code1 asmVoid, code2 asmVoid] .
1601 mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
1602 else if pk1 == FloatRep then
1603 asmParThen [code1 (promote src1), code2 asmVoid] .
1604 mkSeqInstr (FCMP True DF tmp src2)
1606 asmParThen [code1 asmVoid, code2 (promote src2)] .
1607 mkSeqInstr (FCMP True DF src1 tmp)
1609 returnUs (CondCode True cond code__2)
1611 #endif {- sparc_TARGET_ARCH -}
1614 %************************************************************************
1616 \subsection{Generating assignments}
1618 %************************************************************************
1620 Assignments are really at the heart of the whole code generation
1621 business. Almost all top-level nodes of any real importance are
1622 assignments, which correspond to loads, stores, or register transfers.
1623 If we're really lucky, some of the register transfers will go away,
1624 because we can use the destination register to complete the code
1625 generation for the right hand side. This only fails when the right
1626 hand side is forced into a fixed register (e.g. the result of a call).
1629 assignIntCode, assignFltCode
1630 :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
1632 #if alpha_TARGET_ARCH
1634 assignIntCode pk (StInd _ dst) src
1635 = getNewRegNCG IntRep `thenUs` \ tmp ->
1636 getAmode dst `thenUs` \ amode ->
1637 getRegister src `thenUs` \ register ->
1639 code1 = amodeCode amode asmVoid
1640 dst__2 = amodeAddr amode
1641 code2 = registerCode register tmp asmVoid
1642 src__2 = registerName register tmp
1643 sz = primRepToSize pk
1644 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1648 assignIntCode pk dst src
1649 = getRegister dst `thenUs` \ register1 ->
1650 getRegister src `thenUs` \ register2 ->
1652 dst__2 = registerName register1 zeroh
1653 code = registerCode register2 dst__2
1654 src__2 = registerName register2 dst__2
1655 code__2 = if isFixed register2
1656 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1661 #endif {- alpha_TARGET_ARCH -}
1662 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1663 #if i386_TARGET_ARCH
1665 assignIntCode pk (StInd _ dst) src
1666 = getAmode dst `thenUs` \ amode ->
1667 get_op_RI src `thenUs` \ (codesrc, opsrc, sz) ->
1669 code1 = amodeCode amode asmVoid
1670 dst__2 = amodeAddr amode
1671 code__2 = asmParThen [code1, codesrc asmVoid] .
1672 mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
1678 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
1682 = returnUs (asmParThen [], OpImm imm_op, L)
1685 imm_op = case imm of Just x -> x
1688 = getRegister op `thenUs` \ register ->
1689 getNewRegNCG (registerRep register)
1692 code = registerCode register tmp
1693 reg = registerName register tmp
1694 pk = registerRep register
1695 sz = primRepToSize pk
1697 returnUs (code, OpReg reg, sz)
1699 assignIntCode pk dst (StInd _ src)
1700 = getNewRegNCG IntRep `thenUs` \ tmp ->
1701 getAmode src `thenUs` \ amode ->
1702 getRegister dst `thenUs` \ register ->
1704 code1 = amodeCode amode asmVoid
1705 src__2 = amodeAddr amode
1706 code2 = registerCode register tmp asmVoid
1707 dst__2 = registerName register tmp
1708 sz = primRepToSize pk
1709 code__2 = asmParThen [code1, code2] .
1710 mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
1714 assignIntCode pk dst src
1715 = getRegister dst `thenUs` \ register1 ->
1716 getRegister src `thenUs` \ register2 ->
1717 getNewRegNCG IntRep `thenUs` \ tmp ->
1719 dst__2 = registerName register1 tmp
1720 code = registerCode register2 dst__2
1721 src__2 = registerName register2 dst__2
1722 code__2 = if isFixed register2 && dst__2 /= src__2
1723 then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
1728 #endif {- i386_TARGET_ARCH -}
1729 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1730 #if sparc_TARGET_ARCH
1732 assignIntCode pk (StInd _ dst) src
1733 = getNewRegNCG IntRep `thenUs` \ tmp ->
1734 getAmode dst `thenUs` \ amode ->
1735 getRegister src `thenUs` \ register ->
1737 code1 = amodeCode amode asmVoid
1738 dst__2 = amodeAddr amode
1739 code2 = registerCode register tmp asmVoid
1740 src__2 = registerName register tmp
1741 sz = primRepToSize pk
1742 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1746 assignIntCode pk dst src
1747 = getRegister dst `thenUs` \ register1 ->
1748 getRegister src `thenUs` \ register2 ->
1750 dst__2 = registerName register1 g0
1751 code = registerCode register2 dst__2
1752 src__2 = registerName register2 dst__2
1753 code__2 = if isFixed register2
1754 then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
1759 #endif {- sparc_TARGET_ARCH -}
1762 % --------------------------------
1763 Floating-point assignments:
1764 % --------------------------------
1766 #if alpha_TARGET_ARCH
1768 assignFltCode pk (StInd _ dst) src
1769 = getNewRegNCG pk `thenUs` \ tmp ->
1770 getAmode dst `thenUs` \ amode ->
1771 getRegister src `thenUs` \ register ->
1773 code1 = amodeCode amode asmVoid
1774 dst__2 = amodeAddr amode
1775 code2 = registerCode register tmp asmVoid
1776 src__2 = registerName register tmp
1777 sz = primRepToSize pk
1778 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1782 assignFltCode pk dst src
1783 = getRegister dst `thenUs` \ register1 ->
1784 getRegister src `thenUs` \ register2 ->
1786 dst__2 = registerName register1 zeroh
1787 code = registerCode register2 dst__2
1788 src__2 = registerName register2 dst__2
1789 code__2 = if isFixed register2
1790 then code . mkSeqInstr (FMOV src__2 dst__2)
1795 #endif {- alpha_TARGET_ARCH -}
1796 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1797 #if i386_TARGET_ARCH
1799 assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
1800 = getNewRegNCG IntRep `thenUs` \ tmp ->
1801 getAmode src `thenUs` \ amodesrc ->
1802 getAmode dst `thenUs` \ amodedst ->
1803 --getRegister src `thenUs` \ register ->
1805 codesrc1 = amodeCode amodesrc asmVoid
1806 addrsrc1 = amodeAddr amodesrc
1807 codedst1 = amodeCode amodedst asmVoid
1808 addrdst1 = amodeAddr amodedst
1809 addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x
1810 addrdst2 = case (addrOffset addrdst1 4) of Just x -> x
1812 code__2 = asmParThen [codesrc1, codedst1] .
1813 mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
1814 MOV L (OpReg tmp) (OpAddr addrdst1)]
1817 then [MOV L (OpAddr addrsrc2) (OpReg tmp),
1818 MOV L (OpReg tmp) (OpAddr addrdst2)]
1823 assignFltCode pk (StInd _ dst) src
1824 = --getNewRegNCG pk `thenUs` \ tmp ->
1825 getAmode dst `thenUs` \ amode ->
1826 getRegister src `thenUs` \ register ->
1828 sz = primRepToSize pk
1829 dst__2 = amodeAddr amode
1831 code1 = amodeCode amode asmVoid
1832 code2 = registerCode register {-tmp-}st0 asmVoid
1834 --src__2= registerName register tmp
1835 pk__2 = registerRep register
1836 sz__2 = primRepToSize pk__2
1838 code__2 = asmParThen [code1, code2] .
1839 mkSeqInstr (FSTP sz (OpAddr dst__2))
1843 assignFltCode pk dst src
1844 = getRegister dst `thenUs` \ register1 ->
1845 getRegister src `thenUs` \ register2 ->
1846 --getNewRegNCG (registerRep register2)
1847 -- `thenUs` \ tmp ->
1849 sz = primRepToSize pk
1850 dst__2 = registerName register1 st0 --tmp
1852 code = registerCode register2 dst__2
1853 src__2 = registerName register2 dst__2
1859 #endif {- i386_TARGET_ARCH -}
1860 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1861 #if sparc_TARGET_ARCH
1863 assignFltCode pk (StInd _ dst) src
1864 = getNewRegNCG pk `thenUs` \ tmp1 ->
1865 getAmode dst `thenUs` \ amode ->
1866 getRegister src `thenUs` \ register ->
1868 sz = primRepToSize pk
1869 dst__2 = amodeAddr amode
1871 code1 = amodeCode amode asmVoid
1872 code2 = registerCode register tmp1 asmVoid
1874 src__2 = registerName register tmp1
1875 pk__2 = registerRep register
1876 sz__2 = primRepToSize pk__2
1878 code__2 = asmParThen [code1, code2] .
1880 mkSeqInstr (ST sz src__2 dst__2)
1882 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1886 assignFltCode pk dst src
1887 = getRegister dst `thenUs` \ register1 ->
1888 getRegister src `thenUs` \ register2 ->
1890 pk__2 = registerRep register2
1891 sz__2 = primRepToSize pk__2
1893 getNewRegNCG pk__2 `thenUs` \ tmp ->
1895 sz = primRepToSize pk
1896 dst__2 = registerName register1 g0 -- must be Fixed
1899 reg__2 = if pk /= pk__2 then tmp else dst__2
1901 code = registerCode register2 reg__2
1903 src__2 = registerName register2 reg__2
1907 code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
1908 else if isFixed register2 then
1909 code . mkSeqInstr (FMOV sz src__2 dst__2)
1915 #endif {- sparc_TARGET_ARCH -}
1918 %************************************************************************
1920 \subsection{Generating an unconditional branch}
1922 %************************************************************************
1924 We accept two types of targets: an immediate CLabel or a tree that
1925 gets evaluated into a register. Any CLabels which are AsmTemporaries
1926 are assumed to be in the local block of code, close enough for a
1927 branch instruction. Other CLabels are assumed to be far away.
1929 (If applicable) Do not fill the delay slots here; you will confuse the
1933 genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
1935 #if alpha_TARGET_ARCH
1937 genJump (StCLbl lbl)
1938 | isAsmTemp lbl = returnInstr (BR target)
1939 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1941 target = ImmCLbl lbl
1944 = getRegister tree `thenUs` \ register ->
1945 getNewRegNCG PtrRep `thenUs` \ tmp ->
1947 dst = registerName register pv
1948 code = registerCode register pv
1949 target = registerName register pv
1951 if isFixed register then
1952 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1954 returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1956 #endif {- alpha_TARGET_ARCH -}
1957 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1958 #if i386_TARGET_ARCH
1961 genJump (StCLbl lbl)
1962 | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
1963 | otherwise = returnInstrs [JMP (OpImm target)]
1965 target = ImmCLbl lbl
1968 genJump (StInd pk mem)
1969 = getAmode mem `thenUs` \ amode ->
1971 code = amodeCode amode
1972 target = amodeAddr amode
1974 returnSeq code [JMP (OpAddr target)]
1978 = returnInstr (JMP (OpImm target))
1981 = getRegister tree `thenUs` \ register ->
1982 getNewRegNCG PtrRep `thenUs` \ tmp ->
1984 code = registerCode register tmp
1985 target = registerName register tmp
1987 returnSeq code [JMP (OpReg target)]
1990 target = case imm of Just x -> x
1992 #endif {- i386_TARGET_ARCH -}
1993 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1994 #if sparc_TARGET_ARCH
1996 genJump (StCLbl lbl)
1997 | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
1998 | otherwise = returnInstrs [CALL target 0 True, NOP]
2000 target = ImmCLbl lbl
2003 = getRegister tree `thenUs` \ register ->
2004 getNewRegNCG PtrRep `thenUs` \ tmp ->
2006 code = registerCode register tmp
2007 target = registerName register tmp
2009 returnSeq code [JMP (AddrRegReg target g0), NOP]
2011 #endif {- sparc_TARGET_ARCH -}
2014 %************************************************************************
2016 \subsection{Conditional jumps}
2018 %************************************************************************
2020 Conditional jumps are always to local labels, so we can use branch
2021 instructions. We peek at the arguments to decide what kind of
2024 ALPHA: For comparisons with 0, we're laughing, because we can just do
2025 the desired conditional branch.
2027 I386: First, we have to ensure that the condition
2028 codes are set according to the supplied comparison operation.
2030 SPARC: First, we have to ensure that the condition codes are set
2031 according to the supplied comparison operation. We generate slightly
2032 different code for floating point comparisons, because a floating
2033 point operation cannot directly precede a @BF@. We assume the worst
2034 and fill that slot with a @NOP@.
2036 SPARC: Do not fill the delay slots here; you will confuse the register
2041 :: CLabel -- the branch target
2042 -> StixTree -- the condition on which to branch
2043 -> UniqSM InstrBlock
2045 #if alpha_TARGET_ARCH
2047 genCondJump lbl (StPrim op [x, StInt 0])
2048 = getRegister x `thenUs` \ register ->
2049 getNewRegNCG (registerRep register)
2052 code = registerCode register tmp
2053 value = registerName register tmp
2054 pk = registerRep register
2055 target = ImmCLbl lbl
2057 returnSeq code [BI (cmpOp op) value target]
2059 cmpOp CharGtOp = GTT
2061 cmpOp CharEqOp = EQQ
2063 cmpOp CharLtOp = LTT
2072 cmpOp WordGeOp = ALWAYS
2073 cmpOp WordEqOp = EQQ
2075 cmpOp WordLtOp = NEVER
2076 cmpOp WordLeOp = EQQ
2078 cmpOp AddrGeOp = ALWAYS
2079 cmpOp AddrEqOp = EQQ
2081 cmpOp AddrLtOp = NEVER
2082 cmpOp AddrLeOp = EQQ
2084 genCondJump lbl (StPrim op [x, StDouble 0.0])
2085 = getRegister x `thenUs` \ register ->
2086 getNewRegNCG (registerRep register)
2089 code = registerCode register tmp
2090 value = registerName register tmp
2091 pk = registerRep register
2092 target = ImmCLbl lbl
2094 returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
2096 cmpOp FloatGtOp = GTT
2097 cmpOp FloatGeOp = GE
2098 cmpOp FloatEqOp = EQQ
2099 cmpOp FloatNeOp = NE
2100 cmpOp FloatLtOp = LTT
2101 cmpOp FloatLeOp = LE
2102 cmpOp DoubleGtOp = GTT
2103 cmpOp DoubleGeOp = GE
2104 cmpOp DoubleEqOp = EQQ
2105 cmpOp DoubleNeOp = NE
2106 cmpOp DoubleLtOp = LTT
2107 cmpOp DoubleLeOp = LE
2109 genCondJump lbl (StPrim op [x, y])
2111 = trivialFCode pr instr x y `thenUs` \ register ->
2112 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2114 code = registerCode register tmp
2115 result = registerName register tmp
2116 target = ImmCLbl lbl
2118 returnUs (code . mkSeqInstr (BF cond result target))
2120 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2122 fltCmpOp op = case op of
2136 (instr, cond) = case op of
2137 FloatGtOp -> (FCMP TF LE, EQQ)
2138 FloatGeOp -> (FCMP TF LTT, EQQ)
2139 FloatEqOp -> (FCMP TF EQQ, NE)
2140 FloatNeOp -> (FCMP TF EQQ, EQQ)
2141 FloatLtOp -> (FCMP TF LTT, NE)
2142 FloatLeOp -> (FCMP TF LE, NE)
2143 DoubleGtOp -> (FCMP TF LE, EQQ)
2144 DoubleGeOp -> (FCMP TF LTT, EQQ)
2145 DoubleEqOp -> (FCMP TF EQQ, NE)
2146 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2147 DoubleLtOp -> (FCMP TF LTT, NE)
2148 DoubleLeOp -> (FCMP TF LE, NE)
2150 genCondJump lbl (StPrim op [x, y])
2151 = trivialCode instr x y `thenUs` \ register ->
2152 getNewRegNCG IntRep `thenUs` \ tmp ->
2154 code = registerCode register tmp
2155 result = registerName register tmp
2156 target = ImmCLbl lbl
2158 returnUs (code . mkSeqInstr (BI cond result target))
2160 (instr, cond) = case op of
2161 CharGtOp -> (CMP LE, EQQ)
2162 CharGeOp -> (CMP LTT, EQQ)
2163 CharEqOp -> (CMP EQQ, NE)
2164 CharNeOp -> (CMP EQQ, EQQ)
2165 CharLtOp -> (CMP LTT, NE)
2166 CharLeOp -> (CMP LE, NE)
2167 IntGtOp -> (CMP LE, EQQ)
2168 IntGeOp -> (CMP LTT, EQQ)
2169 IntEqOp -> (CMP EQQ, NE)
2170 IntNeOp -> (CMP EQQ, EQQ)
2171 IntLtOp -> (CMP LTT, NE)
2172 IntLeOp -> (CMP LE, NE)
2173 WordGtOp -> (CMP ULE, EQQ)
2174 WordGeOp -> (CMP ULT, EQQ)
2175 WordEqOp -> (CMP EQQ, NE)
2176 WordNeOp -> (CMP EQQ, EQQ)
2177 WordLtOp -> (CMP ULT, NE)
2178 WordLeOp -> (CMP ULE, NE)
2179 AddrGtOp -> (CMP ULE, EQQ)
2180 AddrGeOp -> (CMP ULT, EQQ)
2181 AddrEqOp -> (CMP EQQ, NE)
2182 AddrNeOp -> (CMP EQQ, EQQ)
2183 AddrLtOp -> (CMP ULT, NE)
2184 AddrLeOp -> (CMP ULE, NE)
2186 #endif {- alpha_TARGET_ARCH -}
2187 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2188 #if i386_TARGET_ARCH
2190 genCondJump lbl bool
2191 = getCondCode bool `thenUs` \ condition ->
2193 code = condCode condition
2194 cond = condName condition
2195 target = ImmCLbl lbl
2197 returnSeq code [JXX cond lbl]
2199 #endif {- i386_TARGET_ARCH -}
2200 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2201 #if sparc_TARGET_ARCH
2203 genCondJump lbl bool
2204 = getCondCode bool `thenUs` \ condition ->
2206 code = condCode condition
2207 cond = condName condition
2208 target = ImmCLbl lbl
2211 if condFloat condition then
2212 [NOP, BF cond False target, NOP]
2214 [BI cond False target, NOP]
2217 #endif {- sparc_TARGET_ARCH -}
2220 %************************************************************************
2222 \subsection{Generating C calls}
2224 %************************************************************************
2226 Now the biggest nightmare---calls. Most of the nastiness is buried in
2227 @get_arg@, which moves the arguments to the correct registers/stack
2228 locations. Apart from that, the code is easy.
2230 (If applicable) Do not fill the delay slots here; you will confuse the
2235 :: FAST_STRING -- function to call
2237 -> PrimRep -- type of the result
2238 -> [StixTree] -- arguments (of mixed type)
2239 -> UniqSM InstrBlock
2241 #if alpha_TARGET_ARCH
2243 genCCall fn cconv kind args
2244 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2245 `thenUs` \ ((unused,_), argCode) ->
2247 nRegs = length allArgRegs - length unused
2248 code = asmParThen (map ($ asmVoid) argCode)
2251 LDA pv (AddrImm (ImmLab (ptext fn))),
2252 JSR ra (AddrReg pv) nRegs,
2253 LDGP gp (AddrReg ra)]
2255 ------------------------
2256 {- Try to get a value into a specific register (or registers) for
2257 a call. The first 6 arguments go into the appropriate
2258 argument register (separate registers for integer and floating
2259 point arguments, but used in lock-step), and the remaining
2260 arguments are dumped to the stack, beginning at 0(sp). Our
2261 first argument is a pair of the list of remaining argument
2262 registers to be assigned for this call and the next stack
2263 offset to use for overflowing arguments. This way,
2264 @get_Arg@ can be applied to all of a call's arguments using
2268 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2269 -> StixTree -- Current argument
2270 -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2272 -- We have to use up all of our argument registers first...
2274 get_arg ((iDst,fDst):dsts, offset) arg
2275 = getRegister arg `thenUs` \ register ->
2277 reg = if isFloatingRep pk then fDst else iDst
2278 code = registerCode register reg
2279 src = registerName register reg
2280 pk = registerRep register
2283 if isFloatingRep pk then
2284 ((dsts, offset), if isFixed register then
2285 code . mkSeqInstr (FMOV src fDst)
2288 ((dsts, offset), if isFixed register then
2289 code . mkSeqInstr (OR src (RIReg src) iDst)
2292 -- Once we have run out of argument registers, we move to the
2295 get_arg ([], offset) arg
2296 = getRegister arg `thenUs` \ register ->
2297 getNewRegNCG (registerRep register)
2300 code = registerCode register tmp
2301 src = registerName register tmp
2302 pk = registerRep register
2303 sz = primRepToSize pk
2305 returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2307 #endif {- alpha_TARGET_ARCH -}
2308 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2309 #if i386_TARGET_ARCH
2311 genCCall fn cconv kind [StInt i]
2312 | fn == SLIT ("PerformGC_wrapper")
2314 call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2315 CALL (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))]
2320 = getUniqLabelNCG `thenUs` \ lbl ->
2322 call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2323 MOV L (OpImm (ImmCLbl lbl))
2324 -- this is hardwired
2325 (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 104))),
2326 JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
2332 genCCall fn cconv kind args
2333 = mapUs get_call_arg args `thenUs` \ argCode ->
2337 {- OLD: Since there's no attempt at stealing %esp at the moment,
2338 restoring %esp from MainRegTable.rCstkptr is not done. -- SOF 97/09
2339 (ditto for saving away old-esp in MainRegTable.Hp (!!) )
2340 code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))),
2341 MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
2345 code2 = asmParThen (map ($ asmVoid) (reverse argCode))
2346 call = [CALL fn__2 ,
2347 -- pop args; all args word sized?
2348 ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp) --,
2350 -- Don't restore %esp (see above)
2351 -- MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
2354 returnSeq (code2) call
2356 -- function names that begin with '.' are assumed to be special
2357 -- internally generated names like '.mul,' which don't get an
2358 -- underscore prefix
2359 -- ToDo:needed (WDP 96/03) ???
2360 fn__2 = case (_HEAD_ fn) of
2361 '.' -> ImmLit (ptext fn)
2362 _ -> ImmLab (ptext fn)
2365 get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code
2368 = get_op arg `thenUs` \ (code, op, sz) ->
2369 returnUs (code . mkSeqInstr (PUSH sz op))
2374 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
2377 = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
2379 get_op (StInd pk mem)
2380 = getAmode mem `thenUs` \ amode ->
2382 code = amodeCode amode --asmVoid
2383 addr = amodeAddr amode
2384 sz = primRepToSize pk
2386 returnUs (code, OpAddr addr, sz)
2389 = getRegister op `thenUs` \ register ->
2390 getNewRegNCG (registerRep register)
2393 code = registerCode register tmp
2394 reg = registerName register tmp
2395 pk = registerRep register
2396 sz = primRepToSize pk
2398 returnUs (code, OpReg reg, sz)
2400 #endif {- i386_TARGET_ARCH -}
2401 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2402 #if sparc_TARGET_ARCH
2404 genCCall fn cconv kind args
2405 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2406 `thenUs` \ ((unused,_), argCode) ->
2408 nRegs = length allArgRegs - length unused
2409 call = CALL fn__2 nRegs False
2410 code = asmParThen (map ($ asmVoid) argCode)
2412 returnSeq code [call, NOP]
2414 -- function names that begin with '.' are assumed to be special
2415 -- internally generated names like '.mul,' which don't get an
2416 -- underscore prefix
2417 -- ToDo:needed (WDP 96/03) ???
2418 fn__2 = case (_HEAD_ fn) of
2419 '.' -> ImmLit (ptext fn)
2420 _ -> ImmLab (ptext fn)
2422 ------------------------------------
2423 {- Try to get a value into a specific register (or registers) for
2424 a call. The SPARC calling convention is an absolute
2425 nightmare. The first 6x32 bits of arguments are mapped into
2426 %o0 through %o5, and the remaining arguments are dumped to the
2427 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2428 first argument is a pair of the list of remaining argument
2429 registers to be assigned for this call and the next stack
2430 offset to use for overflowing arguments. This way,
2431 @get_arg@ can be applied to all of a call's arguments using
2435 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2436 -> StixTree -- Current argument
2437 -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2439 -- We have to use up all of our argument registers first...
2441 get_arg (dst:dsts, offset) arg
2442 = getRegister arg `thenUs` \ register ->
2443 getNewRegNCG (registerRep register)
2446 reg = if isFloatingRep pk then tmp else dst
2447 code = registerCode register reg
2448 src = registerName register reg
2449 pk = registerRep register
2451 returnUs (case pk of
2454 [] -> (([], offset + 1), code . mkSeqInstrs [
2455 -- conveniently put the second part in the right stack
2456 -- location, and load the first part into %o5
2457 ST DF src (spRel (offset - 1)),
2458 LD W (spRel (offset - 1)) dst])
2459 (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2460 ST DF src (spRel (-2)),
2461 LD W (spRel (-2)) dst,
2462 LD W (spRel (-1)) dst__2])
2463 FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2464 ST F src (spRel (-2)),
2465 LD W (spRel (-2)) dst])
2466 _ -> ((dsts, offset), if isFixed register then
2467 code . mkSeqInstr (OR False g0 (RIReg src) dst)
2470 -- Once we have run out of argument registers, we move to the
2473 get_arg ([], offset) arg
2474 = getRegister arg `thenUs` \ register ->
2475 getNewRegNCG (registerRep register)
2478 code = registerCode register tmp
2479 src = registerName register tmp
2480 pk = registerRep register
2481 sz = primRepToSize pk
2482 words = if pk == DoubleRep then 2 else 1
2484 returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2486 #endif {- sparc_TARGET_ARCH -}
2489 %************************************************************************
2491 \subsection{Support bits}
2493 %************************************************************************
2495 %************************************************************************
2497 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2499 %************************************************************************
2501 Turn those condition codes into integers now (when they appear on
2502 the right hand side of an assignment).
2504 (If applicable) Do not fill the delay slots here; you will confuse the
2508 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2510 #if alpha_TARGET_ARCH
2511 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2512 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2513 #endif {- alpha_TARGET_ARCH -}
2515 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2516 #if i386_TARGET_ARCH
2519 = condIntCode cond x y `thenUs` \ condition ->
2520 getNewRegNCG IntRep `thenUs` \ tmp ->
2521 --getRegister dst `thenUs` \ register ->
2523 --code2 = registerCode register tmp asmVoid
2524 --dst__2 = registerName register tmp
2525 code = condCode condition
2526 cond = condName condition
2527 -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2528 code__2 dst = code . mkSeqInstrs [
2529 SETCC cond (OpReg tmp),
2530 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2531 MOV L (OpReg tmp) (OpReg dst)]
2533 returnUs (Any IntRep code__2)
2536 = getUniqLabelNCG `thenUs` \ lbl1 ->
2537 getUniqLabelNCG `thenUs` \ lbl2 ->
2538 condFltCode cond x y `thenUs` \ condition ->
2540 code = condCode condition
2541 cond = condName condition
2542 code__2 dst = code . mkSeqInstrs [
2544 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2547 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2550 returnUs (Any IntRep code__2)
2552 #endif {- i386_TARGET_ARCH -}
2553 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2554 #if sparc_TARGET_ARCH
2556 condIntReg EQQ x (StInt 0)
2557 = getRegister x `thenUs` \ register ->
2558 getNewRegNCG IntRep `thenUs` \ tmp ->
2560 code = registerCode register tmp
2561 src = registerName register tmp
2562 code__2 dst = code . mkSeqInstrs [
2563 SUB False True g0 (RIReg src) g0,
2564 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2566 returnUs (Any IntRep code__2)
2569 = getRegister x `thenUs` \ register1 ->
2570 getRegister y `thenUs` \ register2 ->
2571 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2572 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2574 code1 = registerCode register1 tmp1 asmVoid
2575 src1 = registerName register1 tmp1
2576 code2 = registerCode register2 tmp2 asmVoid
2577 src2 = registerName register2 tmp2
2578 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2579 XOR False src1 (RIReg src2) dst,
2580 SUB False True g0 (RIReg dst) g0,
2581 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2583 returnUs (Any IntRep code__2)
2585 condIntReg NE x (StInt 0)
2586 = getRegister x `thenUs` \ register ->
2587 getNewRegNCG IntRep `thenUs` \ tmp ->
2589 code = registerCode register tmp
2590 src = registerName register tmp
2591 code__2 dst = code . mkSeqInstrs [
2592 SUB False True g0 (RIReg src) g0,
2593 ADD True False g0 (RIImm (ImmInt 0)) dst]
2595 returnUs (Any IntRep code__2)
2598 = getRegister x `thenUs` \ register1 ->
2599 getRegister y `thenUs` \ register2 ->
2600 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2601 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2603 code1 = registerCode register1 tmp1 asmVoid
2604 src1 = registerName register1 tmp1
2605 code2 = registerCode register2 tmp2 asmVoid
2606 src2 = registerName register2 tmp2
2607 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2608 XOR False src1 (RIReg src2) dst,
2609 SUB False True g0 (RIReg dst) g0,
2610 ADD True False g0 (RIImm (ImmInt 0)) dst]
2612 returnUs (Any IntRep code__2)
2615 = getUniqLabelNCG `thenUs` \ lbl1 ->
2616 getUniqLabelNCG `thenUs` \ lbl2 ->
2617 condIntCode cond x y `thenUs` \ condition ->
2619 code = condCode condition
2620 cond = condName condition
2621 code__2 dst = code . mkSeqInstrs [
2622 BI cond False (ImmCLbl lbl1), NOP,
2623 OR False g0 (RIImm (ImmInt 0)) dst,
2624 BI ALWAYS False (ImmCLbl lbl2), NOP,
2626 OR False g0 (RIImm (ImmInt 1)) dst,
2629 returnUs (Any IntRep code__2)
2632 = getUniqLabelNCG `thenUs` \ lbl1 ->
2633 getUniqLabelNCG `thenUs` \ lbl2 ->
2634 condFltCode cond x y `thenUs` \ condition ->
2636 code = condCode condition
2637 cond = condName condition
2638 code__2 dst = code . mkSeqInstrs [
2640 BF cond False (ImmCLbl lbl1), NOP,
2641 OR False g0 (RIImm (ImmInt 0)) dst,
2642 BI ALWAYS False (ImmCLbl lbl2), NOP,
2644 OR False g0 (RIImm (ImmInt 1)) dst,
2647 returnUs (Any IntRep code__2)
2649 #endif {- sparc_TARGET_ARCH -}
2652 %************************************************************************
2654 \subsubsection{@trivial*Code@: deal with trivial instructions}
2656 %************************************************************************
2658 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2659 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2660 for constants on the right hand side, because that's where the generic
2661 optimizer will have put them.
2663 Similarly, for unary instructions, we don't have to worry about
2664 matching an StInt as the argument, because genericOpt will already
2665 have handled the constant-folding.
2669 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2670 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2671 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2673 -> StixTree -> StixTree -- the two arguments
2678 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2679 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2681 {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
2682 (Size -> Operand -> Instr)
2683 -> (Size -> Operand -> Instr) {-reversed instr-}
2685 -> Instr {-reversed instr: pop-}
2687 -> StixTree -> StixTree -- the two arguments
2691 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2692 ,IF_ARCH_i386 ((Operand -> Instr)
2693 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2695 -> StixTree -- the one argument
2700 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2701 ,IF_ARCH_i386 (Instr
2702 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2704 -> StixTree -- the one argument
2707 #if alpha_TARGET_ARCH
2709 trivialCode instr x (StInt y)
2711 = getRegister x `thenUs` \ register ->
2712 getNewRegNCG IntRep `thenUs` \ tmp ->
2714 code = registerCode register tmp
2715 src1 = registerName register tmp
2716 src2 = ImmInt (fromInteger y)
2717 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2719 returnUs (Any IntRep code__2)
2721 trivialCode instr x y
2722 = getRegister x `thenUs` \ register1 ->
2723 getRegister y `thenUs` \ register2 ->
2724 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2725 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2727 code1 = registerCode register1 tmp1 asmVoid
2728 src1 = registerName register1 tmp1
2729 code2 = registerCode register2 tmp2 asmVoid
2730 src2 = registerName register2 tmp2
2731 code__2 dst = asmParThen [code1, code2] .
2732 mkSeqInstr (instr src1 (RIReg src2) dst)
2734 returnUs (Any IntRep code__2)
2737 trivialUCode instr x
2738 = getRegister x `thenUs` \ register ->
2739 getNewRegNCG IntRep `thenUs` \ tmp ->
2741 code = registerCode register tmp
2742 src = registerName register tmp
2743 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2745 returnUs (Any IntRep code__2)
2748 trivialFCode _ instr x y
2749 = getRegister x `thenUs` \ register1 ->
2750 getRegister y `thenUs` \ register2 ->
2751 getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
2752 getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
2754 code1 = registerCode register1 tmp1
2755 src1 = registerName register1 tmp1
2757 code2 = registerCode register2 tmp2
2758 src2 = registerName register2 tmp2
2760 code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2761 mkSeqInstr (instr src1 src2 dst)
2763 returnUs (Any DoubleRep code__2)
2765 trivialUFCode _ instr x
2766 = getRegister x `thenUs` \ register ->
2767 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2769 code = registerCode register tmp
2770 src = registerName register tmp
2771 code__2 dst = code . mkSeqInstr (instr src dst)
2773 returnUs (Any DoubleRep code__2)
2775 #endif {- alpha_TARGET_ARCH -}
2776 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2777 #if i386_TARGET_ARCH
2779 trivialCode instr x y
2781 = getRegister x `thenUs` \ register1 ->
2782 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2784 -- fixedname = registerName register1 eax
2785 code__2 dst = let code1 = registerCode register1 dst
2786 src1 = registerName register1 dst
2788 if isFixed register1 && src1 /= dst
2789 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2790 instr (OpImm imm__2) (OpReg dst)]
2792 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
2794 returnUs (Any IntRep code__2)
2797 imm__2 = case imm of Just x -> x
2799 trivialCode instr x y
2801 = getRegister y `thenUs` \ register1 ->
2802 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2804 -- fixedname = registerName register1 eax
2805 code__2 dst = let code1 = registerCode register1 dst
2806 src1 = registerName register1 dst
2808 if isFixed register1 && src1 /= dst
2809 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2810 instr (OpImm imm__2) (OpReg dst)]
2812 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
2814 returnUs (Any IntRep code__2)
2817 imm__2 = case imm of Just x -> x
2819 trivialCode instr x (StInd pk mem)
2820 = getRegister x `thenUs` \ register ->
2821 --getNewRegNCG IntRep `thenUs` \ tmp ->
2822 getAmode mem `thenUs` \ amode ->
2824 -- fixedname = registerName register eax
2825 code2 = amodeCode amode asmVoid
2826 src2 = amodeAddr amode
2827 code__2 dst = let code1 = registerCode register dst asmVoid
2828 src1 = registerName register dst
2829 in asmParThen [code1, code2] .
2830 if isFixed register && src1 /= dst
2831 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2832 instr (OpAddr src2) (OpReg dst)]
2834 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2836 returnUs (Any pk code__2)
2838 trivialCode instr (StInd pk mem) y
2839 = getRegister y `thenUs` \ register ->
2840 --getNewRegNCG IntRep `thenUs` \ tmp ->
2841 getAmode mem `thenUs` \ amode ->
2843 -- fixedname = registerName register eax
2844 code2 = amodeCode amode asmVoid
2845 src2 = amodeAddr amode
2847 code1 = registerCode register dst asmVoid
2848 src1 = registerName register dst
2849 in asmParThen [code1, code2] .
2850 if isFixed register && src1 /= dst
2851 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2852 instr (OpAddr src2) (OpReg dst)]
2854 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2856 returnUs (Any pk code__2)
2858 trivialCode instr x y
2859 = getRegister x `thenUs` \ register1 ->
2860 getRegister y `thenUs` \ register2 ->
2861 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2862 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2864 -- fixedname = registerName register1 eax
2865 code2 = registerCode register2 tmp2 asmVoid
2866 src2 = registerName register2 tmp2
2868 code1 = registerCode register1 dst asmVoid
2869 src1 = registerName register1 dst
2870 in asmParThen [code1, code2] .
2871 if isFixed register1 && src1 /= dst
2872 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2873 instr (OpReg src2) (OpReg dst)]
2875 mkSeqInstr (instr (OpReg src2) (OpReg src1))
2877 returnUs (Any IntRep code__2)
2880 trivialUCode instr x
2881 = getRegister x `thenUs` \ register ->
2882 -- getNewRegNCG IntRep `thenUs` \ tmp ->
2884 -- fixedname = registerName register eax
2886 code = registerCode register dst
2887 src = registerName register dst
2888 in code . if isFixed register && dst /= src
2889 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
2891 else mkSeqInstr (instr (OpReg src))
2893 returnUs (Any IntRep code__2)
2896 trivialFCode pk _ instrr _ _ (StInd pk' mem) y
2897 = getRegister y `thenUs` \ register2 ->
2898 --getNewRegNCG (registerRep register2)
2899 -- `thenUs` \ tmp2 ->
2900 getAmode mem `thenUs` \ amode ->
2902 code1 = amodeCode amode
2903 src1 = amodeAddr amode
2906 code2 = registerCode register2 dst
2907 src2 = registerName register2 dst
2908 in asmParThen [code1 asmVoid,code2 asmVoid] .
2909 mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
2911 returnUs (Any pk code__2)
2913 trivialFCode pk instr _ _ _ x (StInd pk' mem)
2914 = getRegister x `thenUs` \ register1 ->
2915 --getNewRegNCG (registerRep register1)
2916 -- `thenUs` \ tmp1 ->
2917 getAmode mem `thenUs` \ amode ->
2919 code2 = amodeCode amode
2920 src2 = amodeAddr amode
2923 code1 = registerCode register1 dst
2924 src1 = registerName register1 dst
2925 in asmParThen [code2 asmVoid,code1 asmVoid] .
2926 mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
2928 returnUs (Any pk code__2)
2930 trivialFCode pk _ _ _ instrpr x y
2931 = getRegister x `thenUs` \ register1 ->
2932 getRegister y `thenUs` \ register2 ->
2933 --getNewRegNCG (registerRep register1)
2934 -- `thenUs` \ tmp1 ->
2935 --getNewRegNCG (registerRep register2)
2936 -- `thenUs` \ tmp2 ->
2937 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2939 pk1 = registerRep register1
2940 code1 = registerCode register1 st0 --tmp1
2941 src1 = registerName register1 st0 --tmp1
2943 pk2 = registerRep register2
2946 code2 = registerCode register2 dst
2947 src2 = registerName register2 dst
2948 in asmParThen [code1 asmVoid, code2 asmVoid] .
2951 returnUs (Any pk1 code__2)
2954 trivialUFCode pk instr (StInd pk' mem)
2955 = getAmode mem `thenUs` \ amode ->
2957 code = amodeCode amode
2958 src = amodeAddr amode
2959 code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
2962 returnUs (Any pk code__2)
2964 trivialUFCode pk instr x
2965 = getRegister x `thenUs` \ register ->
2966 --getNewRegNCG pk `thenUs` \ tmp ->
2969 code = registerCode register dst
2970 src = registerName register dst
2971 in code . mkSeqInstrs [instr]
2973 returnUs (Any pk code__2)
2975 #endif {- i386_TARGET_ARCH -}
2976 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2977 #if sparc_TARGET_ARCH
2979 trivialCode instr x (StInt y)
2981 = getRegister x `thenUs` \ register ->
2982 getNewRegNCG IntRep `thenUs` \ tmp ->
2984 code = registerCode register tmp
2985 src1 = registerName register tmp
2986 src2 = ImmInt (fromInteger y)
2987 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2989 returnUs (Any IntRep code__2)
2991 trivialCode instr x y
2992 = getRegister x `thenUs` \ register1 ->
2993 getRegister y `thenUs` \ register2 ->
2994 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2995 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2997 code1 = registerCode register1 tmp1 asmVoid
2998 src1 = registerName register1 tmp1
2999 code2 = registerCode register2 tmp2 asmVoid
3000 src2 = registerName register2 tmp2
3001 code__2 dst = asmParThen [code1, code2] .
3002 mkSeqInstr (instr src1 (RIReg src2) dst)
3004 returnUs (Any IntRep code__2)
3007 trivialFCode pk instr x y
3008 = getRegister x `thenUs` \ register1 ->
3009 getRegister y `thenUs` \ register2 ->
3010 getNewRegNCG (registerRep register1)
3012 getNewRegNCG (registerRep register2)
3014 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3016 promote x = asmInstr (FxTOy F DF x tmp)
3018 pk1 = registerRep register1
3019 code1 = registerCode register1 tmp1
3020 src1 = registerName register1 tmp1
3022 pk2 = registerRep register2
3023 code2 = registerCode register2 tmp2
3024 src2 = registerName register2 tmp2
3028 asmParThen [code1 asmVoid, code2 asmVoid] .
3029 mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
3030 else if pk1 == FloatRep then
3031 asmParThen [code1 (promote src1), code2 asmVoid] .
3032 mkSeqInstr (instr DF tmp src2 dst)
3034 asmParThen [code1 asmVoid, code2 (promote src2)] .
3035 mkSeqInstr (instr DF src1 tmp dst)
3037 returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3040 trivialUCode instr x
3041 = getRegister x `thenUs` \ register ->
3042 getNewRegNCG IntRep `thenUs` \ tmp ->
3044 code = registerCode register tmp
3045 src = registerName register tmp
3046 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3048 returnUs (Any IntRep code__2)
3051 trivialUFCode pk instr x
3052 = getRegister x `thenUs` \ register ->
3053 getNewRegNCG pk `thenUs` \ tmp ->
3055 code = registerCode register tmp
3056 src = registerName register tmp
3057 code__2 dst = code . mkSeqInstr (instr src dst)
3059 returnUs (Any pk code__2)
3061 #endif {- sparc_TARGET_ARCH -}
3064 %************************************************************************
3066 \subsubsection{Coercing to/from integer/floating-point...}
3068 %************************************************************************
3070 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3071 to be generated. Here we just change the type on the Register passed
3072 on up. The code is machine-independent.
3074 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3075 conversions. We have to store temporaries in memory to move
3076 between the integer and the floating point register sets.
3079 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
3080 coerceFltCode :: StixTree -> UniqSM Register
3082 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
3083 coerceFP2Int :: StixTree -> UniqSM Register
3086 = getRegister x `thenUs` \ register ->
3089 Fixed _ reg code -> Fixed pk reg code
3090 Any _ code -> Any pk code
3095 = getRegister x `thenUs` \ register ->
3098 Fixed _ reg code -> Fixed DoubleRep reg code
3099 Any _ code -> Any DoubleRep code
3104 #if alpha_TARGET_ARCH
3107 = getRegister x `thenUs` \ register ->
3108 getNewRegNCG IntRep `thenUs` \ reg ->
3110 code = registerCode register reg
3111 src = registerName register reg
3113 code__2 dst = code . mkSeqInstrs [
3115 LD TF dst (spRel 0),
3118 returnUs (Any DoubleRep code__2)
3122 = getRegister x `thenUs` \ register ->
3123 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3125 code = registerCode register tmp
3126 src = registerName register tmp
3128 code__2 dst = code . mkSeqInstrs [
3130 ST TF tmp (spRel 0),
3133 returnUs (Any IntRep code__2)
3135 #endif {- alpha_TARGET_ARCH -}
3136 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3137 #if i386_TARGET_ARCH
3140 = getRegister x `thenUs` \ register ->
3141 getNewRegNCG IntRep `thenUs` \ reg ->
3143 code = registerCode register reg
3144 src = registerName register reg
3146 code__2 dst = code . mkSeqInstrs [
3147 -- to fix: should spill instead of using R1
3148 MOV L (OpReg src) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
3149 FILD (primRepToSize pk) (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
3151 returnUs (Any pk code__2)
3155 = getRegister x `thenUs` \ register ->
3156 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3158 code = registerCode register tmp
3159 src = registerName register tmp
3160 pk = registerRep register
3162 code__2 dst = code . mkSeqInstrs [
3164 FIST L (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)),
3165 MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
3167 returnUs (Any IntRep code__2)
3169 #endif {- i386_TARGET_ARCH -}
3170 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3171 #if sparc_TARGET_ARCH
3174 = getRegister x `thenUs` \ register ->
3175 getNewRegNCG IntRep `thenUs` \ reg ->
3177 code = registerCode register reg
3178 src = registerName register reg
3180 code__2 dst = code . mkSeqInstrs [
3181 ST W src (spRel (-2)),
3182 LD W (spRel (-2)) dst,
3183 FxTOy W (primRepToSize pk) dst dst]
3185 returnUs (Any pk code__2)
3189 = getRegister x `thenUs` \ register ->
3190 getNewRegNCG IntRep `thenUs` \ reg ->
3191 getNewRegNCG FloatRep `thenUs` \ tmp ->
3193 code = registerCode register reg
3194 src = registerName register reg
3195 pk = registerRep register
3197 code__2 dst = code . mkSeqInstrs [
3198 FxTOy (primRepToSize pk) W src tmp,
3199 ST W tmp (spRel (-2)),
3200 LD W (spRel (-2)) dst]
3202 returnUs (Any IntRep code__2)
3204 #endif {- sparc_TARGET_ARCH -}
3207 %************************************************************************
3209 \subsubsection{Coercing integer to @Char@...}
3211 %************************************************************************
3213 Integer to character conversion. Where applicable, we try to do this
3214 in one step if the original object is in memory.
3217 chrCode :: StixTree -> UniqSM Register
3219 #if alpha_TARGET_ARCH
3222 = getRegister x `thenUs` \ register ->
3223 getNewRegNCG IntRep `thenUs` \ reg ->
3225 code = registerCode register reg
3226 src = registerName register reg
3227 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3229 returnUs (Any IntRep code__2)
3231 #endif {- alpha_TARGET_ARCH -}
3232 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3233 #if i386_TARGET_ARCH
3236 = getRegister x `thenUs` \ register ->
3237 --getNewRegNCG IntRep `thenUs` \ reg ->
3239 -- fixedname = registerName register eax
3241 code = registerCode register dst
3242 src = registerName register dst
3244 if isFixed register && src /= dst
3245 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3246 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3247 else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3249 returnUs (Any IntRep code__2)
3251 #endif {- i386_TARGET_ARCH -}
3252 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3253 #if sparc_TARGET_ARCH
3255 chrCode (StInd pk mem)
3256 = getAmode mem `thenUs` \ amode ->
3258 code = amodeCode amode
3259 src = amodeAddr amode
3260 src_off = addrOffset src 3
3261 src__2 = case src_off of Just x -> x
3262 code__2 dst = if maybeToBool src_off then
3263 code . mkSeqInstr (LD BU src__2 dst)
3265 code . mkSeqInstrs [
3266 LD (primRepToSize pk) src dst,
3267 AND False dst (RIImm (ImmInt 255)) dst]
3269 returnUs (Any pk code__2)
3272 = getRegister x `thenUs` \ register ->
3273 getNewRegNCG IntRep `thenUs` \ reg ->
3275 code = registerCode register reg
3276 src = registerName register reg
3277 code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3279 returnUs (Any IntRep code__2)
3281 #endif {- sparc_TARGET_ARCH -}
3284 %************************************************************************
3286 \subsubsection{Absolute value on integers}
3288 %************************************************************************
3290 Absolute value on integers, mostly for gmp size check macros. Again,
3291 the argument cannot be an StInt, because genericOpt already folded
3294 If applicable, do not fill the delay slots here; you will confuse the
3298 absIntCode :: StixTree -> UniqSM Register
3300 #if alpha_TARGET_ARCH
3301 absIntCode = panic "MachCode.absIntCode: not on Alphas"
3302 #endif {- alpha_TARGET_ARCH -}
3304 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3305 #if i386_TARGET_ARCH
3308 = getRegister x `thenUs` \ register ->
3309 --getNewRegNCG IntRep `thenUs` \ reg ->
3310 getUniqLabelNCG `thenUs` \ lbl ->
3312 code__2 dst = let code = registerCode register dst
3313 src = registerName register dst
3314 in code . if isFixed register && dst /= src
3315 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3316 TEST L (OpReg dst) (OpReg dst),
3320 else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
3325 returnUs (Any IntRep code__2)
3327 #endif {- i386_TARGET_ARCH -}
3328 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3329 #if sparc_TARGET_ARCH
3332 = getRegister x `thenUs` \ register ->
3333 getNewRegNCG IntRep `thenUs` \ reg ->
3334 getUniqLabelNCG `thenUs` \ lbl ->
3336 code = registerCode register reg
3337 src = registerName register reg
3338 code__2 dst = code . mkSeqInstrs [
3339 SUB False True g0 (RIReg src) dst,
3340 BI GE False (ImmCLbl lbl), NOP,
3341 OR False g0 (RIReg src) dst,
3344 returnUs (Any IntRep code__2)
3346 #endif {- sparc_TARGET_ARCH -}