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 CLabel ( isAsmTemp, CLabel )
23 import Maybes ( maybeToBool, expectJust )
24 import OrdList -- quite a bit of it
25 import PrimRep ( isFloatingRep, PrimRep(..) )
26 import PrimOp ( PrimOp(..), showPrimOp )
27 import Stix ( getUniqLabelNCG, StixTree(..),
28 StixReg(..), CodeSegment(..)
30 import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
36 Code extractor for an entire stix tree---stix statement level.
39 stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock
41 stmt2Instrs stmt = case stmt of
42 StComment s -> returnInstr (COMMENT s)
43 StSegment seg -> returnInstr (SEGMENT seg)
44 StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab))
45 StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id)
46 StLabel lab -> returnInstr (LABEL lab)
48 StJump arg -> genJump arg
49 StCondJump lab arg -> genCondJump lab arg
50 StCall fn VoidRep args -> genCCall fn VoidRep args
53 | isFloatingRep pk -> assignFltCode pk dst src
54 | otherwise -> assignIntCode pk dst src
57 -- When falling through on the Alpha, we still have to load pv
58 -- with the address of the next routine, so that it can load gp.
59 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
63 -> mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
64 returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms))
65 (foldr1 (.) codes xs))
67 getData :: StixTree -> UniqSM (InstrBlock, Imm)
69 getData (StInt i) = returnUs (id, ImmInteger i)
70 getData (StDouble d) = returnUs (id, dblImmLit d)
71 getData (StLitLbl s) = returnUs (id, ImmLab s)
72 getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
73 getData (StCLbl l) = returnUs (id, ImmCLbl l)
74 getData (StString s) =
75 getUniqLabelNCG `thenUs` \ lbl ->
76 returnUs (mkSeqInstrs [LABEL lbl,
77 ASCII True (_UNPK_ s)],
81 %************************************************************************
83 \subsection{General things for putting together code sequences}
85 %************************************************************************
88 type InstrList = OrdList Instr
89 type InstrBlock = InstrList -> InstrList
94 asmInstr :: Instr -> InstrList
95 asmInstr i = mkUnitList i
97 asmSeq :: [Instr] -> InstrList
98 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
100 asmParThen :: [InstrList] -> InstrBlock
101 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
103 returnInstr :: Instr -> UniqSM InstrBlock
104 returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
106 returnInstrs :: [Instr] -> UniqSM InstrBlock
107 returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
109 returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock
110 returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
112 mkSeqInstr :: Instr -> InstrBlock
113 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
115 mkSeqInstrs :: [Instr] -> InstrBlock
116 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
120 mangleIndexTree :: StixTree -> StixTree
122 mangleIndexTree (StIndex pk base (StInt i))
123 = StPrim IntAddOp [base, off]
125 off = StInt (i * sizeOf pk)
127 #ifndef i386_TARGET_ARCH
128 mangleIndexTree (StIndex pk base off)
129 = StPrim IntAddOp [base,
135 ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
136 StPrim SllOp [off, StInt s]
139 shift DoubleRep = 3::Integer
140 shift _ = IF_ARCH_alpha(3,2)
142 -- Hmm..this is an attempt at fixing Adress amodes (i.e., *[disp](base,index,<n>),
143 -- that do include the size of the primitive kind we're addressing. When StIndex
144 -- is expanded to actual code, the index (in units) is by the above code approp.
145 -- shifted to get the no. of bytes. Since Address amodes do contain size info
146 -- explicitly, we disable the shifting for x86s.
147 mangleIndexTree (StIndex pk base off) = StPrim IntAddOp [base, off]
153 maybeImm :: StixTree -> Maybe Imm
155 maybeImm (StLitLbl s) = Just (ImmLab s)
156 maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
157 maybeImm (StCLbl l) = Just (ImmCLbl l)
160 | i >= toInteger minInt && i <= toInteger maxInt
161 = Just (ImmInt (fromInteger i))
163 = Just (ImmInteger i)
168 %************************************************************************
170 \subsection{The @Register@ type}
172 %************************************************************************
174 @Register@s passed up the tree. If the stix code forces the register
175 to live in a pre-decided machine register, it comes out as @Fixed@;
176 otherwise, it comes out as @Any@, and the parent can decide which
177 register to put it in.
181 = Fixed PrimRep Reg InstrBlock
182 | Any PrimRep (Reg -> InstrBlock)
184 registerCode :: Register -> Reg -> InstrBlock
185 registerCode (Fixed _ _ code) reg = code
186 registerCode (Any _ code) reg = code reg
188 registerName :: Register -> Reg -> Reg
189 registerName (Fixed _ reg _) _ = reg
190 registerName (Any _ _) reg = reg
192 registerRep :: Register -> PrimRep
193 registerRep (Fixed pk _ _) = pk
194 registerRep (Any pk _) = pk
196 isFixed :: Register -> Bool
197 isFixed (Fixed _ _ _) = True
198 isFixed (Any _ _) = False
201 Generate code to get a subtree into a @Register@:
203 getRegister :: StixTree -> UniqSM Register
205 getRegister (StReg (StixMagicId stgreg))
206 = case (magicIdRegMaybe stgreg) of
207 Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id)
210 getRegister (StReg (StixTemp u pk))
211 = returnUs (Fixed pk (UnmappedReg u pk) id)
213 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
215 getRegister (StCall fn kind args)
216 = genCCall fn kind args `thenUs` \ call ->
217 returnUs (Fixed kind reg call)
219 reg = if isFloatingRep kind
220 then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,)))
221 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
223 getRegister (StString s)
224 = getUniqLabelNCG `thenUs` \ lbl ->
226 imm_lbl = ImmCLbl lbl
228 code dst = mkSeqInstrs [
231 ASCII True (_UNPK_ s),
233 #if alpha_TARGET_ARCH
234 LDA dst (AddrImm imm_lbl)
237 MOV L (OpImm imm_lbl) (OpReg dst)
239 #if sparc_TARGET_ARCH
240 SETHI (HI imm_lbl) dst,
241 OR False dst (RIImm (LO imm_lbl)) dst
245 returnUs (Any PtrRep code)
247 getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"'
248 = getUniqLabelNCG `thenUs` \ lbl ->
250 imm_lbl = ImmCLbl lbl
252 code dst = mkSeqInstrs [
255 ASCII False (init xs),
257 #if alpha_TARGET_ARCH
258 LDA dst (AddrImm imm_lbl)
261 MOV L (OpImm imm_lbl) (OpReg dst)
263 #if sparc_TARGET_ARCH
264 SETHI (HI imm_lbl) dst,
265 OR False dst (RIImm (LO imm_lbl)) dst
269 returnUs (Any PtrRep code)
271 xs = _UNPK_ (_TAIL_ s)
273 -- end of machine-"independent" bit; here we go on the rest...
275 #if alpha_TARGET_ARCH
277 getRegister (StDouble d)
278 = getUniqLabelNCG `thenUs` \ lbl ->
279 getNewRegNCG PtrRep `thenUs` \ tmp ->
280 let code dst = mkSeqInstrs [
283 DATA TF [ImmLab (rational d)],
285 LDA tmp (AddrImm (ImmCLbl lbl)),
286 LD TF dst (AddrReg tmp)]
288 returnUs (Any DoubleRep code)
290 getRegister (StPrim primop [x]) -- unary PrimOps
292 IntNegOp -> trivialUCode (NEG Q False) x
293 IntAbsOp -> trivialUCode (ABS Q) x
295 NotOp -> trivialUCode NOT x
297 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
298 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
300 OrdOp -> coerceIntCode IntRep x
303 Float2IntOp -> coerceFP2Int x
304 Int2FloatOp -> coerceInt2FP pr x
305 Double2IntOp -> coerceFP2Int x
306 Int2DoubleOp -> coerceInt2FP pr x
308 Double2FloatOp -> coerceFltCode x
309 Float2DoubleOp -> coerceFltCode x
311 other_op -> getRegister (StCall fn DoubleRep [x])
313 fn = case other_op of
314 FloatExpOp -> SLIT("exp")
315 FloatLogOp -> SLIT("log")
316 FloatSqrtOp -> SLIT("sqrt")
317 FloatSinOp -> SLIT("sin")
318 FloatCosOp -> SLIT("cos")
319 FloatTanOp -> SLIT("tan")
320 FloatAsinOp -> SLIT("asin")
321 FloatAcosOp -> SLIT("acos")
322 FloatAtanOp -> SLIT("atan")
323 FloatSinhOp -> SLIT("sinh")
324 FloatCoshOp -> SLIT("cosh")
325 FloatTanhOp -> SLIT("tanh")
326 DoubleExpOp -> SLIT("exp")
327 DoubleLogOp -> SLIT("log")
328 DoubleSqrtOp -> SLIT("sqrt")
329 DoubleSinOp -> SLIT("sin")
330 DoubleCosOp -> SLIT("cos")
331 DoubleTanOp -> SLIT("tan")
332 DoubleAsinOp -> SLIT("asin")
333 DoubleAcosOp -> SLIT("acos")
334 DoubleAtanOp -> SLIT("atan")
335 DoubleSinhOp -> SLIT("sinh")
336 DoubleCoshOp -> SLIT("cosh")
337 DoubleTanhOp -> SLIT("tanh")
339 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
341 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
343 CharGtOp -> trivialCode (CMP LTT) y x
344 CharGeOp -> trivialCode (CMP LE) y x
345 CharEqOp -> trivialCode (CMP EQQ) x y
346 CharNeOp -> int_NE_code x y
347 CharLtOp -> trivialCode (CMP LTT) x y
348 CharLeOp -> trivialCode (CMP LE) x y
350 IntGtOp -> trivialCode (CMP LTT) y x
351 IntGeOp -> trivialCode (CMP LE) y x
352 IntEqOp -> trivialCode (CMP EQQ) x y
353 IntNeOp -> int_NE_code x y
354 IntLtOp -> trivialCode (CMP LTT) x y
355 IntLeOp -> trivialCode (CMP LE) x y
357 WordGtOp -> trivialCode (CMP ULT) y x
358 WordGeOp -> trivialCode (CMP ULE) x y
359 WordEqOp -> trivialCode (CMP EQQ) x y
360 WordNeOp -> int_NE_code x y
361 WordLtOp -> trivialCode (CMP ULT) x y
362 WordLeOp -> trivialCode (CMP ULE) x y
364 AddrGtOp -> trivialCode (CMP ULT) y x
365 AddrGeOp -> trivialCode (CMP ULE) y x
366 AddrEqOp -> trivialCode (CMP EQQ) x y
367 AddrNeOp -> int_NE_code x y
368 AddrLtOp -> trivialCode (CMP ULT) x y
369 AddrLeOp -> trivialCode (CMP ULE) x y
371 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
372 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
373 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
374 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
375 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
376 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
378 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
379 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
380 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
381 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
382 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
383 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
385 IntAddOp -> trivialCode (ADD Q False) x y
386 IntSubOp -> trivialCode (SUB Q False) x y
387 IntMulOp -> trivialCode (MUL Q False) x y
388 IntQuotOp -> trivialCode (DIV Q False) x y
389 IntRemOp -> trivialCode (REM Q False) x y
391 WordQuotOp -> trivialCode (DIV Q True) x y
392 WordRemOp -> trivialCode (REM Q True) x y
394 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
395 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
396 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
397 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
399 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
400 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
401 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
402 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
404 AndOp -> trivialCode AND x y
405 OrOp -> trivialCode OR x y
406 XorOp -> trivialCode XOR x y
407 SllOp -> trivialCode SLL x y
408 SraOp -> trivialCode SRA x y
409 SrlOp -> trivialCode SRL x y
411 ISllOp -> panic "AlphaGen:isll"
412 ISraOp -> panic "AlphaGen:isra"
413 ISrlOp -> panic "AlphaGen:isrl"
415 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
416 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
418 {- ------------------------------------------------------------
419 Some bizarre special code for getting condition codes into
420 registers. Integer non-equality is a test for equality
421 followed by an XOR with 1. (Integer comparisons always set
422 the result register to 0 or 1.) Floating point comparisons of
423 any kind leave the result in a floating point register, so we
424 need to wrangle an integer register out of things.
426 int_NE_code :: StixTree -> StixTree -> UniqSM Register
429 = trivialCode (CMP EQQ) x y `thenUs` \ register ->
430 getNewRegNCG IntRep `thenUs` \ tmp ->
432 code = registerCode register tmp
433 src = registerName register tmp
434 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
436 returnUs (Any IntRep code__2)
438 {- ------------------------------------------------------------
439 Comments for int_NE_code also apply to cmpF_code
442 :: (Reg -> Reg -> Reg -> Instr)
444 -> StixTree -> StixTree
447 cmpF_code instr cond x y
448 = trivialFCode pr instr x y `thenUs` \ register ->
449 getNewRegNCG DoubleRep `thenUs` \ tmp ->
450 getUniqLabelNCG `thenUs` \ lbl ->
452 code = registerCode register tmp
453 result = registerName register tmp
455 code__2 dst = code . mkSeqInstrs [
456 OR zeroh (RIImm (ImmInt 1)) dst,
457 BF cond result (ImmCLbl lbl),
458 OR zeroh (RIReg zeroh) dst,
461 returnUs (Any IntRep code__2)
463 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
464 ------------------------------------------------------------
466 getRegister (StInd pk mem)
467 = getAmode mem `thenUs` \ amode ->
469 code = amodeCode amode
470 src = amodeAddr amode
471 size = primRepToSize pk
472 code__2 dst = code . mkSeqInstr (LD size dst src)
474 returnUs (Any pk code__2)
476 getRegister (StInt i)
479 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
481 returnUs (Any IntRep code)
484 code dst = mkSeqInstr (LDI Q dst src)
486 returnUs (Any IntRep code)
488 src = ImmInt (fromInteger i)
493 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
495 returnUs (Any PtrRep code)
498 imm__2 = case imm of Just x -> x
500 #endif {- alpha_TARGET_ARCH -}
501 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
504 getRegister (StDouble 0.0)
506 code dst = mkSeqInstrs [FLDZ]
508 returnUs (Any DoubleRep code)
510 getRegister (StDouble 1.0)
512 code dst = mkSeqInstrs [FLD1]
514 returnUs (Any DoubleRep code)
516 getRegister (StDouble d)
517 = getUniqLabelNCG `thenUs` \ lbl ->
518 --getNewRegNCG PtrRep `thenUs` \ tmp ->
519 let code dst = mkSeqInstrs [
522 DATA DF [dblImmLit d],
524 FLD DF (OpImm (ImmCLbl lbl))
527 returnUs (Any DoubleRep code)
529 getRegister (StPrim primop [x]) -- unary PrimOps
531 IntNegOp -> trivialUCode (NEGI L) x
532 IntAbsOp -> absIntCode x
534 NotOp -> trivialUCode (NOT L) x
536 FloatNegOp -> trivialUFCode FloatRep FCHS x
537 FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
538 DoubleNegOp -> trivialUFCode DoubleRep FCHS x
540 DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
542 OrdOp -> coerceIntCode IntRep x
545 Float2IntOp -> coerceFP2Int x
546 Int2FloatOp -> coerceInt2FP FloatRep x
547 Double2IntOp -> coerceFP2Int x
548 Int2DoubleOp -> coerceInt2FP DoubleRep x
550 Double2FloatOp -> coerceFltCode x
551 Float2DoubleOp -> coerceFltCode x
555 fixed_x = if is_float_op -- promote to double
556 then StPrim Float2DoubleOp [x]
559 getRegister (StCall fn DoubleRep [x])
563 FloatExpOp -> (True, SLIT("exp"))
564 FloatLogOp -> (True, SLIT("log"))
566 FloatSinOp -> (True, SLIT("sin"))
567 FloatCosOp -> (True, SLIT("cos"))
568 FloatTanOp -> (True, SLIT("tan"))
570 FloatAsinOp -> (True, SLIT("asin"))
571 FloatAcosOp -> (True, SLIT("acos"))
572 FloatAtanOp -> (True, SLIT("atan"))
574 FloatSinhOp -> (True, SLIT("sinh"))
575 FloatCoshOp -> (True, SLIT("cosh"))
576 FloatTanhOp -> (True, SLIT("tanh"))
578 DoubleExpOp -> (False, SLIT("exp"))
579 DoubleLogOp -> (False, SLIT("log"))
581 DoubleSinOp -> (False, SLIT("sin"))
582 DoubleCosOp -> (False, SLIT("cos"))
583 DoubleTanOp -> (False, SLIT("tan"))
585 DoubleAsinOp -> (False, SLIT("asin"))
586 DoubleAcosOp -> (False, SLIT("acos"))
587 DoubleAtanOp -> (False, SLIT("atan"))
589 DoubleSinhOp -> (False, SLIT("sinh"))
590 DoubleCoshOp -> (False, SLIT("cosh"))
591 DoubleTanhOp -> (False, SLIT("tanh"))
593 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
595 CharGtOp -> condIntReg GTT x y
596 CharGeOp -> condIntReg GE x y
597 CharEqOp -> condIntReg EQQ x y
598 CharNeOp -> condIntReg NE x y
599 CharLtOp -> condIntReg LTT x y
600 CharLeOp -> condIntReg LE x y
602 IntGtOp -> condIntReg GTT x y
603 IntGeOp -> condIntReg GE x y
604 IntEqOp -> condIntReg EQQ x y
605 IntNeOp -> condIntReg NE x y
606 IntLtOp -> condIntReg LTT x y
607 IntLeOp -> condIntReg LE x y
609 WordGtOp -> condIntReg GU x y
610 WordGeOp -> condIntReg GEU x y
611 WordEqOp -> condIntReg EQQ x y
612 WordNeOp -> condIntReg NE x y
613 WordLtOp -> condIntReg LU x y
614 WordLeOp -> condIntReg LEU x y
616 AddrGtOp -> condIntReg GU x y
617 AddrGeOp -> condIntReg GEU x y
618 AddrEqOp -> condIntReg EQQ x y
619 AddrNeOp -> condIntReg NE x y
620 AddrLtOp -> condIntReg LU x y
621 AddrLeOp -> condIntReg LEU x y
623 FloatGtOp -> condFltReg GTT x y
624 FloatGeOp -> condFltReg GE x y
625 FloatEqOp -> condFltReg EQQ x y
626 FloatNeOp -> condFltReg NE x y
627 FloatLtOp -> condFltReg LTT x y
628 FloatLeOp -> condFltReg LE x y
630 DoubleGtOp -> condFltReg GTT x y
631 DoubleGeOp -> condFltReg GE x y
632 DoubleEqOp -> condFltReg EQQ x y
633 DoubleNeOp -> condFltReg NE x y
634 DoubleLtOp -> condFltReg LTT x y
635 DoubleLeOp -> condFltReg LE x y
637 IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)...
638 -- this should be optimised by the generic Opts,
639 -- I don't know why it is not (sometimes)!
641 [x, StInt 0] -> getRegister x
646 IntSubOp -> sub_code L x y
647 IntQuotOp -> quot_code L x y True{-division-}
648 IntRemOp -> quot_code L x y False{-remainder-}
649 IntMulOp -> trivialCode (IMUL L) x y {-True-}
651 FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y
652 FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y
653 FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y
654 FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y
656 DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y
657 DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y
658 DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y
659 DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y
661 AndOp -> trivialCode (AND L) x y {-True-}
662 OrOp -> trivialCode (OR L) x y {-True-}
663 XorOp -> trivialCode (XOR L) x y {-True-}
665 {- Shift ops on x86s have constraints on their source, it
666 either has to be Imm, CL or 1
667 => trivialCode's is not restrictive enough (sigh.)
670 SllOp -> shift_code (SHL L) x y {-False-}
671 SraOp -> shift_code (SAR L) x y {-False-}
672 SrlOp -> shift_code (SHR L) x y {-False-}
675 ISllOp -> panic "I386Gen:isll"
676 ISraOp -> panic "I386Gen:isra"
677 ISrlOp -> panic "I386Gen:isrl"
679 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
680 where promote x = StPrim Float2DoubleOp [x]
681 DoublePowerOp -> getRegister (StCall SLIT("pow") 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 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 SraOp -> trivialCode SRA x y
1077 SrlOp -> trivialCode SRL x y
1079 ISllOp -> panic "SparcGen:isll"
1080 ISraOp -> panic "SparcGen:isra"
1081 ISrlOp -> panic "SparcGen:isrl"
1083 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
1084 where promote x = StPrim Float2DoubleOp [x]
1085 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
1087 imul_div fn x y = getRegister (StCall fn 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
2236 -> PrimRep -- type of the result
2237 -> [StixTree] -- arguments (of mixed type)
2238 -> UniqSM InstrBlock
2240 #if alpha_TARGET_ARCH
2242 genCCall fn kind args
2243 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2244 `thenUs` \ ((unused,_), argCode) ->
2246 nRegs = length allArgRegs - length unused
2247 code = asmParThen (map ($ asmVoid) argCode)
2250 LDA pv (AddrImm (ImmLab (ptext fn))),
2251 JSR ra (AddrReg pv) nRegs,
2252 LDGP gp (AddrReg ra)]
2254 ------------------------
2255 {- Try to get a value into a specific register (or registers) for
2256 a call. The first 6 arguments go into the appropriate
2257 argument register (separate registers for integer and floating
2258 point arguments, but used in lock-step), and the remaining
2259 arguments are dumped to the stack, beginning at 0(sp). Our
2260 first argument is a pair of the list of remaining argument
2261 registers to be assigned for this call and the next stack
2262 offset to use for overflowing arguments. This way,
2263 @get_Arg@ can be applied to all of a call's arguments using
2267 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2268 -> StixTree -- Current argument
2269 -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2271 -- We have to use up all of our argument registers first...
2273 get_arg ((iDst,fDst):dsts, offset) arg
2274 = getRegister arg `thenUs` \ register ->
2276 reg = if isFloatingRep pk then fDst else iDst
2277 code = registerCode register reg
2278 src = registerName register reg
2279 pk = registerRep register
2282 if isFloatingRep pk then
2283 ((dsts, offset), if isFixed register then
2284 code . mkSeqInstr (FMOV src fDst)
2287 ((dsts, offset), if isFixed register then
2288 code . mkSeqInstr (OR src (RIReg src) iDst)
2291 -- Once we have run out of argument registers, we move to the
2294 get_arg ([], offset) arg
2295 = getRegister arg `thenUs` \ register ->
2296 getNewRegNCG (registerRep register)
2299 code = registerCode register tmp
2300 src = registerName register tmp
2301 pk = registerRep register
2302 sz = primRepToSize pk
2304 returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2306 #endif {- alpha_TARGET_ARCH -}
2307 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2308 #if i386_TARGET_ARCH
2310 genCCall fn kind [StInt i]
2311 | fn == SLIT ("PerformGC_wrapper")
2313 call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2314 CALL (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))]
2319 = getUniqLabelNCG `thenUs` \ lbl ->
2321 call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2322 MOV L (OpImm (ImmCLbl lbl))
2323 -- this is hardwired
2324 (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 104))),
2325 JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
2331 genCCall fn kind args
2332 = mapUs get_call_arg args `thenUs` \ argCode ->
2336 {- OLD: Since there's no attempt at stealing %esp at the moment,
2337 restoring %esp from MainRegTable.rCstkptr is not done. -- SOF 97/09
2338 (ditto for saving away old-esp in MainRegTable.Hp (!!) )
2339 code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))),
2340 MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
2344 code2 = asmParThen (map ($ asmVoid) (reverse argCode))
2345 call = [CALL fn__2 ,
2346 -- pop args; all args word sized?
2347 ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp) --,
2349 -- Don't restore %esp (see above)
2350 -- MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
2353 returnSeq (code2) call
2355 -- function names that begin with '.' are assumed to be special
2356 -- internally generated names like '.mul,' which don't get an
2357 -- underscore prefix
2358 -- ToDo:needed (WDP 96/03) ???
2359 fn__2 = case (_HEAD_ fn) of
2360 '.' -> ImmLit (ptext fn)
2361 _ -> ImmLab (ptext fn)
2364 get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code
2367 = get_op arg `thenUs` \ (code, op, sz) ->
2368 returnUs (code . mkSeqInstr (PUSH sz op))
2373 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
2376 = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
2378 get_op (StInd pk mem)
2379 = getAmode mem `thenUs` \ amode ->
2381 code = amodeCode amode --asmVoid
2382 addr = amodeAddr amode
2383 sz = primRepToSize pk
2385 returnUs (code, OpAddr addr, sz)
2388 = getRegister op `thenUs` \ register ->
2389 getNewRegNCG (registerRep register)
2392 code = registerCode register tmp
2393 reg = registerName register tmp
2394 pk = registerRep register
2395 sz = primRepToSize pk
2397 returnUs (code, OpReg reg, sz)
2399 #endif {- i386_TARGET_ARCH -}
2400 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2401 #if sparc_TARGET_ARCH
2403 genCCall fn kind args
2404 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2405 `thenUs` \ ((unused,_), argCode) ->
2407 nRegs = length allArgRegs - length unused
2408 call = CALL fn__2 nRegs False
2409 code = asmParThen (map ($ asmVoid) argCode)
2411 returnSeq code [call, NOP]
2413 -- function names that begin with '.' are assumed to be special
2414 -- internally generated names like '.mul,' which don't get an
2415 -- underscore prefix
2416 -- ToDo:needed (WDP 96/03) ???
2417 fn__2 = case (_HEAD_ fn) of
2418 '.' -> ImmLit (ptext fn)
2419 _ -> ImmLab (ptext fn)
2421 ------------------------------------
2422 {- Try to get a value into a specific register (or registers) for
2423 a call. The SPARC calling convention is an absolute
2424 nightmare. The first 6x32 bits of arguments are mapped into
2425 %o0 through %o5, and the remaining arguments are dumped to the
2426 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2427 first argument is a pair of the list of remaining argument
2428 registers to be assigned for this call and the next stack
2429 offset to use for overflowing arguments. This way,
2430 @get_arg@ can be applied to all of a call's arguments using
2434 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2435 -> StixTree -- Current argument
2436 -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2438 -- We have to use up all of our argument registers first...
2440 get_arg (dst:dsts, offset) arg
2441 = getRegister arg `thenUs` \ register ->
2442 getNewRegNCG (registerRep register)
2445 reg = if isFloatingRep pk then tmp else dst
2446 code = registerCode register reg
2447 src = registerName register reg
2448 pk = registerRep register
2450 returnUs (case pk of
2453 [] -> (([], offset + 1), code . mkSeqInstrs [
2454 -- conveniently put the second part in the right stack
2455 -- location, and load the first part into %o5
2456 ST DF src (spRel (offset - 1)),
2457 LD W (spRel (offset - 1)) dst])
2458 (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2459 ST DF src (spRel (-2)),
2460 LD W (spRel (-2)) dst,
2461 LD W (spRel (-1)) dst__2])
2462 FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2463 ST F src (spRel (-2)),
2464 LD W (spRel (-2)) dst])
2465 _ -> ((dsts, offset), if isFixed register then
2466 code . mkSeqInstr (OR False g0 (RIReg src) dst)
2469 -- Once we have run out of argument registers, we move to the
2472 get_arg ([], offset) arg
2473 = getRegister arg `thenUs` \ register ->
2474 getNewRegNCG (registerRep register)
2477 code = registerCode register tmp
2478 src = registerName register tmp
2479 pk = registerRep register
2480 sz = primRepToSize pk
2481 words = if pk == DoubleRep then 2 else 1
2483 returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2485 #endif {- sparc_TARGET_ARCH -}
2488 %************************************************************************
2490 \subsection{Support bits}
2492 %************************************************************************
2494 %************************************************************************
2496 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2498 %************************************************************************
2500 Turn those condition codes into integers now (when they appear on
2501 the right hand side of an assignment).
2503 (If applicable) Do not fill the delay slots here; you will confuse the
2507 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2509 #if alpha_TARGET_ARCH
2510 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2511 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2512 #endif {- alpha_TARGET_ARCH -}
2514 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2515 #if i386_TARGET_ARCH
2518 = condIntCode cond x y `thenUs` \ condition ->
2519 getNewRegNCG IntRep `thenUs` \ tmp ->
2520 --getRegister dst `thenUs` \ register ->
2522 --code2 = registerCode register tmp asmVoid
2523 --dst__2 = registerName register tmp
2524 code = condCode condition
2525 cond = condName condition
2526 -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2527 code__2 dst = code . mkSeqInstrs [
2528 SETCC cond (OpReg tmp),
2529 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2530 MOV L (OpReg tmp) (OpReg dst)]
2532 returnUs (Any IntRep code__2)
2535 = getUniqLabelNCG `thenUs` \ lbl1 ->
2536 getUniqLabelNCG `thenUs` \ lbl2 ->
2537 condFltCode cond x y `thenUs` \ condition ->
2539 code = condCode condition
2540 cond = condName condition
2541 code__2 dst = code . mkSeqInstrs [
2543 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2546 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2549 returnUs (Any IntRep code__2)
2551 #endif {- i386_TARGET_ARCH -}
2552 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2553 #if sparc_TARGET_ARCH
2555 condIntReg EQQ x (StInt 0)
2556 = getRegister x `thenUs` \ register ->
2557 getNewRegNCG IntRep `thenUs` \ tmp ->
2559 code = registerCode register tmp
2560 src = registerName register tmp
2561 code__2 dst = code . mkSeqInstrs [
2562 SUB False True g0 (RIReg src) g0,
2563 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2565 returnUs (Any IntRep code__2)
2568 = getRegister x `thenUs` \ register1 ->
2569 getRegister y `thenUs` \ register2 ->
2570 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2571 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2573 code1 = registerCode register1 tmp1 asmVoid
2574 src1 = registerName register1 tmp1
2575 code2 = registerCode register2 tmp2 asmVoid
2576 src2 = registerName register2 tmp2
2577 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2578 XOR False src1 (RIReg src2) dst,
2579 SUB False True g0 (RIReg dst) g0,
2580 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2582 returnUs (Any IntRep code__2)
2584 condIntReg NE x (StInt 0)
2585 = getRegister x `thenUs` \ register ->
2586 getNewRegNCG IntRep `thenUs` \ tmp ->
2588 code = registerCode register tmp
2589 src = registerName register tmp
2590 code__2 dst = code . mkSeqInstrs [
2591 SUB False True g0 (RIReg src) g0,
2592 ADD True False g0 (RIImm (ImmInt 0)) dst]
2594 returnUs (Any IntRep code__2)
2597 = getRegister x `thenUs` \ register1 ->
2598 getRegister y `thenUs` \ register2 ->
2599 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2600 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2602 code1 = registerCode register1 tmp1 asmVoid
2603 src1 = registerName register1 tmp1
2604 code2 = registerCode register2 tmp2 asmVoid
2605 src2 = registerName register2 tmp2
2606 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2607 XOR False src1 (RIReg src2) dst,
2608 SUB False True g0 (RIReg dst) g0,
2609 ADD True False g0 (RIImm (ImmInt 0)) dst]
2611 returnUs (Any IntRep code__2)
2614 = getUniqLabelNCG `thenUs` \ lbl1 ->
2615 getUniqLabelNCG `thenUs` \ lbl2 ->
2616 condIntCode cond x y `thenUs` \ condition ->
2618 code = condCode condition
2619 cond = condName condition
2620 code__2 dst = code . mkSeqInstrs [
2621 BI cond False (ImmCLbl lbl1), NOP,
2622 OR False g0 (RIImm (ImmInt 0)) dst,
2623 BI ALWAYS False (ImmCLbl lbl2), NOP,
2625 OR False g0 (RIImm (ImmInt 1)) dst,
2628 returnUs (Any IntRep code__2)
2631 = getUniqLabelNCG `thenUs` \ lbl1 ->
2632 getUniqLabelNCG `thenUs` \ lbl2 ->
2633 condFltCode cond x y `thenUs` \ condition ->
2635 code = condCode condition
2636 cond = condName condition
2637 code__2 dst = code . mkSeqInstrs [
2639 BF cond False (ImmCLbl lbl1), NOP,
2640 OR False g0 (RIImm (ImmInt 0)) dst,
2641 BI ALWAYS False (ImmCLbl lbl2), NOP,
2643 OR False g0 (RIImm (ImmInt 1)) dst,
2646 returnUs (Any IntRep code__2)
2648 #endif {- sparc_TARGET_ARCH -}
2651 %************************************************************************
2653 \subsubsection{@trivial*Code@: deal with trivial instructions}
2655 %************************************************************************
2657 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2658 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2659 for constants on the right hand side, because that's where the generic
2660 optimizer will have put them.
2662 Similarly, for unary instructions, we don't have to worry about
2663 matching an StInt as the argument, because genericOpt will already
2664 have handled the constant-folding.
2668 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2669 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2670 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2672 -> StixTree -> StixTree -- the two arguments
2677 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2678 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2680 {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
2681 (Size -> Operand -> Instr)
2682 -> (Size -> Operand -> Instr) {-reversed instr-}
2684 -> Instr {-reversed instr: pop-}
2686 -> StixTree -> StixTree -- the two arguments
2690 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2691 ,IF_ARCH_i386 ((Operand -> Instr)
2692 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2694 -> StixTree -- the one argument
2699 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2700 ,IF_ARCH_i386 (Instr
2701 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2703 -> StixTree -- the one argument
2706 #if alpha_TARGET_ARCH
2708 trivialCode instr x (StInt y)
2710 = getRegister x `thenUs` \ register ->
2711 getNewRegNCG IntRep `thenUs` \ tmp ->
2713 code = registerCode register tmp
2714 src1 = registerName register tmp
2715 src2 = ImmInt (fromInteger y)
2716 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2718 returnUs (Any IntRep code__2)
2720 trivialCode instr x y
2721 = getRegister x `thenUs` \ register1 ->
2722 getRegister y `thenUs` \ register2 ->
2723 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2724 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2726 code1 = registerCode register1 tmp1 asmVoid
2727 src1 = registerName register1 tmp1
2728 code2 = registerCode register2 tmp2 asmVoid
2729 src2 = registerName register2 tmp2
2730 code__2 dst = asmParThen [code1, code2] .
2731 mkSeqInstr (instr src1 (RIReg src2) dst)
2733 returnUs (Any IntRep code__2)
2736 trivialUCode instr x
2737 = getRegister x `thenUs` \ register ->
2738 getNewRegNCG IntRep `thenUs` \ tmp ->
2740 code = registerCode register tmp
2741 src = registerName register tmp
2742 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2744 returnUs (Any IntRep code__2)
2747 trivialFCode _ instr x y
2748 = getRegister x `thenUs` \ register1 ->
2749 getRegister y `thenUs` \ register2 ->
2750 getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
2751 getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
2753 code1 = registerCode register1 tmp1
2754 src1 = registerName register1 tmp1
2756 code2 = registerCode register2 tmp2
2757 src2 = registerName register2 tmp2
2759 code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2760 mkSeqInstr (instr src1 src2 dst)
2762 returnUs (Any DoubleRep code__2)
2764 trivialUFCode _ instr x
2765 = getRegister x `thenUs` \ register ->
2766 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2768 code = registerCode register tmp
2769 src = registerName register tmp
2770 code__2 dst = code . mkSeqInstr (instr src dst)
2772 returnUs (Any DoubleRep code__2)
2774 #endif {- alpha_TARGET_ARCH -}
2775 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2776 #if i386_TARGET_ARCH
2778 trivialCode instr x y
2780 = getRegister x `thenUs` \ register1 ->
2781 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2783 -- fixedname = registerName register1 eax
2784 code__2 dst = let code1 = registerCode register1 dst
2785 src1 = registerName register1 dst
2787 if isFixed register1 && src1 /= dst
2788 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2789 instr (OpImm imm__2) (OpReg dst)]
2791 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
2793 returnUs (Any IntRep code__2)
2796 imm__2 = case imm of Just x -> x
2798 trivialCode instr x y
2800 = getRegister y `thenUs` \ register1 ->
2801 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2803 -- fixedname = registerName register1 eax
2804 code__2 dst = let code1 = registerCode register1 dst
2805 src1 = registerName register1 dst
2807 if isFixed register1 && src1 /= dst
2808 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2809 instr (OpImm imm__2) (OpReg dst)]
2811 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
2813 returnUs (Any IntRep code__2)
2816 imm__2 = case imm of Just x -> x
2818 trivialCode instr x (StInd pk mem)
2819 = getRegister x `thenUs` \ register ->
2820 --getNewRegNCG IntRep `thenUs` \ tmp ->
2821 getAmode mem `thenUs` \ amode ->
2823 -- fixedname = registerName register eax
2824 code2 = amodeCode amode asmVoid
2825 src2 = amodeAddr amode
2826 code__2 dst = let code1 = registerCode register dst asmVoid
2827 src1 = registerName register dst
2828 in asmParThen [code1, code2] .
2829 if isFixed register && src1 /= dst
2830 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2831 instr (OpAddr src2) (OpReg dst)]
2833 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2835 returnUs (Any pk code__2)
2837 trivialCode instr (StInd pk mem) y
2838 = getRegister y `thenUs` \ register ->
2839 --getNewRegNCG IntRep `thenUs` \ tmp ->
2840 getAmode mem `thenUs` \ amode ->
2842 -- fixedname = registerName register eax
2843 code2 = amodeCode amode asmVoid
2844 src2 = amodeAddr amode
2846 code1 = registerCode register dst asmVoid
2847 src1 = registerName register dst
2848 in asmParThen [code1, code2] .
2849 if isFixed register && src1 /= dst
2850 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2851 instr (OpAddr src2) (OpReg dst)]
2853 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2855 returnUs (Any pk code__2)
2857 trivialCode instr x y
2858 = getRegister x `thenUs` \ register1 ->
2859 getRegister y `thenUs` \ register2 ->
2860 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2861 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2863 -- fixedname = registerName register1 eax
2864 code2 = registerCode register2 tmp2 asmVoid
2865 src2 = registerName register2 tmp2
2867 code1 = registerCode register1 dst asmVoid
2868 src1 = registerName register1 dst
2869 in asmParThen [code1, code2] .
2870 if isFixed register1 && src1 /= dst
2871 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2872 instr (OpReg src2) (OpReg dst)]
2874 mkSeqInstr (instr (OpReg src2) (OpReg src1))
2876 returnUs (Any IntRep code__2)
2879 trivialUCode instr x
2880 = getRegister x `thenUs` \ register ->
2881 -- getNewRegNCG IntRep `thenUs` \ tmp ->
2883 -- fixedname = registerName register eax
2885 code = registerCode register dst
2886 src = registerName register dst
2887 in code . if isFixed register && dst /= src
2888 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
2890 else mkSeqInstr (instr (OpReg src))
2892 returnUs (Any IntRep code__2)
2895 trivialFCode pk _ instrr _ _ (StInd pk' mem) y
2896 = getRegister y `thenUs` \ register2 ->
2897 --getNewRegNCG (registerRep register2)
2898 -- `thenUs` \ tmp2 ->
2899 getAmode mem `thenUs` \ amode ->
2901 code1 = amodeCode amode
2902 src1 = amodeAddr amode
2905 code2 = registerCode register2 dst
2906 src2 = registerName register2 dst
2907 in asmParThen [code1 asmVoid,code2 asmVoid] .
2908 mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
2910 returnUs (Any pk code__2)
2912 trivialFCode pk instr _ _ _ x (StInd pk' mem)
2913 = getRegister x `thenUs` \ register1 ->
2914 --getNewRegNCG (registerRep register1)
2915 -- `thenUs` \ tmp1 ->
2916 getAmode mem `thenUs` \ amode ->
2918 code2 = amodeCode amode
2919 src2 = amodeAddr amode
2922 code1 = registerCode register1 dst
2923 src1 = registerName register1 dst
2924 in asmParThen [code2 asmVoid,code1 asmVoid] .
2925 mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
2927 returnUs (Any pk code__2)
2929 trivialFCode pk _ _ _ instrpr x y
2930 = getRegister x `thenUs` \ register1 ->
2931 getRegister y `thenUs` \ register2 ->
2932 --getNewRegNCG (registerRep register1)
2933 -- `thenUs` \ tmp1 ->
2934 --getNewRegNCG (registerRep register2)
2935 -- `thenUs` \ tmp2 ->
2936 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2938 pk1 = registerRep register1
2939 code1 = registerCode register1 st0 --tmp1
2940 src1 = registerName register1 st0 --tmp1
2942 pk2 = registerRep register2
2945 code2 = registerCode register2 dst
2946 src2 = registerName register2 dst
2947 in asmParThen [code1 asmVoid, code2 asmVoid] .
2950 returnUs (Any pk1 code__2)
2953 trivialUFCode pk instr (StInd pk' mem)
2954 = getAmode mem `thenUs` \ amode ->
2956 code = amodeCode amode
2957 src = amodeAddr amode
2958 code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
2961 returnUs (Any pk code__2)
2963 trivialUFCode pk instr x
2964 = getRegister x `thenUs` \ register ->
2965 --getNewRegNCG pk `thenUs` \ tmp ->
2968 code = registerCode register dst
2969 src = registerName register dst
2970 in code . mkSeqInstrs [instr]
2972 returnUs (Any pk code__2)
2974 #endif {- i386_TARGET_ARCH -}
2975 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2976 #if sparc_TARGET_ARCH
2978 trivialCode instr x (StInt y)
2980 = getRegister x `thenUs` \ register ->
2981 getNewRegNCG IntRep `thenUs` \ tmp ->
2983 code = registerCode register tmp
2984 src1 = registerName register tmp
2985 src2 = ImmInt (fromInteger y)
2986 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2988 returnUs (Any IntRep code__2)
2990 trivialCode instr x y
2991 = getRegister x `thenUs` \ register1 ->
2992 getRegister y `thenUs` \ register2 ->
2993 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2994 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2996 code1 = registerCode register1 tmp1 asmVoid
2997 src1 = registerName register1 tmp1
2998 code2 = registerCode register2 tmp2 asmVoid
2999 src2 = registerName register2 tmp2
3000 code__2 dst = asmParThen [code1, code2] .
3001 mkSeqInstr (instr src1 (RIReg src2) dst)
3003 returnUs (Any IntRep code__2)
3006 trivialFCode pk instr x y
3007 = getRegister x `thenUs` \ register1 ->
3008 getRegister y `thenUs` \ register2 ->
3009 getNewRegNCG (registerRep register1)
3011 getNewRegNCG (registerRep register2)
3013 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3015 promote x = asmInstr (FxTOy F DF x tmp)
3017 pk1 = registerRep register1
3018 code1 = registerCode register1 tmp1
3019 src1 = registerName register1 tmp1
3021 pk2 = registerRep register2
3022 code2 = registerCode register2 tmp2
3023 src2 = registerName register2 tmp2
3027 asmParThen [code1 asmVoid, code2 asmVoid] .
3028 mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
3029 else if pk1 == FloatRep then
3030 asmParThen [code1 (promote src1), code2 asmVoid] .
3031 mkSeqInstr (instr DF tmp src2 dst)
3033 asmParThen [code1 asmVoid, code2 (promote src2)] .
3034 mkSeqInstr (instr DF src1 tmp dst)
3036 returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3039 trivialUCode instr x
3040 = getRegister x `thenUs` \ register ->
3041 getNewRegNCG IntRep `thenUs` \ tmp ->
3043 code = registerCode register tmp
3044 src = registerName register tmp
3045 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3047 returnUs (Any IntRep code__2)
3050 trivialUFCode pk instr x
3051 = getRegister x `thenUs` \ register ->
3052 getNewRegNCG pk `thenUs` \ tmp ->
3054 code = registerCode register tmp
3055 src = registerName register tmp
3056 code__2 dst = code . mkSeqInstr (instr src dst)
3058 returnUs (Any pk code__2)
3060 #endif {- sparc_TARGET_ARCH -}
3063 %************************************************************************
3065 \subsubsection{Coercing to/from integer/floating-point...}
3067 %************************************************************************
3069 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3070 to be generated. Here we just change the type on the Register passed
3071 on up. The code is machine-independent.
3073 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3074 conversions. We have to store temporaries in memory to move
3075 between the integer and the floating point register sets.
3078 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
3079 coerceFltCode :: StixTree -> UniqSM Register
3081 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
3082 coerceFP2Int :: StixTree -> UniqSM Register
3085 = getRegister x `thenUs` \ register ->
3088 Fixed _ reg code -> Fixed pk reg code
3089 Any _ code -> Any pk code
3094 = getRegister x `thenUs` \ register ->
3097 Fixed _ reg code -> Fixed DoubleRep reg code
3098 Any _ code -> Any DoubleRep code
3103 #if alpha_TARGET_ARCH
3106 = getRegister x `thenUs` \ register ->
3107 getNewRegNCG IntRep `thenUs` \ reg ->
3109 code = registerCode register reg
3110 src = registerName register reg
3112 code__2 dst = code . mkSeqInstrs [
3114 LD TF dst (spRel 0),
3117 returnUs (Any DoubleRep code__2)
3121 = getRegister x `thenUs` \ register ->
3122 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3124 code = registerCode register tmp
3125 src = registerName register tmp
3127 code__2 dst = code . mkSeqInstrs [
3129 ST TF tmp (spRel 0),
3132 returnUs (Any IntRep code__2)
3134 #endif {- alpha_TARGET_ARCH -}
3135 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3136 #if i386_TARGET_ARCH
3139 = getRegister x `thenUs` \ register ->
3140 getNewRegNCG IntRep `thenUs` \ reg ->
3142 code = registerCode register reg
3143 src = registerName register reg
3145 code__2 dst = code . mkSeqInstrs [
3146 -- to fix: should spill instead of using R1
3147 MOV L (OpReg src) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
3148 FILD (primRepToSize pk) (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
3150 returnUs (Any pk code__2)
3154 = getRegister x `thenUs` \ register ->
3155 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3157 code = registerCode register tmp
3158 src = registerName register tmp
3159 pk = registerRep register
3161 code__2 dst = code . mkSeqInstrs [
3163 FIST L (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)),
3164 MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
3166 returnUs (Any IntRep code__2)
3168 #endif {- i386_TARGET_ARCH -}
3169 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3170 #if sparc_TARGET_ARCH
3173 = getRegister x `thenUs` \ register ->
3174 getNewRegNCG IntRep `thenUs` \ reg ->
3176 code = registerCode register reg
3177 src = registerName register reg
3179 code__2 dst = code . mkSeqInstrs [
3180 ST W src (spRel (-2)),
3181 LD W (spRel (-2)) dst,
3182 FxTOy W (primRepToSize pk) dst dst]
3184 returnUs (Any pk code__2)
3188 = getRegister x `thenUs` \ register ->
3189 getNewRegNCG IntRep `thenUs` \ reg ->
3190 getNewRegNCG FloatRep `thenUs` \ tmp ->
3192 code = registerCode register reg
3193 src = registerName register reg
3194 pk = registerRep register
3196 code__2 dst = code . mkSeqInstrs [
3197 FxTOy (primRepToSize pk) W src tmp,
3198 ST W tmp (spRel (-2)),
3199 LD W (spRel (-2)) dst]
3201 returnUs (Any IntRep code__2)
3203 #endif {- sparc_TARGET_ARCH -}
3206 %************************************************************************
3208 \subsubsection{Coercing integer to @Char@...}
3210 %************************************************************************
3212 Integer to character conversion. Where applicable, we try to do this
3213 in one step if the original object is in memory.
3216 chrCode :: StixTree -> UniqSM Register
3218 #if alpha_TARGET_ARCH
3221 = getRegister x `thenUs` \ register ->
3222 getNewRegNCG IntRep `thenUs` \ reg ->
3224 code = registerCode register reg
3225 src = registerName register reg
3226 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3228 returnUs (Any IntRep code__2)
3230 #endif {- alpha_TARGET_ARCH -}
3231 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3232 #if i386_TARGET_ARCH
3235 = getRegister x `thenUs` \ register ->
3236 --getNewRegNCG IntRep `thenUs` \ reg ->
3238 -- fixedname = registerName register eax
3240 code = registerCode register dst
3241 src = registerName register dst
3243 if isFixed register && src /= dst
3244 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3245 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3246 else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3248 returnUs (Any IntRep code__2)
3250 #endif {- i386_TARGET_ARCH -}
3251 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3252 #if sparc_TARGET_ARCH
3254 chrCode (StInd pk mem)
3255 = getAmode mem `thenUs` \ amode ->
3257 code = amodeCode amode
3258 src = amodeAddr amode
3259 src_off = addrOffset src 3
3260 src__2 = case src_off of Just x -> x
3261 code__2 dst = if maybeToBool src_off then
3262 code . mkSeqInstr (LD BU src__2 dst)
3264 code . mkSeqInstrs [
3265 LD (primRepToSize pk) src dst,
3266 AND False dst (RIImm (ImmInt 255)) dst]
3268 returnUs (Any pk code__2)
3271 = getRegister x `thenUs` \ register ->
3272 getNewRegNCG IntRep `thenUs` \ reg ->
3274 code = registerCode register reg
3275 src = registerName register reg
3276 code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3278 returnUs (Any IntRep code__2)
3280 #endif {- sparc_TARGET_ARCH -}
3283 %************************************************************************
3285 \subsubsection{Absolute value on integers}
3287 %************************************************************************
3289 Absolute value on integers, mostly for gmp size check macros. Again,
3290 the argument cannot be an StInt, because genericOpt already folded
3293 If applicable, do not fill the delay slots here; you will confuse the
3297 absIntCode :: StixTree -> UniqSM Register
3299 #if alpha_TARGET_ARCH
3300 absIntCode = panic "MachCode.absIntCode: not on Alphas"
3301 #endif {- alpha_TARGET_ARCH -}
3303 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3304 #if i386_TARGET_ARCH
3307 = getRegister x `thenUs` \ register ->
3308 --getNewRegNCG IntRep `thenUs` \ reg ->
3309 getUniqLabelNCG `thenUs` \ lbl ->
3311 code__2 dst = let code = registerCode register dst
3312 src = registerName register dst
3313 in code . if isFixed register && dst /= src
3314 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3315 TEST L (OpReg dst) (OpReg dst),
3319 else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
3324 returnUs (Any IntRep code__2)
3326 #endif {- i386_TARGET_ARCH -}
3327 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3328 #if sparc_TARGET_ARCH
3331 = getRegister x `thenUs` \ register ->
3332 getNewRegNCG IntRep `thenUs` \ reg ->
3333 getUniqLabelNCG `thenUs` \ lbl ->
3335 code = registerCode register reg
3336 src = registerName register reg
3337 code__2 dst = code . mkSeqInstrs [
3338 SUB False True g0 (RIReg src) dst,
3339 BI GE False (ImmCLbl lbl), NOP,
3340 OR False g0 (RIReg src) dst,
3343 returnUs (Any IntRep code__2)
3345 #endif {- sparc_TARGET_ARCH -}