2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[MachCode]{Generating machine code}
6 This is a big module, but, if you pay attention to
7 (a) the sectioning, (b) the type signatures, and
8 (c) the \tr{#if blah_TARGET_ARCH} things, the
9 structure should not be too overwhelming.
12 module MachCode ( stmt2Instrs, asmVoid, InstrList ) where
14 #include "HsVersions.h"
15 #include "nativeGen/NCG.h"
17 import MachMisc -- may differ per-platform
20 import AbsCSyn ( MagicId )
21 import AbsCUtils ( magicIdPrimRep )
22 import CallConv ( CallConv )
23 import CLabel ( isAsmTemp, CLabel, pprCLabel_asm )
24 import Maybes ( maybeToBool, expectJust )
25 import OrdList -- quite a bit of it
26 import PrimRep ( isFloatingRep, PrimRep(..) )
27 import PrimOp ( PrimOp(..) )
28 import CallConv ( cCallConv )
29 import Stix ( getUniqLabelNCG, StixTree(..),
30 StixReg(..), CodeSegment(..)
32 import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
38 Code extractor for an entire stix tree---stix statement level.
41 stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock
43 stmt2Instrs stmt = case stmt of
44 StComment s -> returnInstr (COMMENT s)
45 StSegment seg -> returnInstr (SEGMENT seg)
48 -- StFunBegin, normal non-debugging code for all architectures
49 StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab))
51 -- StFunBegin, special tracing code for x86-Linux only
52 -- requires you to supply
53 -- void native_trace ( char* str )
54 StFunBegin lab -> getUniqLabelNCG `thenUs` \ str_lbl ->
55 returnUs (mkSeqInstrs [
57 COMMENT SLIT("begin trace sequence"),
60 ASCII True (showSDoc (pprCLabel_asm lab)),
63 PUSH L (OpImm (ImmCLbl str_lbl)),
64 CALL (ImmLit (text "native_trace")),
65 ADD L (OpImm (ImmInt 4)) (OpReg esp),
67 COMMENT SLIT("end trace sequence")
71 StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id)
72 StLabel lab -> returnInstr (LABEL lab)
74 StJump arg -> genJump arg
75 StCondJump lab arg -> genCondJump lab arg
76 StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args
79 | isFloatingRep pk -> assignFltCode pk dst src
80 | otherwise -> assignIntCode pk dst src
83 -- When falling through on the Alpha, we still have to load pv
84 -- with the address of the next routine, so that it can load gp.
85 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
89 -> mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
90 returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms))
91 (foldr (.) id codes xs))
93 getData :: StixTree -> UniqSM (InstrBlock, Imm)
95 getData (StInt i) = returnUs (id, ImmInteger i)
96 getData (StDouble d) = returnUs (id, ImmDouble d)
97 getData (StLitLbl s) = returnUs (id, ImmLab s)
98 getData (StCLbl l) = returnUs (id, ImmCLbl l)
99 getData (StString s) =
100 getUniqLabelNCG `thenUs` \ lbl ->
101 returnUs (mkSeqInstrs [LABEL lbl,
102 ASCII True (_UNPK_ s)],
104 -- the linker can handle simple arithmetic...
105 getData (StIndex rep (StCLbl lbl) (StInt off)) =
106 returnUs (id, ImmIndex lbl (fromInteger (off * sizeOf rep)))
109 %************************************************************************
111 \subsection{General things for putting together code sequences}
113 %************************************************************************
116 type InstrList = OrdList Instr
117 type InstrBlock = InstrList -> InstrList
120 asmVoid = mkEmptyList
122 asmInstr :: Instr -> InstrList
123 asmInstr i = mkUnitList i
125 asmSeq :: [Instr] -> InstrList
126 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
128 asmParThen :: [InstrList] -> InstrBlock
129 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
131 returnInstr :: Instr -> UniqSM InstrBlock
132 returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
134 returnInstrs :: [Instr] -> UniqSM InstrBlock
135 returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
137 returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock
138 returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
140 mkSeqInstr :: Instr -> InstrBlock
141 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
143 mkSeqInstrs :: [Instr] -> InstrBlock
144 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
148 mangleIndexTree :: StixTree -> StixTree
150 mangleIndexTree (StIndex pk base (StInt i))
151 = StPrim IntAddOp [base, off]
153 off = StInt (i * sizeOf pk)
155 #ifndef i386_TARGET_ARCH
156 mangleIndexTree (StIndex pk base off)
157 = StPrim IntAddOp [base,
163 ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
164 StPrim SllOp [off, StInt s]
167 shift DoubleRep = 3::Integer
168 shift _ = IF_ARCH_alpha(3,2)
170 -- Hmm..this is an attempt at fixing Adress amodes (i.e., *[disp](base,index,<n>),
171 -- that do include the size of the primitive kind we're addressing. When StIndex
172 -- is expanded to actual code, the index (in units) is by the above code approp.
173 -- shifted to get the no. of bytes. Since Address amodes do contain size info
174 -- explicitly, we disable the shifting for x86s.
175 mangleIndexTree (StIndex pk base off) = StPrim IntAddOp [base, off]
181 maybeImm :: StixTree -> Maybe Imm
183 maybeImm (StLitLbl s) = Just (ImmLab s)
184 maybeImm (StCLbl l) = Just (ImmCLbl l)
186 maybeImm (StIndex rep (StCLbl l) (StInt off)) =
187 Just (ImmIndex l (fromInteger (off * sizeOf rep)))
190 | i >= toInteger minInt && i <= toInteger maxInt
191 = Just (ImmInt (fromInteger i))
193 = Just (ImmInteger i)
198 %************************************************************************
200 \subsection{The @Register@ type}
202 %************************************************************************
204 @Register@s passed up the tree. If the stix code forces the register
205 to live in a pre-decided machine register, it comes out as @Fixed@;
206 otherwise, it comes out as @Any@, and the parent can decide which
207 register to put it in.
211 = Fixed PrimRep Reg InstrBlock
212 | Any PrimRep (Reg -> InstrBlock)
214 registerCode :: Register -> Reg -> InstrBlock
215 registerCode (Fixed _ _ code) reg = code
216 registerCode (Any _ code) reg = code reg
218 registerName :: Register -> Reg -> Reg
219 registerName (Fixed _ reg _) _ = reg
220 registerName (Any _ _) reg = reg
222 registerRep :: Register -> PrimRep
223 registerRep (Fixed pk _ _) = pk
224 registerRep (Any pk _) = pk
226 isFixed :: Register -> Bool
227 isFixed (Fixed _ _ _) = True
228 isFixed (Any _ _) = False
231 Generate code to get a subtree into a @Register@:
233 getRegister :: StixTree -> UniqSM Register
235 getRegister (StReg (StixMagicId stgreg))
236 = case (magicIdRegMaybe stgreg) of
237 Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id)
240 getRegister (StReg (StixTemp u pk))
241 = returnUs (Fixed pk (UnmappedReg u pk) id)
243 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
245 getRegister (StCall fn cconv kind args)
246 = genCCall fn cconv kind args `thenUs` \ call ->
247 returnUs (Fixed kind reg call)
249 reg = if isFloatingRep kind
250 then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,)))
251 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
253 getRegister (StString s)
254 = getUniqLabelNCG `thenUs` \ lbl ->
256 imm_lbl = ImmCLbl lbl
258 code dst = mkSeqInstrs [
261 ASCII True (_UNPK_ s),
263 #if alpha_TARGET_ARCH
264 LDA dst (AddrImm imm_lbl)
267 MOV L (OpImm imm_lbl) (OpReg dst)
269 #if sparc_TARGET_ARCH
270 SETHI (HI imm_lbl) dst,
271 OR False dst (RIImm (LO imm_lbl)) dst
275 returnUs (Any PtrRep code)
279 -- end of machine-"independent" bit; here we go on the rest...
281 #if alpha_TARGET_ARCH
283 getRegister (StDouble d)
284 = getUniqLabelNCG `thenUs` \ lbl ->
285 getNewRegNCG PtrRep `thenUs` \ tmp ->
286 let code dst = mkSeqInstrs [
289 DATA TF [ImmLab (rational d)],
291 LDA tmp (AddrImm (ImmCLbl lbl)),
292 LD TF dst (AddrReg tmp)]
294 returnUs (Any DoubleRep code)
296 getRegister (StPrim primop [x]) -- unary PrimOps
298 IntNegOp -> trivialUCode (NEG Q False) x
300 NotOp -> trivialUCode NOT x
302 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
303 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
305 OrdOp -> coerceIntCode IntRep x
308 Float2IntOp -> coerceFP2Int x
309 Int2FloatOp -> coerceInt2FP pr x
310 Double2IntOp -> coerceFP2Int x
311 Int2DoubleOp -> coerceInt2FP pr x
313 Double2FloatOp -> coerceFltCode x
314 Float2DoubleOp -> coerceFltCode x
316 other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
318 fn = case other_op of
319 FloatExpOp -> SLIT("exp")
320 FloatLogOp -> SLIT("log")
321 FloatSqrtOp -> SLIT("sqrt")
322 FloatSinOp -> SLIT("sin")
323 FloatCosOp -> SLIT("cos")
324 FloatTanOp -> SLIT("tan")
325 FloatAsinOp -> SLIT("asin")
326 FloatAcosOp -> SLIT("acos")
327 FloatAtanOp -> SLIT("atan")
328 FloatSinhOp -> SLIT("sinh")
329 FloatCoshOp -> SLIT("cosh")
330 FloatTanhOp -> SLIT("tanh")
331 DoubleExpOp -> SLIT("exp")
332 DoubleLogOp -> SLIT("log")
333 DoubleSqrtOp -> SLIT("sqrt")
334 DoubleSinOp -> SLIT("sin")
335 DoubleCosOp -> SLIT("cos")
336 DoubleTanOp -> SLIT("tan")
337 DoubleAsinOp -> SLIT("asin")
338 DoubleAcosOp -> SLIT("acos")
339 DoubleAtanOp -> SLIT("atan")
340 DoubleSinhOp -> SLIT("sinh")
341 DoubleCoshOp -> SLIT("cosh")
342 DoubleTanhOp -> SLIT("tanh")
344 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
346 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
348 CharGtOp -> trivialCode (CMP LTT) y x
349 CharGeOp -> trivialCode (CMP LE) y x
350 CharEqOp -> trivialCode (CMP EQQ) x y
351 CharNeOp -> int_NE_code x y
352 CharLtOp -> trivialCode (CMP LTT) x y
353 CharLeOp -> trivialCode (CMP LE) x y
355 IntGtOp -> trivialCode (CMP LTT) y x
356 IntGeOp -> trivialCode (CMP LE) y x
357 IntEqOp -> trivialCode (CMP EQQ) x y
358 IntNeOp -> int_NE_code x y
359 IntLtOp -> trivialCode (CMP LTT) x y
360 IntLeOp -> trivialCode (CMP LE) x y
362 WordGtOp -> trivialCode (CMP ULT) y x
363 WordGeOp -> trivialCode (CMP ULE) x y
364 WordEqOp -> trivialCode (CMP EQQ) x y
365 WordNeOp -> int_NE_code x y
366 WordLtOp -> trivialCode (CMP ULT) x y
367 WordLeOp -> trivialCode (CMP ULE) x y
369 AddrGtOp -> trivialCode (CMP ULT) y x
370 AddrGeOp -> trivialCode (CMP ULE) y x
371 AddrEqOp -> trivialCode (CMP EQQ) x y
372 AddrNeOp -> int_NE_code x y
373 AddrLtOp -> trivialCode (CMP ULT) x y
374 AddrLeOp -> trivialCode (CMP ULE) x y
376 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
377 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
378 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
379 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
380 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
381 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
383 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
384 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
385 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
386 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
387 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
388 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
390 IntAddOp -> trivialCode (ADD Q False) x y
391 IntSubOp -> trivialCode (SUB Q False) x y
392 IntMulOp -> trivialCode (MUL Q False) x y
393 IntQuotOp -> trivialCode (DIV Q False) x y
394 IntRemOp -> trivialCode (REM Q False) x y
396 WordQuotOp -> trivialCode (DIV Q True) x y
397 WordRemOp -> trivialCode (REM Q True) x y
399 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
400 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
401 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
402 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
404 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
405 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
406 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
407 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
409 AndOp -> trivialCode AND x y
410 OrOp -> trivialCode OR x y
411 XorOp -> trivialCode XOR x y
412 SllOp -> trivialCode SLL x y
413 SrlOp -> trivialCode SRL x y
415 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
416 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
417 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
419 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
420 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
422 {- ------------------------------------------------------------
423 Some bizarre special code for getting condition codes into
424 registers. Integer non-equality is a test for equality
425 followed by an XOR with 1. (Integer comparisons always set
426 the result register to 0 or 1.) Floating point comparisons of
427 any kind leave the result in a floating point register, so we
428 need to wrangle an integer register out of things.
430 int_NE_code :: StixTree -> StixTree -> UniqSM Register
433 = trivialCode (CMP EQQ) x y `thenUs` \ register ->
434 getNewRegNCG IntRep `thenUs` \ tmp ->
436 code = registerCode register tmp
437 src = registerName register tmp
438 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
440 returnUs (Any IntRep code__2)
442 {- ------------------------------------------------------------
443 Comments for int_NE_code also apply to cmpF_code
446 :: (Reg -> Reg -> Reg -> Instr)
448 -> StixTree -> StixTree
451 cmpF_code instr cond x y
452 = trivialFCode pr instr x y `thenUs` \ register ->
453 getNewRegNCG DoubleRep `thenUs` \ tmp ->
454 getUniqLabelNCG `thenUs` \ lbl ->
456 code = registerCode register tmp
457 result = registerName register tmp
459 code__2 dst = code . mkSeqInstrs [
460 OR zeroh (RIImm (ImmInt 1)) dst,
461 BF cond result (ImmCLbl lbl),
462 OR zeroh (RIReg zeroh) dst,
465 returnUs (Any IntRep code__2)
467 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
468 ------------------------------------------------------------
470 getRegister (StInd pk mem)
471 = getAmode mem `thenUs` \ amode ->
473 code = amodeCode amode
474 src = amodeAddr amode
475 size = primRepToSize pk
476 code__2 dst = code . mkSeqInstr (LD size dst src)
478 returnUs (Any pk code__2)
480 getRegister (StInt i)
483 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
485 returnUs (Any IntRep code)
488 code dst = mkSeqInstr (LDI Q dst src)
490 returnUs (Any IntRep code)
492 src = ImmInt (fromInteger i)
497 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
499 returnUs (Any PtrRep code)
502 imm__2 = case imm of Just x -> x
504 #endif {- alpha_TARGET_ARCH -}
505 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
508 getRegister (StDouble 0.0)
510 code dst = mkSeqInstrs [FLDZ]
512 returnUs (Any DoubleRep code)
514 getRegister (StDouble 1.0)
516 code dst = mkSeqInstrs [FLD1]
518 returnUs (Any DoubleRep code)
520 getRegister (StDouble d)
521 = getUniqLabelNCG `thenUs` \ lbl ->
522 --getNewRegNCG PtrRep `thenUs` \ tmp ->
523 let code dst = mkSeqInstrs [
526 DATA DF [ImmDouble d],
528 FLD DF (OpImm (ImmCLbl lbl))
531 returnUs (Any DoubleRep code)
533 getRegister (StPrim primop [x]) -- unary PrimOps
535 IntNegOp -> trivialUCode (NEGI L) x
537 NotOp -> trivialUCode (NOT L) x
539 FloatNegOp -> trivialUFCode FloatRep FCHS x
540 FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
541 DoubleNegOp -> trivialUFCode DoubleRep FCHS x
543 DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
545 OrdOp -> coerceIntCode IntRep x
548 Float2IntOp -> coerceFP2Int x
549 Int2FloatOp -> coerceInt2FP FloatRep x
550 Double2IntOp -> coerceFP2Int x
551 Int2DoubleOp -> coerceInt2FP DoubleRep x
553 Double2FloatOp -> coerceFltCode x
554 Float2DoubleOp -> coerceFltCode x
558 fixed_x = if is_float_op -- promote to double
559 then StPrim Float2DoubleOp [x]
562 getRegister (StCall fn cCallConv DoubleRep [x])
566 FloatExpOp -> (True, SLIT("exp"))
567 FloatLogOp -> (True, SLIT("log"))
569 FloatSinOp -> (True, SLIT("sin"))
570 FloatCosOp -> (True, SLIT("cos"))
571 FloatTanOp -> (True, SLIT("tan"))
573 FloatAsinOp -> (True, SLIT("asin"))
574 FloatAcosOp -> (True, SLIT("acos"))
575 FloatAtanOp -> (True, SLIT("atan"))
577 FloatSinhOp -> (True, SLIT("sinh"))
578 FloatCoshOp -> (True, SLIT("cosh"))
579 FloatTanhOp -> (True, SLIT("tanh"))
581 DoubleExpOp -> (False, SLIT("exp"))
582 DoubleLogOp -> (False, SLIT("log"))
584 DoubleSinOp -> (False, SLIT("sin"))
585 DoubleCosOp -> (False, SLIT("cos"))
586 DoubleTanOp -> (False, SLIT("tan"))
588 DoubleAsinOp -> (False, SLIT("asin"))
589 DoubleAcosOp -> (False, SLIT("acos"))
590 DoubleAtanOp -> (False, SLIT("atan"))
592 DoubleSinhOp -> (False, SLIT("sinh"))
593 DoubleCoshOp -> (False, SLIT("cosh"))
594 DoubleTanhOp -> (False, SLIT("tanh"))
596 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
598 CharGtOp -> condIntReg GTT x y
599 CharGeOp -> condIntReg GE x y
600 CharEqOp -> condIntReg EQQ x y
601 CharNeOp -> condIntReg NE x y
602 CharLtOp -> condIntReg LTT x y
603 CharLeOp -> condIntReg LE x y
605 IntGtOp -> condIntReg GTT x y
606 IntGeOp -> condIntReg GE x y
607 IntEqOp -> condIntReg EQQ x y
608 IntNeOp -> condIntReg NE x y
609 IntLtOp -> condIntReg LTT x y
610 IntLeOp -> condIntReg LE x y
612 WordGtOp -> condIntReg GU x y
613 WordGeOp -> condIntReg GEU x y
614 WordEqOp -> condIntReg EQQ x y
615 WordNeOp -> condIntReg NE x y
616 WordLtOp -> condIntReg LU x y
617 WordLeOp -> condIntReg LEU x y
619 AddrGtOp -> condIntReg GU x y
620 AddrGeOp -> condIntReg GEU x y
621 AddrEqOp -> condIntReg EQQ x y
622 AddrNeOp -> condIntReg NE x y
623 AddrLtOp -> condIntReg LU x y
624 AddrLeOp -> condIntReg LEU x y
626 FloatGtOp -> condFltReg GTT x y
627 FloatGeOp -> condFltReg GE x y
628 FloatEqOp -> condFltReg EQQ x y
629 FloatNeOp -> condFltReg NE x y
630 FloatLtOp -> condFltReg LTT x y
631 FloatLeOp -> condFltReg LE x y
633 DoubleGtOp -> condFltReg GTT x y
634 DoubleGeOp -> condFltReg GE x y
635 DoubleEqOp -> condFltReg EQQ x y
636 DoubleNeOp -> condFltReg NE x y
637 DoubleLtOp -> condFltReg LTT x y
638 DoubleLeOp -> condFltReg LE x y
640 IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)...
641 -- this should be optimised by the generic Opts,
642 -- I don't know why it is not (sometimes)!
644 [x, StInt 0] -> getRegister x
649 IntSubOp -> sub_code L x y
650 IntQuotOp -> quot_code L x y True{-division-}
651 IntRemOp -> quot_code L x y False{-remainder-}
652 IntMulOp -> trivialCode (IMUL L) x y {-True-}
654 FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y
655 FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y
656 FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y
657 FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y
659 DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y
660 DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y
661 DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y
662 DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y
664 AndOp -> trivialCode (AND L) x y {-True-}
665 OrOp -> trivialCode (OR L) x y {-True-}
666 XorOp -> trivialCode (XOR L) x y {-True-}
668 {- Shift ops on x86s have constraints on their source, it
669 either has to be Imm, CL or 1
670 => trivialCode's is not restrictive enough (sigh.)
673 SllOp -> shift_code (SHL L) x y {-False-}
674 SrlOp -> shift_code (SHR L) x y {-False-}
676 ISllOp -> shift_code (SHL L) x y {-False-} --was:panic "I386Gen:isll"
677 ISraOp -> shift_code (SAR L) x y {-False-} --was:panic "I386Gen:isra"
678 ISrlOp -> shift_code (SHR L) x y {-False-} --was:panic "I386Gen:isrl"
680 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
681 where promote x = StPrim Float2DoubleOp [x]
682 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
684 shift_code :: (Operand -> Operand -> Instr)
688 {- Case1: shift length as immediate -}
689 -- Code is the same as the first eq. for trivialCode -- sigh.
690 shift_code instr x y{-amount-}
692 = getRegister x `thenUs` \ register ->
694 op_imm = OpImm imm__2
697 code = registerCode register dst
698 src = registerName register dst
700 mkSeqInstr (COMMENT SLIT("shift_code")) .
702 if isFixed register && src /= dst
704 mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
705 instr op_imm (OpReg dst)]
707 mkSeqInstr (instr op_imm (OpReg src))
709 returnUs (Any IntRep code__2)
712 imm__2 = case imm of Just x -> x
714 {- Case2: shift length is complex (non-immediate) -}
715 shift_code instr x y{-amount-}
716 = getRegister y `thenUs` \ register1 ->
717 getRegister x `thenUs` \ register2 ->
718 -- getNewRegNCG IntRep `thenUs` \ dst ->
720 -- Note: we force the shift length to be loaded
721 -- into ECX, so that we can use CL when shifting.
722 -- (only register location we are allowed
723 -- to put shift amounts.)
725 -- The shift instruction is fed ECX as src reg,
726 -- but we coerce this into CL when printing out.
727 src1 = registerName register1 ecx
728 code1 = if src1 /= ecx then -- if it is not in ecx already, force it!
729 registerCode register1 ecx .
730 mkSeqInstr (MOV L (OpReg src1) (OpReg ecx))
732 registerCode register1 ecx
735 code2 = registerCode register2 eax
736 src2 = registerName register2 eax
739 mkSeqInstr (instr (OpReg ecx) (OpReg eax))
741 returnUs (Fixed IntRep eax code__2)
743 add_code :: Size -> StixTree -> StixTree -> UniqSM Register
745 add_code sz x (StInt y)
746 = getRegister x `thenUs` \ register ->
747 getNewRegNCG IntRep `thenUs` \ tmp ->
749 code = registerCode register tmp
750 src1 = registerName register tmp
751 src2 = ImmInt (fromInteger y)
753 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst))
755 returnUs (Any IntRep code__2)
757 add_code sz x (StInd _ mem)
758 = getRegister x `thenUs` \ register1 ->
759 --getNewRegNCG (registerRep register1)
760 -- `thenUs` \ tmp1 ->
761 getAmode mem `thenUs` \ amode ->
763 code2 = amodeCode amode
764 src2 = amodeAddr amode
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 code__2 dst = let code2 = registerCode register2 dst
787 src2 = registerName register2 dst
788 in asmParThen [code1 asmVoid,code2 asmVoid] .
789 if isFixed register2 && src2 /= dst
790 then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
791 ADD sz (OpAddr src1) (OpReg dst)]
793 mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
795 returnUs (Any IntRep code__2)
798 = getRegister x `thenUs` \ register1 ->
799 getRegister y `thenUs` \ register2 ->
800 getNewRegNCG IntRep `thenUs` \ tmp1 ->
801 getNewRegNCG IntRep `thenUs` \ tmp2 ->
803 code1 = registerCode register1 tmp1 asmVoid
804 src1 = registerName register1 tmp1
805 code2 = registerCode register2 tmp2 asmVoid
806 src2 = registerName register2 tmp2
807 code__2 dst = asmParThen [code1, code2] .
808 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
810 returnUs (Any IntRep code__2)
813 sub_code :: Size -> StixTree -> StixTree -> UniqSM Register
815 sub_code sz x (StInt y)
816 = getRegister x `thenUs` \ register ->
817 getNewRegNCG IntRep `thenUs` \ tmp ->
819 code = registerCode register tmp
820 src1 = registerName register tmp
821 src2 = ImmInt (-(fromInteger y))
823 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst))
825 returnUs (Any IntRep code__2)
827 sub_code sz x y = trivialCode (SUB sz) x y {-False-}
832 -> StixTree -> StixTree
833 -> Bool -- True => division, False => remainder operation
836 -- x must go into eax, edx must be a sign-extension of eax, and y
837 -- should go in some other register (or memory), so that we get
838 -- edx:eax / reg -> eax (remainder in edx) Currently we chose to
839 -- put y in memory (if it is not there already)
841 quot_code sz x (StInd pk mem) is_division
842 = getRegister x `thenUs` \ register1 ->
843 getNewRegNCG IntRep `thenUs` \ tmp1 ->
844 getAmode mem `thenUs` \ amode ->
846 code1 = registerCode register1 tmp1 asmVoid
847 src1 = registerName register1 tmp1
848 code2 = amodeCode amode asmVoid
849 src2 = amodeAddr amode
850 code__2 = asmParThen [code1, code2] .
851 mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
853 IDIV sz (OpAddr src2)]
855 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
857 quot_code sz x (StInt i) is_division
858 = getRegister x `thenUs` \ register1 ->
859 getNewRegNCG IntRep `thenUs` \ tmp1 ->
861 code1 = registerCode register1 tmp1 asmVoid
862 src1 = registerName register1 tmp1
863 src2 = ImmInt (fromInteger i)
864 code__2 = asmParThen [code1] .
865 mkSeqInstrs [-- we put src2 in (ebx)
866 MOV L (OpImm src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
867 MOV L (OpReg src1) (OpReg eax),
869 IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))]
871 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
873 quot_code sz x y is_division
874 = getRegister x `thenUs` \ register1 ->
875 getNewRegNCG IntRep `thenUs` \ tmp1 ->
876 getRegister y `thenUs` \ register2 ->
877 getNewRegNCG IntRep `thenUs` \ tmp2 ->
879 code1 = registerCode register1 tmp1 asmVoid
880 src1 = registerName register1 tmp1
881 code2 = registerCode register2 tmp2 asmVoid
882 src2 = registerName register2 tmp2
883 code__2 = asmParThen [code1, code2] .
884 if src2 == ecx || src2 == esi
885 then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
887 IDIV sz (OpReg src2)]
888 else mkSeqInstrs [ -- we put src2 in (ebx)
889 MOV L (OpReg src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
890 MOV L (OpReg src1) (OpReg eax),
892 IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))]
894 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
895 -----------------------
897 getRegister (StInd pk mem)
898 = getAmode mem `thenUs` \ amode ->
900 code = amodeCode amode
901 src = amodeAddr amode
902 size = primRepToSize pk
904 if pk == DoubleRep || pk == FloatRep
905 then mkSeqInstr (FLD {-DF-} size (OpAddr src))
906 else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
908 returnUs (Any pk code__2)
911 getRegister (StInt i)
913 src = ImmInt (fromInteger i)
914 code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
916 returnUs (Any IntRep code)
921 code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
923 returnUs (Any PtrRep code)
926 imm__2 = case imm of Just x -> x
928 #endif {- i386_TARGET_ARCH -}
929 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
930 #if sparc_TARGET_ARCH
932 getRegister (StDouble d)
933 = getUniqLabelNCG `thenUs` \ lbl ->
934 getNewRegNCG PtrRep `thenUs` \ tmp ->
935 let code dst = mkSeqInstrs [
938 DATA DF [ImmDouble d],
940 SETHI (HI (ImmCLbl lbl)) tmp,
941 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
943 returnUs (Any DoubleRep code)
945 getRegister (StPrim primop [x]) -- unary PrimOps
947 IntNegOp -> trivialUCode (SUB False False g0) x
948 NotOp -> trivialUCode (XNOR False g0) x
950 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
952 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
954 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
955 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
957 OrdOp -> coerceIntCode IntRep x
960 Float2IntOp -> coerceFP2Int x
961 Int2FloatOp -> coerceInt2FP FloatRep x
962 Double2IntOp -> coerceFP2Int x
963 Int2DoubleOp -> coerceInt2FP DoubleRep x
967 fixed_x = if is_float_op -- promote to double
968 then StPrim Float2DoubleOp [x]
971 getRegister (StCall fn cCallConv DoubleRep [x])
975 FloatExpOp -> (True, SLIT("exp"))
976 FloatLogOp -> (True, SLIT("log"))
977 FloatSqrtOp -> (True, SLIT("sqrt"))
979 FloatSinOp -> (True, SLIT("sin"))
980 FloatCosOp -> (True, SLIT("cos"))
981 FloatTanOp -> (True, SLIT("tan"))
983 FloatAsinOp -> (True, SLIT("asin"))
984 FloatAcosOp -> (True, SLIT("acos"))
985 FloatAtanOp -> (True, SLIT("atan"))
987 FloatSinhOp -> (True, SLIT("sinh"))
988 FloatCoshOp -> (True, SLIT("cosh"))
989 FloatTanhOp -> (True, SLIT("tanh"))
991 DoubleExpOp -> (False, SLIT("exp"))
992 DoubleLogOp -> (False, SLIT("log"))
993 DoubleSqrtOp -> (True, SLIT("sqrt"))
995 DoubleSinOp -> (False, SLIT("sin"))
996 DoubleCosOp -> (False, SLIT("cos"))
997 DoubleTanOp -> (False, SLIT("tan"))
999 DoubleAsinOp -> (False, SLIT("asin"))
1000 DoubleAcosOp -> (False, SLIT("acos"))
1001 DoubleAtanOp -> (False, SLIT("atan"))
1003 DoubleSinhOp -> (False, SLIT("sinh"))
1004 DoubleCoshOp -> (False, SLIT("cosh"))
1005 DoubleTanhOp -> (False, SLIT("tanh"))
1006 _ -> panic ("Monadic PrimOp not handled: " ++ show primop)
1008 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
1010 CharGtOp -> condIntReg GTT x y
1011 CharGeOp -> condIntReg GE x y
1012 CharEqOp -> condIntReg EQQ x y
1013 CharNeOp -> condIntReg NE x y
1014 CharLtOp -> condIntReg LTT x y
1015 CharLeOp -> condIntReg LE x y
1017 IntGtOp -> condIntReg GTT x y
1018 IntGeOp -> condIntReg GE x y
1019 IntEqOp -> condIntReg EQQ x y
1020 IntNeOp -> condIntReg NE x y
1021 IntLtOp -> condIntReg LTT x y
1022 IntLeOp -> condIntReg LE x y
1024 WordGtOp -> condIntReg GU x y
1025 WordGeOp -> condIntReg GEU x y
1026 WordEqOp -> condIntReg EQQ x y
1027 WordNeOp -> condIntReg NE x y
1028 WordLtOp -> condIntReg LU x y
1029 WordLeOp -> condIntReg LEU x y
1031 AddrGtOp -> condIntReg GU x y
1032 AddrGeOp -> condIntReg GEU x y
1033 AddrEqOp -> condIntReg EQQ x y
1034 AddrNeOp -> condIntReg NE x y
1035 AddrLtOp -> condIntReg LU x y
1036 AddrLeOp -> condIntReg LEU x y
1038 FloatGtOp -> condFltReg GTT x y
1039 FloatGeOp -> condFltReg GE x y
1040 FloatEqOp -> condFltReg EQQ x y
1041 FloatNeOp -> condFltReg NE x y
1042 FloatLtOp -> condFltReg LTT x y
1043 FloatLeOp -> condFltReg LE x y
1045 DoubleGtOp -> condFltReg GTT x y
1046 DoubleGeOp -> condFltReg GE x y
1047 DoubleEqOp -> condFltReg EQQ x y
1048 DoubleNeOp -> condFltReg NE x y
1049 DoubleLtOp -> condFltReg LTT x y
1050 DoubleLeOp -> condFltReg LE x y
1052 IntAddOp -> trivialCode (ADD False False) x y
1053 IntSubOp -> trivialCode (SUB False False) x y
1055 -- ToDo: teach about V8+ SPARC mul/div instructions
1056 IntMulOp -> imul_div SLIT(".umul") x y
1057 IntQuotOp -> imul_div SLIT(".div") x y
1058 IntRemOp -> imul_div SLIT(".rem") x y
1060 FloatAddOp -> trivialFCode FloatRep FADD x y
1061 FloatSubOp -> trivialFCode FloatRep FSUB x y
1062 FloatMulOp -> trivialFCode FloatRep FMUL x y
1063 FloatDivOp -> trivialFCode FloatRep FDIV x y
1065 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1066 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1067 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1068 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1070 AndOp -> trivialCode (AND False) x y
1071 OrOp -> trivialCode (OR False) x y
1072 XorOp -> trivialCode (XOR False) x y
1073 SllOp -> trivialCode SLL x y
1074 SrlOp -> trivialCode SRL x y
1076 ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
1077 ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
1078 ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
1080 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
1081 where promote x = StPrim Float2DoubleOp [x]
1082 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
1083 -- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
1085 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1087 getRegister (StInd pk mem)
1088 = getAmode mem `thenUs` \ amode ->
1090 code = amodeCode amode
1091 src = amodeAddr amode
1092 size = primRepToSize pk
1093 code__2 dst = code . mkSeqInstr (LD size src dst)
1095 returnUs (Any pk code__2)
1097 getRegister (StInt i)
1100 src = ImmInt (fromInteger i)
1101 code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
1103 returnUs (Any IntRep code)
1108 code dst = mkSeqInstrs [
1109 SETHI (HI imm__2) dst,
1110 OR False dst (RIImm (LO imm__2)) dst]
1112 returnUs (Any PtrRep code)
1115 imm__2 = case imm of Just x -> x
1117 #endif {- sparc_TARGET_ARCH -}
1120 %************************************************************************
1122 \subsection{The @Amode@ type}
1124 %************************************************************************
1126 @Amode@s: Memory addressing modes passed up the tree.
1128 data Amode = Amode MachRegsAddr InstrBlock
1130 amodeAddr (Amode addr _) = addr
1131 amodeCode (Amode _ code) = code
1134 Now, given a tree (the argument to an StInd) that references memory,
1135 produce a suitable addressing mode.
1138 getAmode :: StixTree -> UniqSM Amode
1140 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1142 #if alpha_TARGET_ARCH
1144 getAmode (StPrim IntSubOp [x, StInt i])
1145 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1146 getRegister x `thenUs` \ register ->
1148 code = registerCode register tmp
1149 reg = registerName register tmp
1150 off = ImmInt (-(fromInteger i))
1152 returnUs (Amode (AddrRegImm reg off) code)
1154 getAmode (StPrim IntAddOp [x, StInt i])
1155 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1156 getRegister x `thenUs` \ register ->
1158 code = registerCode register tmp
1159 reg = registerName register tmp
1160 off = ImmInt (fromInteger i)
1162 returnUs (Amode (AddrRegImm reg off) code)
1166 = returnUs (Amode (AddrImm imm__2) id)
1169 imm__2 = case imm of Just x -> x
1172 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1173 getRegister other `thenUs` \ register ->
1175 code = registerCode register tmp
1176 reg = registerName register tmp
1178 returnUs (Amode (AddrReg reg) code)
1180 #endif {- alpha_TARGET_ARCH -}
1181 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1182 #if i386_TARGET_ARCH
1184 getAmode (StPrim IntSubOp [x, StInt i])
1185 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1186 getRegister x `thenUs` \ register ->
1188 code = registerCode register tmp
1189 reg = registerName register tmp
1190 off = ImmInt (-(fromInteger i))
1192 returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1194 getAmode (StPrim IntAddOp [x, StInt i])
1197 code = mkSeqInstrs []
1199 returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
1202 imm__2 = case imm of Just x -> x
1204 getAmode (StPrim IntAddOp [x, StInt i])
1205 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1206 getRegister x `thenUs` \ register ->
1208 code = registerCode register tmp
1209 reg = registerName register tmp
1210 off = ImmInt (fromInteger i)
1212 returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1214 getAmode (StPrim IntAddOp [x, y])
1215 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1216 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1217 getRegister x `thenUs` \ register1 ->
1218 getRegister y `thenUs` \ register2 ->
1220 code1 = registerCode register1 tmp1 asmVoid
1221 reg1 = registerName register1 tmp1
1222 code2 = registerCode register2 tmp2 asmVoid
1223 reg2 = registerName register2 tmp2
1224 code__2 = asmParThen [code1, code2]
1226 returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
1231 code = mkSeqInstrs []
1233 returnUs (Amode (ImmAddr imm__2 0) code)
1236 imm__2 = case imm of Just x -> x
1239 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1240 getRegister other `thenUs` \ register ->
1242 code = registerCode register tmp
1243 reg = registerName register tmp
1246 returnUs (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1248 #endif {- i386_TARGET_ARCH -}
1249 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1250 #if sparc_TARGET_ARCH
1252 getAmode (StPrim IntSubOp [x, StInt i])
1254 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1255 getRegister x `thenUs` \ register ->
1257 code = registerCode register tmp
1258 reg = registerName register tmp
1259 off = ImmInt (-(fromInteger i))
1261 returnUs (Amode (AddrRegImm reg off) code)
1264 getAmode (StPrim IntAddOp [x, StInt i])
1266 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1267 getRegister x `thenUs` \ register ->
1269 code = registerCode register tmp
1270 reg = registerName register tmp
1271 off = ImmInt (fromInteger i)
1273 returnUs (Amode (AddrRegImm reg off) code)
1275 getAmode (StPrim IntAddOp [x, y])
1276 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1277 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1278 getRegister x `thenUs` \ register1 ->
1279 getRegister y `thenUs` \ register2 ->
1281 code1 = registerCode register1 tmp1 asmVoid
1282 reg1 = registerName register1 tmp1
1283 code2 = registerCode register2 tmp2 asmVoid
1284 reg2 = registerName register2 tmp2
1285 code__2 = asmParThen [code1, code2]
1287 returnUs (Amode (AddrRegReg reg1 reg2) code__2)
1291 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1293 code = mkSeqInstr (SETHI (HI imm__2) tmp)
1295 returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
1298 imm__2 = case imm of Just x -> x
1301 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1302 getRegister other `thenUs` \ register ->
1304 code = registerCode register tmp
1305 reg = registerName register tmp
1308 returnUs (Amode (AddrRegImm reg off) code)
1310 #endif {- sparc_TARGET_ARCH -}
1313 %************************************************************************
1315 \subsection{The @CondCode@ type}
1317 %************************************************************************
1319 Condition codes passed up the tree.
1321 data CondCode = CondCode Bool Cond InstrBlock
1323 condName (CondCode _ cond _) = cond
1324 condFloat (CondCode is_float _ _) = is_float
1325 condCode (CondCode _ _ code) = code
1328 Set up a condition code for a conditional branch.
1331 getCondCode :: StixTree -> UniqSM CondCode
1333 #if alpha_TARGET_ARCH
1334 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1335 #endif {- alpha_TARGET_ARCH -}
1336 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1338 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1339 -- yes, they really do seem to want exactly the same!
1341 getCondCode (StPrim primop [x, y])
1343 CharGtOp -> condIntCode GTT x y
1344 CharGeOp -> condIntCode GE x y
1345 CharEqOp -> condIntCode EQQ x y
1346 CharNeOp -> condIntCode NE x y
1347 CharLtOp -> condIntCode LTT x y
1348 CharLeOp -> condIntCode LE x y
1350 IntGtOp -> condIntCode GTT x y
1351 IntGeOp -> condIntCode GE x y
1352 IntEqOp -> condIntCode EQQ x y
1353 IntNeOp -> condIntCode NE x y
1354 IntLtOp -> condIntCode LTT x y
1355 IntLeOp -> condIntCode LE x y
1357 WordGtOp -> condIntCode GU x y
1358 WordGeOp -> condIntCode GEU x y
1359 WordEqOp -> condIntCode EQQ x y
1360 WordNeOp -> condIntCode NE x y
1361 WordLtOp -> condIntCode LU x y
1362 WordLeOp -> condIntCode LEU x y
1364 AddrGtOp -> condIntCode GU x y
1365 AddrGeOp -> condIntCode GEU x y
1366 AddrEqOp -> condIntCode EQQ x y
1367 AddrNeOp -> condIntCode NE x y
1368 AddrLtOp -> condIntCode LU x y
1369 AddrLeOp -> condIntCode LEU x y
1371 FloatGtOp -> condFltCode GTT x y
1372 FloatGeOp -> condFltCode GE x y
1373 FloatEqOp -> condFltCode EQQ x y
1374 FloatNeOp -> condFltCode NE x y
1375 FloatLtOp -> condFltCode LTT x y
1376 FloatLeOp -> condFltCode LE x y
1378 DoubleGtOp -> condFltCode GTT x y
1379 DoubleGeOp -> condFltCode GE x y
1380 DoubleEqOp -> condFltCode EQQ x y
1381 DoubleNeOp -> condFltCode NE x y
1382 DoubleLtOp -> condFltCode LTT x y
1383 DoubleLeOp -> condFltCode LE x y
1385 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1390 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1391 passed back up the tree.
1394 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode
1396 #if alpha_TARGET_ARCH
1397 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1398 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1399 #endif {- alpha_TARGET_ARCH -}
1401 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1402 #if i386_TARGET_ARCH
1404 condIntCode cond (StInd _ x) y
1406 = getAmode x `thenUs` \ amode ->
1408 code1 = amodeCode amode asmVoid
1409 y__2 = amodeAddr amode
1410 code__2 = asmParThen [code1] .
1411 mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
1413 returnUs (CondCode False cond code__2)
1416 imm__2 = case imm of Just x -> x
1418 condIntCode cond x (StInt 0)
1419 = getRegister x `thenUs` \ register1 ->
1420 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1422 code1 = registerCode register1 tmp1 asmVoid
1423 src1 = registerName register1 tmp1
1424 code__2 = asmParThen [code1] .
1425 mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
1427 returnUs (CondCode False cond code__2)
1429 condIntCode cond x y
1431 = getRegister x `thenUs` \ register1 ->
1432 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1434 code1 = registerCode register1 tmp1 asmVoid
1435 src1 = registerName register1 tmp1
1436 code__2 = asmParThen [code1] .
1437 mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
1439 returnUs (CondCode False cond code__2)
1442 imm__2 = case imm of Just x -> x
1444 condIntCode cond (StInd _ x) y
1445 = getAmode x `thenUs` \ amode ->
1446 getRegister y `thenUs` \ register2 ->
1447 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1449 code1 = amodeCode amode asmVoid
1450 src1 = amodeAddr amode
1451 code2 = registerCode register2 tmp2 asmVoid
1452 src2 = registerName register2 tmp2
1453 code__2 = asmParThen [code1, code2] .
1454 mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
1456 returnUs (CondCode False cond code__2)
1458 condIntCode cond y (StInd _ x)
1459 = getAmode x `thenUs` \ amode ->
1460 getRegister y `thenUs` \ register2 ->
1461 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1463 code1 = amodeCode amode asmVoid
1464 src1 = amodeAddr amode
1465 code2 = registerCode register2 tmp2 asmVoid
1466 src2 = registerName register2 tmp2
1467 code__2 = asmParThen [code1, code2] .
1468 mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
1470 returnUs (CondCode False cond code__2)
1472 condIntCode cond x y
1473 = getRegister x `thenUs` \ register1 ->
1474 getRegister y `thenUs` \ register2 ->
1475 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1476 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1478 code1 = registerCode register1 tmp1 asmVoid
1479 src1 = registerName register1 tmp1
1480 code2 = registerCode register2 tmp2 asmVoid
1481 src2 = registerName register2 tmp2
1482 code__2 = asmParThen [code1, code2] .
1483 mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
1485 returnUs (CondCode False cond code__2)
1489 condFltCode cond x (StDouble 0.0)
1490 = getRegister x `thenUs` \ register1 ->
1491 getNewRegNCG (registerRep register1)
1494 pk1 = registerRep register1
1495 code1 = registerCode register1 tmp1
1496 src1 = registerName register1 tmp1
1498 code__2 = asmParThen [code1 asmVoid] .
1499 mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ?
1501 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1502 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1506 returnUs (CondCode True (fix_FP_cond cond) code__2)
1508 condFltCode cond x y
1509 = getRegister x `thenUs` \ register1 ->
1510 getRegister y `thenUs` \ register2 ->
1511 getNewRegNCG (registerRep register1)
1513 getNewRegNCG (registerRep register2)
1516 pk1 = registerRep register1
1517 code1 = registerCode register1 tmp1
1518 src1 = registerName register1 tmp1
1520 code2 = registerCode register2 tmp2
1521 src2 = registerName register2 tmp2
1523 code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
1524 mkSeqInstrs [FUCOMPP,
1526 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1527 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1531 returnUs (CondCode True (fix_FP_cond cond) code__2)
1533 {- On the 486, the flags set by FP compare are the unsigned ones!
1534 (This looks like a HACK to me. WDP 96/03)
1537 fix_FP_cond :: Cond -> Cond
1539 fix_FP_cond GE = GEU
1540 fix_FP_cond GTT = GU
1541 fix_FP_cond LTT = LU
1542 fix_FP_cond LE = LEU
1543 fix_FP_cond any = any
1545 #endif {- i386_TARGET_ARCH -}
1546 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1547 #if sparc_TARGET_ARCH
1549 condIntCode cond x (StInt y)
1551 = getRegister x `thenUs` \ register ->
1552 getNewRegNCG IntRep `thenUs` \ tmp ->
1554 code = registerCode register tmp
1555 src1 = registerName register tmp
1556 src2 = ImmInt (fromInteger y)
1557 code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
1559 returnUs (CondCode False cond code__2)
1561 condIntCode cond x y
1562 = getRegister x `thenUs` \ register1 ->
1563 getRegister y `thenUs` \ register2 ->
1564 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1565 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1567 code1 = registerCode register1 tmp1 asmVoid
1568 src1 = registerName register1 tmp1
1569 code2 = registerCode register2 tmp2 asmVoid
1570 src2 = registerName register2 tmp2
1571 code__2 = asmParThen [code1, code2] .
1572 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
1574 returnUs (CondCode False cond code__2)
1577 condFltCode cond x y
1578 = getRegister x `thenUs` \ register1 ->
1579 getRegister y `thenUs` \ register2 ->
1580 getNewRegNCG (registerRep register1)
1582 getNewRegNCG (registerRep register2)
1584 getNewRegNCG DoubleRep `thenUs` \ tmp ->
1586 promote x = asmInstr (FxTOy F DF x tmp)
1588 pk1 = registerRep register1
1589 code1 = registerCode register1 tmp1
1590 src1 = registerName register1 tmp1
1592 pk2 = registerRep register2
1593 code2 = registerCode register2 tmp2
1594 src2 = registerName register2 tmp2
1598 asmParThen [code1 asmVoid, code2 asmVoid] .
1599 mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
1600 else if pk1 == FloatRep then
1601 asmParThen [code1 (promote src1), code2 asmVoid] .
1602 mkSeqInstr (FCMP True DF tmp src2)
1604 asmParThen [code1 asmVoid, code2 (promote src2)] .
1605 mkSeqInstr (FCMP True DF src1 tmp)
1607 returnUs (CondCode True cond code__2)
1609 #endif {- sparc_TARGET_ARCH -}
1612 %************************************************************************
1614 \subsection{Generating assignments}
1616 %************************************************************************
1618 Assignments are really at the heart of the whole code generation
1619 business. Almost all top-level nodes of any real importance are
1620 assignments, which correspond to loads, stores, or register transfers.
1621 If we're really lucky, some of the register transfers will go away,
1622 because we can use the destination register to complete the code
1623 generation for the right hand side. This only fails when the right
1624 hand side is forced into a fixed register (e.g. the result of a call).
1627 assignIntCode, assignFltCode
1628 :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
1630 #if alpha_TARGET_ARCH
1632 assignIntCode pk (StInd _ dst) src
1633 = getNewRegNCG IntRep `thenUs` \ tmp ->
1634 getAmode dst `thenUs` \ amode ->
1635 getRegister src `thenUs` \ register ->
1637 code1 = amodeCode amode asmVoid
1638 dst__2 = amodeAddr amode
1639 code2 = registerCode register tmp asmVoid
1640 src__2 = registerName register tmp
1641 sz = primRepToSize pk
1642 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1646 assignIntCode pk dst src
1647 = getRegister dst `thenUs` \ register1 ->
1648 getRegister src `thenUs` \ register2 ->
1650 dst__2 = registerName register1 zeroh
1651 code = registerCode register2 dst__2
1652 src__2 = registerName register2 dst__2
1653 code__2 = if isFixed register2
1654 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1659 #endif {- alpha_TARGET_ARCH -}
1660 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1661 #if i386_TARGET_ARCH
1663 assignIntCode pk (StInd _ dst) src
1664 = getAmode dst `thenUs` \ amode ->
1665 get_op_RI src `thenUs` \ (codesrc, opsrc, sz) ->
1667 code1 = amodeCode amode asmVoid
1668 dst__2 = amodeAddr amode
1669 code__2 = asmParThen [code1, codesrc asmVoid] .
1670 mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
1676 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
1680 = returnUs (asmParThen [], OpImm imm_op, L)
1683 imm_op = case imm of Just x -> x
1686 = getRegister op `thenUs` \ register ->
1687 getNewRegNCG (registerRep register)
1690 code = registerCode register tmp
1691 reg = registerName register tmp
1692 pk = registerRep register
1693 sz = primRepToSize pk
1695 returnUs (code, OpReg reg, sz)
1697 assignIntCode pk dst (StInd _ src)
1698 = getNewRegNCG IntRep `thenUs` \ tmp ->
1699 getAmode src `thenUs` \ amode ->
1700 getRegister dst `thenUs` \ register ->
1702 code1 = amodeCode amode asmVoid
1703 src__2 = amodeAddr amode
1704 code2 = registerCode register tmp asmVoid
1705 dst__2 = registerName register tmp
1706 sz = primRepToSize pk
1707 code__2 = asmParThen [code1, code2] .
1708 mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
1712 assignIntCode pk dst src
1713 = getRegister dst `thenUs` \ register1 ->
1714 getRegister src `thenUs` \ register2 ->
1715 getNewRegNCG IntRep `thenUs` \ tmp ->
1717 dst__2 = registerName register1 tmp
1718 code = registerCode register2 dst__2
1719 src__2 = registerName register2 dst__2
1720 code__2 = if isFixed register2 && dst__2 /= src__2
1721 then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
1726 #endif {- i386_TARGET_ARCH -}
1727 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1728 #if sparc_TARGET_ARCH
1730 assignIntCode pk (StInd _ dst) src
1731 = getNewRegNCG IntRep `thenUs` \ tmp ->
1732 getAmode dst `thenUs` \ amode ->
1733 getRegister src `thenUs` \ register ->
1735 code1 = amodeCode amode asmVoid
1736 dst__2 = amodeAddr amode
1737 code2 = registerCode register tmp asmVoid
1738 src__2 = registerName register tmp
1739 sz = primRepToSize pk
1740 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1744 assignIntCode pk dst src
1745 = getRegister dst `thenUs` \ register1 ->
1746 getRegister src `thenUs` \ register2 ->
1748 dst__2 = registerName register1 g0
1749 code = registerCode register2 dst__2
1750 src__2 = registerName register2 dst__2
1751 code__2 = if isFixed register2
1752 then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
1757 #endif {- sparc_TARGET_ARCH -}
1760 % --------------------------------
1761 Floating-point assignments:
1762 % --------------------------------
1764 #if alpha_TARGET_ARCH
1766 assignFltCode pk (StInd _ dst) src
1767 = getNewRegNCG pk `thenUs` \ tmp ->
1768 getAmode dst `thenUs` \ amode ->
1769 getRegister src `thenUs` \ register ->
1771 code1 = amodeCode amode asmVoid
1772 dst__2 = amodeAddr amode
1773 code2 = registerCode register tmp asmVoid
1774 src__2 = registerName register tmp
1775 sz = primRepToSize pk
1776 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1780 assignFltCode pk dst src
1781 = getRegister dst `thenUs` \ register1 ->
1782 getRegister src `thenUs` \ register2 ->
1784 dst__2 = registerName register1 zeroh
1785 code = registerCode register2 dst__2
1786 src__2 = registerName register2 dst__2
1787 code__2 = if isFixed register2
1788 then code . mkSeqInstr (FMOV src__2 dst__2)
1793 #endif {- alpha_TARGET_ARCH -}
1794 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1795 #if i386_TARGET_ARCH
1797 assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
1798 = getNewRegNCG IntRep `thenUs` \ tmp ->
1799 getAmode src `thenUs` \ amodesrc ->
1800 getAmode dst `thenUs` \ amodedst ->
1801 --getRegister src `thenUs` \ register ->
1803 codesrc1 = amodeCode amodesrc asmVoid
1804 addrsrc1 = amodeAddr amodesrc
1805 codedst1 = amodeCode amodedst asmVoid
1806 addrdst1 = amodeAddr amodedst
1807 addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x
1808 addrdst2 = case (addrOffset addrdst1 4) of Just x -> x
1810 code__2 = asmParThen [codesrc1, codedst1] .
1811 mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
1812 MOV L (OpReg tmp) (OpAddr addrdst1)]
1815 then [MOV L (OpAddr addrsrc2) (OpReg tmp),
1816 MOV L (OpReg tmp) (OpAddr addrdst2)]
1821 assignFltCode pk (StInd _ dst) src
1822 = --getNewRegNCG pk `thenUs` \ tmp ->
1823 getAmode dst `thenUs` \ amode ->
1824 getRegister src `thenUs` \ register ->
1826 sz = primRepToSize pk
1827 dst__2 = amodeAddr amode
1829 code1 = amodeCode amode asmVoid
1830 code2 = registerCode register {-tmp-}st0 asmVoid
1832 --src__2= registerName register tmp
1833 pk__2 = registerRep register
1834 sz__2 = primRepToSize pk__2
1836 code__2 = asmParThen [code1, code2] .
1837 mkSeqInstr (FSTP sz (OpAddr dst__2))
1841 assignFltCode pk dst src
1842 = getRegister dst `thenUs` \ register1 ->
1843 getRegister src `thenUs` \ register2 ->
1844 --getNewRegNCG (registerRep register2)
1845 -- `thenUs` \ tmp ->
1847 sz = primRepToSize pk
1848 dst__2 = registerName register1 st0 --tmp
1850 code = registerCode register2 dst__2
1851 src__2 = registerName register2 dst__2
1857 #endif {- i386_TARGET_ARCH -}
1858 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1859 #if sparc_TARGET_ARCH
1861 assignFltCode pk (StInd _ dst) src
1862 = getNewRegNCG pk `thenUs` \ tmp1 ->
1863 getAmode dst `thenUs` \ amode ->
1864 getRegister src `thenUs` \ register ->
1866 sz = primRepToSize pk
1867 dst__2 = amodeAddr amode
1869 code1 = amodeCode amode asmVoid
1870 code2 = registerCode register tmp1 asmVoid
1872 src__2 = registerName register tmp1
1873 pk__2 = registerRep register
1874 sz__2 = primRepToSize pk__2
1876 code__2 = asmParThen [code1, code2] .
1878 mkSeqInstr (ST sz src__2 dst__2)
1880 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1884 assignFltCode pk dst src
1885 = getRegister dst `thenUs` \ register1 ->
1886 getRegister src `thenUs` \ register2 ->
1888 pk__2 = registerRep register2
1889 sz__2 = primRepToSize pk__2
1891 getNewRegNCG pk__2 `thenUs` \ tmp ->
1893 sz = primRepToSize pk
1894 dst__2 = registerName register1 g0 -- must be Fixed
1897 reg__2 = if pk /= pk__2 then tmp else dst__2
1899 code = registerCode register2 reg__2
1901 src__2 = registerName register2 reg__2
1905 code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
1906 else if isFixed register2 then
1907 code . mkSeqInstr (FMOV sz src__2 dst__2)
1913 #endif {- sparc_TARGET_ARCH -}
1916 %************************************************************************
1918 \subsection{Generating an unconditional branch}
1920 %************************************************************************
1922 We accept two types of targets: an immediate CLabel or a tree that
1923 gets evaluated into a register. Any CLabels which are AsmTemporaries
1924 are assumed to be in the local block of code, close enough for a
1925 branch instruction. Other CLabels are assumed to be far away.
1927 (If applicable) Do not fill the delay slots here; you will confuse the
1931 genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
1933 #if alpha_TARGET_ARCH
1935 genJump (StCLbl lbl)
1936 | isAsmTemp lbl = returnInstr (BR target)
1937 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1939 target = ImmCLbl lbl
1942 = getRegister tree `thenUs` \ register ->
1943 getNewRegNCG PtrRep `thenUs` \ tmp ->
1945 dst = registerName register pv
1946 code = registerCode register pv
1947 target = registerName register pv
1949 if isFixed register then
1950 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1952 returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1954 #endif {- alpha_TARGET_ARCH -}
1955 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1956 #if i386_TARGET_ARCH
1959 genJump (StCLbl lbl)
1960 | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
1961 | otherwise = returnInstrs [JMP (OpImm target)]
1963 target = ImmCLbl lbl
1966 genJump (StInd pk mem)
1967 = getAmode mem `thenUs` \ amode ->
1969 code = amodeCode amode
1970 target = amodeAddr amode
1972 returnSeq code [JMP (OpAddr target)]
1976 = returnInstr (JMP (OpImm target))
1979 = getRegister tree `thenUs` \ register ->
1980 getNewRegNCG PtrRep `thenUs` \ tmp ->
1982 code = registerCode register tmp
1983 target = registerName register tmp
1985 returnSeq code [JMP (OpReg target)]
1988 target = case imm of Just x -> x
1990 #endif {- i386_TARGET_ARCH -}
1991 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1992 #if sparc_TARGET_ARCH
1994 genJump (StCLbl lbl)
1995 | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
1996 | otherwise = returnInstrs [CALL target 0 True, NOP]
1998 target = ImmCLbl lbl
2001 = getRegister tree `thenUs` \ register ->
2002 getNewRegNCG PtrRep `thenUs` \ tmp ->
2004 code = registerCode register tmp
2005 target = registerName register tmp
2007 returnSeq code [JMP (AddrRegReg target g0), NOP]
2009 #endif {- sparc_TARGET_ARCH -}
2012 %************************************************************************
2014 \subsection{Conditional jumps}
2016 %************************************************************************
2018 Conditional jumps are always to local labels, so we can use branch
2019 instructions. We peek at the arguments to decide what kind of
2022 ALPHA: For comparisons with 0, we're laughing, because we can just do
2023 the desired conditional branch.
2025 I386: First, we have to ensure that the condition
2026 codes are set according to the supplied comparison operation.
2028 SPARC: First, we have to ensure that the condition codes are set
2029 according to the supplied comparison operation. We generate slightly
2030 different code for floating point comparisons, because a floating
2031 point operation cannot directly precede a @BF@. We assume the worst
2032 and fill that slot with a @NOP@.
2034 SPARC: Do not fill the delay slots here; you will confuse the register
2039 :: CLabel -- the branch target
2040 -> StixTree -- the condition on which to branch
2041 -> UniqSM InstrBlock
2043 #if alpha_TARGET_ARCH
2045 genCondJump lbl (StPrim op [x, StInt 0])
2046 = getRegister x `thenUs` \ register ->
2047 getNewRegNCG (registerRep register)
2050 code = registerCode register tmp
2051 value = registerName register tmp
2052 pk = registerRep register
2053 target = ImmCLbl lbl
2055 returnSeq code [BI (cmpOp op) value target]
2057 cmpOp CharGtOp = GTT
2059 cmpOp CharEqOp = EQQ
2061 cmpOp CharLtOp = LTT
2070 cmpOp WordGeOp = ALWAYS
2071 cmpOp WordEqOp = EQQ
2073 cmpOp WordLtOp = NEVER
2074 cmpOp WordLeOp = EQQ
2076 cmpOp AddrGeOp = ALWAYS
2077 cmpOp AddrEqOp = EQQ
2079 cmpOp AddrLtOp = NEVER
2080 cmpOp AddrLeOp = EQQ
2082 genCondJump lbl (StPrim op [x, StDouble 0.0])
2083 = getRegister x `thenUs` \ register ->
2084 getNewRegNCG (registerRep register)
2087 code = registerCode register tmp
2088 value = registerName register tmp
2089 pk = registerRep register
2090 target = ImmCLbl lbl
2092 returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
2094 cmpOp FloatGtOp = GTT
2095 cmpOp FloatGeOp = GE
2096 cmpOp FloatEqOp = EQQ
2097 cmpOp FloatNeOp = NE
2098 cmpOp FloatLtOp = LTT
2099 cmpOp FloatLeOp = LE
2100 cmpOp DoubleGtOp = GTT
2101 cmpOp DoubleGeOp = GE
2102 cmpOp DoubleEqOp = EQQ
2103 cmpOp DoubleNeOp = NE
2104 cmpOp DoubleLtOp = LTT
2105 cmpOp DoubleLeOp = LE
2107 genCondJump lbl (StPrim op [x, y])
2109 = trivialFCode pr instr x y `thenUs` \ register ->
2110 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2112 code = registerCode register tmp
2113 result = registerName register tmp
2114 target = ImmCLbl lbl
2116 returnUs (code . mkSeqInstr (BF cond result target))
2118 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2120 fltCmpOp op = case op of
2134 (instr, cond) = case op of
2135 FloatGtOp -> (FCMP TF LE, EQQ)
2136 FloatGeOp -> (FCMP TF LTT, EQQ)
2137 FloatEqOp -> (FCMP TF EQQ, NE)
2138 FloatNeOp -> (FCMP TF EQQ, EQQ)
2139 FloatLtOp -> (FCMP TF LTT, NE)
2140 FloatLeOp -> (FCMP TF LE, NE)
2141 DoubleGtOp -> (FCMP TF LE, EQQ)
2142 DoubleGeOp -> (FCMP TF LTT, EQQ)
2143 DoubleEqOp -> (FCMP TF EQQ, NE)
2144 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2145 DoubleLtOp -> (FCMP TF LTT, NE)
2146 DoubleLeOp -> (FCMP TF LE, NE)
2148 genCondJump lbl (StPrim op [x, y])
2149 = trivialCode instr x y `thenUs` \ register ->
2150 getNewRegNCG IntRep `thenUs` \ tmp ->
2152 code = registerCode register tmp
2153 result = registerName register tmp
2154 target = ImmCLbl lbl
2156 returnUs (code . mkSeqInstr (BI cond result target))
2158 (instr, cond) = case op of
2159 CharGtOp -> (CMP LE, EQQ)
2160 CharGeOp -> (CMP LTT, EQQ)
2161 CharEqOp -> (CMP EQQ, NE)
2162 CharNeOp -> (CMP EQQ, EQQ)
2163 CharLtOp -> (CMP LTT, NE)
2164 CharLeOp -> (CMP LE, NE)
2165 IntGtOp -> (CMP LE, EQQ)
2166 IntGeOp -> (CMP LTT, EQQ)
2167 IntEqOp -> (CMP EQQ, NE)
2168 IntNeOp -> (CMP EQQ, EQQ)
2169 IntLtOp -> (CMP LTT, NE)
2170 IntLeOp -> (CMP LE, NE)
2171 WordGtOp -> (CMP ULE, EQQ)
2172 WordGeOp -> (CMP ULT, EQQ)
2173 WordEqOp -> (CMP EQQ, NE)
2174 WordNeOp -> (CMP EQQ, EQQ)
2175 WordLtOp -> (CMP ULT, NE)
2176 WordLeOp -> (CMP ULE, NE)
2177 AddrGtOp -> (CMP ULE, EQQ)
2178 AddrGeOp -> (CMP ULT, EQQ)
2179 AddrEqOp -> (CMP EQQ, NE)
2180 AddrNeOp -> (CMP EQQ, EQQ)
2181 AddrLtOp -> (CMP ULT, NE)
2182 AddrLeOp -> (CMP ULE, NE)
2184 #endif {- alpha_TARGET_ARCH -}
2185 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2186 #if i386_TARGET_ARCH
2188 genCondJump lbl bool
2189 = getCondCode bool `thenUs` \ condition ->
2191 code = condCode condition
2192 cond = condName condition
2193 target = ImmCLbl lbl
2195 returnSeq code [JXX cond lbl]
2197 #endif {- i386_TARGET_ARCH -}
2198 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2199 #if sparc_TARGET_ARCH
2201 genCondJump lbl bool
2202 = getCondCode bool `thenUs` \ condition ->
2204 code = condCode condition
2205 cond = condName condition
2206 target = ImmCLbl lbl
2209 if condFloat condition then
2210 [NOP, BF cond False target, NOP]
2212 [BI cond False target, NOP]
2215 #endif {- sparc_TARGET_ARCH -}
2218 %************************************************************************
2220 \subsection{Generating C calls}
2222 %************************************************************************
2224 Now the biggest nightmare---calls. Most of the nastiness is buried in
2225 @get_arg@, which moves the arguments to the correct registers/stack
2226 locations. Apart from that, the code is easy.
2228 (If applicable) Do not fill the delay slots here; you will confuse the
2233 :: FAST_STRING -- function to call
2235 -> PrimRep -- type of the result
2236 -> [StixTree] -- arguments (of mixed type)
2237 -> UniqSM InstrBlock
2239 #if alpha_TARGET_ARCH
2241 genCCall fn cconv kind args
2242 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2243 `thenUs` \ ((unused,_), argCode) ->
2245 nRegs = length allArgRegs - length unused
2246 code = asmParThen (map ($ asmVoid) argCode)
2249 LDA pv (AddrImm (ImmLab (ptext fn))),
2250 JSR ra (AddrReg pv) nRegs,
2251 LDGP gp (AddrReg ra)]
2253 ------------------------
2254 {- Try to get a value into a specific register (or registers) for
2255 a call. The first 6 arguments go into the appropriate
2256 argument register (separate registers for integer and floating
2257 point arguments, but used in lock-step), and the remaining
2258 arguments are dumped to the stack, beginning at 0(sp). Our
2259 first argument is a pair of the list of remaining argument
2260 registers to be assigned for this call and the next stack
2261 offset to use for overflowing arguments. This way,
2262 @get_Arg@ can be applied to all of a call's arguments using
2266 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2267 -> StixTree -- Current argument
2268 -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2270 -- We have to use up all of our argument registers first...
2272 get_arg ((iDst,fDst):dsts, offset) arg
2273 = getRegister arg `thenUs` \ register ->
2275 reg = if isFloatingRep pk then fDst else iDst
2276 code = registerCode register reg
2277 src = registerName register reg
2278 pk = registerRep register
2281 if isFloatingRep pk then
2282 ((dsts, offset), if isFixed register then
2283 code . mkSeqInstr (FMOV src fDst)
2286 ((dsts, offset), if isFixed register then
2287 code . mkSeqInstr (OR src (RIReg src) iDst)
2290 -- Once we have run out of argument registers, we move to the
2293 get_arg ([], offset) arg
2294 = getRegister arg `thenUs` \ register ->
2295 getNewRegNCG (registerRep register)
2298 code = registerCode register tmp
2299 src = registerName register tmp
2300 pk = registerRep register
2301 sz = primRepToSize pk
2303 returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2305 #endif {- alpha_TARGET_ARCH -}
2306 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2307 #if i386_TARGET_ARCH
2309 genCCall fn cconv kind [StInt i]
2310 | fn == SLIT ("PerformGC_wrapper")
2311 = let call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2312 CALL (ImmLit (ptext (if underscorePrefix
2313 then (SLIT ("_PerformGC_wrapper"))
2314 else (SLIT ("PerformGC_wrapper")))))]
2319 genCCall fn cconv kind args
2320 = mapUs get_call_arg args `thenUs` \ sizes_and_argCodes ->
2322 (sizes, argCode) = unzip sizes_and_argCodes
2323 tot_arg_size = sum (map (\sz -> case sz of DF -> 8; _ -> 4) sizes)
2325 code2 = asmParThen (map ($ asmVoid) (reverse argCode))
2326 call = [CALL fn__2 ,
2327 ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)
2330 returnSeq (code2) call
2333 -- function names that begin with '.' are assumed to be special
2334 -- internally generated names like '.mul,' which don't get an
2335 -- underscore prefix
2336 -- ToDo:needed (WDP 96/03) ???
2337 fn__2 = case (_HEAD_ fn) of
2338 '.' -> ImmLit (ptext fn)
2339 _ -> ImmLab (ptext fn)
2342 get_call_arg :: StixTree{-current argument-}
2343 -> UniqSM (Size, InstrBlock) -- arg size, code
2346 = get_op arg `thenUs` \ (code, op, sz) ->
2350 mkSeqInstr (FLD L op) .
2351 mkSeqInstr (SUB L (OpImm (ImmInt 8)) (OpReg esp)) .
2352 mkSeqInstr (FSTP DF (OpAddr (AddrBaseIndex
2354 Nothing (ImmInt 0))))
2357 code . mkSeqInstr (PUSH sz op))
2362 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
2365 = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
2367 get_op (StInd pk mem)
2368 = getAmode mem `thenUs` \ amode ->
2370 code = amodeCode amode --asmVoid
2371 addr = amodeAddr amode
2372 sz = primRepToSize pk
2374 returnUs (code, OpAddr addr, sz)
2377 = getRegister op `thenUs` \ register ->
2378 getNewRegNCG (registerRep register)
2381 code = registerCode register tmp
2382 reg = registerName register tmp
2383 pk = registerRep register
2384 sz = primRepToSize pk
2386 returnUs (code, OpReg reg, sz)
2388 #endif {- i386_TARGET_ARCH -}
2389 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2390 #if sparc_TARGET_ARCH
2392 genCCall fn cconv kind args
2393 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2394 `thenUs` \ ((unused,_), argCode) ->
2396 nRegs = length allArgRegs - length unused
2397 call = CALL fn__2 nRegs False
2398 code = asmParThen (map ($ asmVoid) argCode)
2400 returnSeq code [call, NOP]
2402 -- function names that begin with '.' are assumed to be special
2403 -- internally generated names like '.mul,' which don't get an
2404 -- underscore prefix
2405 -- ToDo:needed (WDP 96/03) ???
2406 fn__2 = case (_HEAD_ fn) of
2407 '.' -> ImmLit (ptext fn)
2408 _ -> ImmLab (ptext fn)
2410 ------------------------------------
2411 {- Try to get a value into a specific register (or registers) for
2412 a call. The SPARC calling convention is an absolute
2413 nightmare. The first 6x32 bits of arguments are mapped into
2414 %o0 through %o5, and the remaining arguments are dumped to the
2415 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2416 first argument is a pair of the list of remaining argument
2417 registers to be assigned for this call and the next stack
2418 offset to use for overflowing arguments. This way,
2419 @get_arg@ can be applied to all of a call's arguments using
2423 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2424 -> StixTree -- Current argument
2425 -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2427 -- We have to use up all of our argument registers first...
2429 get_arg (dst:dsts, offset) arg
2430 = getRegister arg `thenUs` \ register ->
2431 getNewRegNCG (registerRep register)
2434 reg = if isFloatingRep pk then tmp else dst
2435 code = registerCode register reg
2436 src = registerName register reg
2437 pk = registerRep register
2439 returnUs (case pk of
2442 [] -> (([], offset + 1), code . mkSeqInstrs [
2443 -- conveniently put the second part in the right stack
2444 -- location, and load the first part into %o5
2445 ST DF src (spRel (offset - 1)),
2446 LD W (spRel (offset - 1)) dst])
2447 (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2448 ST DF src (spRel (-2)),
2449 LD W (spRel (-2)) dst,
2450 LD W (spRel (-1)) dst__2])
2451 FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2452 ST F src (spRel (-2)),
2453 LD W (spRel (-2)) dst])
2454 _ -> ((dsts, offset), if isFixed register then
2455 code . mkSeqInstr (OR False g0 (RIReg src) dst)
2458 -- Once we have run out of argument registers, we move to the
2461 get_arg ([], offset) arg
2462 = getRegister arg `thenUs` \ register ->
2463 getNewRegNCG (registerRep register)
2466 code = registerCode register tmp
2467 src = registerName register tmp
2468 pk = registerRep register
2469 sz = primRepToSize pk
2470 words = if pk == DoubleRep then 2 else 1
2472 returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2474 #endif {- sparc_TARGET_ARCH -}
2477 %************************************************************************
2479 \subsection{Support bits}
2481 %************************************************************************
2483 %************************************************************************
2485 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2487 %************************************************************************
2489 Turn those condition codes into integers now (when they appear on
2490 the right hand side of an assignment).
2492 (If applicable) Do not fill the delay slots here; you will confuse the
2496 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2498 #if alpha_TARGET_ARCH
2499 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2500 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2501 #endif {- alpha_TARGET_ARCH -}
2503 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2504 #if i386_TARGET_ARCH
2507 = condIntCode cond x y `thenUs` \ condition ->
2508 getNewRegNCG IntRep `thenUs` \ tmp ->
2509 --getRegister dst `thenUs` \ register ->
2511 --code2 = registerCode register tmp asmVoid
2512 --dst__2 = registerName register tmp
2513 code = condCode condition
2514 cond = condName condition
2515 -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2516 code__2 dst = code . mkSeqInstrs [
2517 SETCC cond (OpReg tmp),
2518 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2519 MOV L (OpReg tmp) (OpReg dst)]
2521 returnUs (Any IntRep code__2)
2524 = getUniqLabelNCG `thenUs` \ lbl1 ->
2525 getUniqLabelNCG `thenUs` \ lbl2 ->
2526 condFltCode cond x y `thenUs` \ condition ->
2528 code = condCode condition
2529 cond = condName condition
2530 code__2 dst = code . mkSeqInstrs [
2532 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2535 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2538 returnUs (Any IntRep code__2)
2540 #endif {- i386_TARGET_ARCH -}
2541 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2542 #if sparc_TARGET_ARCH
2544 condIntReg EQQ x (StInt 0)
2545 = getRegister x `thenUs` \ register ->
2546 getNewRegNCG IntRep `thenUs` \ tmp ->
2548 code = registerCode register tmp
2549 src = registerName register tmp
2550 code__2 dst = code . mkSeqInstrs [
2551 SUB False True g0 (RIReg src) g0,
2552 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2554 returnUs (Any IntRep code__2)
2557 = getRegister x `thenUs` \ register1 ->
2558 getRegister y `thenUs` \ register2 ->
2559 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2560 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2562 code1 = registerCode register1 tmp1 asmVoid
2563 src1 = registerName register1 tmp1
2564 code2 = registerCode register2 tmp2 asmVoid
2565 src2 = registerName register2 tmp2
2566 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2567 XOR False src1 (RIReg src2) dst,
2568 SUB False True g0 (RIReg dst) g0,
2569 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2571 returnUs (Any IntRep code__2)
2573 condIntReg NE x (StInt 0)
2574 = getRegister x `thenUs` \ register ->
2575 getNewRegNCG IntRep `thenUs` \ tmp ->
2577 code = registerCode register tmp
2578 src = registerName register tmp
2579 code__2 dst = code . mkSeqInstrs [
2580 SUB False True g0 (RIReg src) g0,
2581 ADD True False g0 (RIImm (ImmInt 0)) dst]
2583 returnUs (Any IntRep code__2)
2586 = getRegister x `thenUs` \ register1 ->
2587 getRegister y `thenUs` \ register2 ->
2588 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2589 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2591 code1 = registerCode register1 tmp1 asmVoid
2592 src1 = registerName register1 tmp1
2593 code2 = registerCode register2 tmp2 asmVoid
2594 src2 = registerName register2 tmp2
2595 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2596 XOR False src1 (RIReg src2) dst,
2597 SUB False True g0 (RIReg dst) g0,
2598 ADD True False g0 (RIImm (ImmInt 0)) dst]
2600 returnUs (Any IntRep code__2)
2603 = getUniqLabelNCG `thenUs` \ lbl1 ->
2604 getUniqLabelNCG `thenUs` \ lbl2 ->
2605 condIntCode cond x y `thenUs` \ condition ->
2607 code = condCode condition
2608 cond = condName condition
2609 code__2 dst = code . mkSeqInstrs [
2610 BI cond False (ImmCLbl lbl1), NOP,
2611 OR False g0 (RIImm (ImmInt 0)) dst,
2612 BI ALWAYS False (ImmCLbl lbl2), NOP,
2614 OR False g0 (RIImm (ImmInt 1)) dst,
2617 returnUs (Any IntRep code__2)
2620 = getUniqLabelNCG `thenUs` \ lbl1 ->
2621 getUniqLabelNCG `thenUs` \ lbl2 ->
2622 condFltCode cond x y `thenUs` \ condition ->
2624 code = condCode condition
2625 cond = condName condition
2626 code__2 dst = code . mkSeqInstrs [
2628 BF cond False (ImmCLbl lbl1), NOP,
2629 OR False g0 (RIImm (ImmInt 0)) dst,
2630 BI ALWAYS False (ImmCLbl lbl2), NOP,
2632 OR False g0 (RIImm (ImmInt 1)) dst,
2635 returnUs (Any IntRep code__2)
2637 #endif {- sparc_TARGET_ARCH -}
2640 %************************************************************************
2642 \subsubsection{@trivial*Code@: deal with trivial instructions}
2644 %************************************************************************
2646 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2647 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2648 for constants on the right hand side, because that's where the generic
2649 optimizer will have put them.
2651 Similarly, for unary instructions, we don't have to worry about
2652 matching an StInt as the argument, because genericOpt will already
2653 have handled the constant-folding.
2657 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2658 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2659 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2661 -> StixTree -> StixTree -- the two arguments
2666 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2667 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2669 {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
2670 (Size -> Operand -> Instr)
2671 -> (Size -> Operand -> Instr) {-reversed instr-}
2673 -> Instr {-reversed instr: pop-}
2675 -> StixTree -> StixTree -- the two arguments
2679 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2680 ,IF_ARCH_i386 ((Operand -> Instr)
2681 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2683 -> StixTree -- the one argument
2688 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2689 ,IF_ARCH_i386 (Instr
2690 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2692 -> StixTree -- the one argument
2695 #if alpha_TARGET_ARCH
2697 trivialCode instr x (StInt y)
2699 = getRegister x `thenUs` \ register ->
2700 getNewRegNCG IntRep `thenUs` \ tmp ->
2702 code = registerCode register tmp
2703 src1 = registerName register tmp
2704 src2 = ImmInt (fromInteger y)
2705 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2707 returnUs (Any IntRep code__2)
2709 trivialCode instr x y
2710 = getRegister x `thenUs` \ register1 ->
2711 getRegister y `thenUs` \ register2 ->
2712 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2713 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2715 code1 = registerCode register1 tmp1 asmVoid
2716 src1 = registerName register1 tmp1
2717 code2 = registerCode register2 tmp2 asmVoid
2718 src2 = registerName register2 tmp2
2719 code__2 dst = asmParThen [code1, code2] .
2720 mkSeqInstr (instr src1 (RIReg src2) dst)
2722 returnUs (Any IntRep code__2)
2725 trivialUCode instr x
2726 = getRegister x `thenUs` \ register ->
2727 getNewRegNCG IntRep `thenUs` \ tmp ->
2729 code = registerCode register tmp
2730 src = registerName register tmp
2731 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2733 returnUs (Any IntRep code__2)
2736 trivialFCode _ instr x y
2737 = getRegister x `thenUs` \ register1 ->
2738 getRegister y `thenUs` \ register2 ->
2739 getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
2740 getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
2742 code1 = registerCode register1 tmp1
2743 src1 = registerName register1 tmp1
2745 code2 = registerCode register2 tmp2
2746 src2 = registerName register2 tmp2
2748 code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2749 mkSeqInstr (instr src1 src2 dst)
2751 returnUs (Any DoubleRep code__2)
2753 trivialUFCode _ instr x
2754 = getRegister x `thenUs` \ register ->
2755 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2757 code = registerCode register tmp
2758 src = registerName register tmp
2759 code__2 dst = code . mkSeqInstr (instr src dst)
2761 returnUs (Any DoubleRep code__2)
2763 #endif {- alpha_TARGET_ARCH -}
2764 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2765 #if i386_TARGET_ARCH
2767 trivialCode instr x y
2769 = getRegister x `thenUs` \ register1 ->
2770 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2772 code__2 dst = let code1 = registerCode register1 dst
2773 src1 = registerName register1 dst
2775 if isFixed register1 && src1 /= dst
2776 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2777 instr (OpImm imm__2) (OpReg dst)]
2779 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
2781 returnUs (Any IntRep code__2)
2784 imm__2 = case imm of Just x -> x
2786 trivialCode instr x y
2788 = getRegister y `thenUs` \ register1 ->
2789 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2791 code__2 dst = let code1 = registerCode register1 dst
2792 src1 = registerName register1 dst
2794 if isFixed register1 && src1 /= dst
2795 then mkSeqInstrs [MOV L (OpImm imm__2) (OpReg dst),
2796 instr (OpReg src1) (OpReg dst)]
2798 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
2800 returnUs (Any IntRep code__2)
2803 imm__2 = case imm of Just x -> x
2805 trivialCode instr x (StInd pk mem)
2806 = getRegister x `thenUs` \ register ->
2807 --getNewRegNCG IntRep `thenUs` \ tmp ->
2808 getAmode mem `thenUs` \ amode ->
2810 code2 = amodeCode amode asmVoid
2811 src2 = amodeAddr amode
2812 code__2 dst = let code1 = registerCode register dst asmVoid
2813 src1 = registerName register dst
2814 in asmParThen [code1, code2] .
2815 if isFixed register && src1 /= dst
2816 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2817 instr (OpAddr src2) (OpReg dst)]
2819 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2821 returnUs (Any pk code__2)
2823 trivialCode instr (StInd pk mem) y
2824 = getRegister y `thenUs` \ register ->
2825 --getNewRegNCG IntRep `thenUs` \ tmp ->
2826 getAmode mem `thenUs` \ amode ->
2828 code2 = amodeCode amode asmVoid
2829 src2 = amodeAddr amode
2831 code1 = registerCode register dst asmVoid
2832 src1 = registerName register dst
2833 in asmParThen [code1, code2] .
2834 if isFixed register && src1 /= dst
2835 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2836 instr (OpAddr src2) (OpReg dst)]
2838 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2840 returnUs (Any pk code__2)
2842 trivialCode instr x y
2843 = getRegister x `thenUs` \ register1 ->
2844 getRegister y `thenUs` \ register2 ->
2845 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2846 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2848 code2 = registerCode register2 tmp2 asmVoid
2849 src2 = registerName register2 tmp2
2851 code1 = registerCode register1 dst asmVoid
2852 src1 = registerName register1 dst
2853 in asmParThen [code1, code2] .
2854 if isFixed register1 && src1 /= dst
2855 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2856 instr (OpReg src2) (OpReg dst)]
2858 mkSeqInstr (instr (OpReg src2) (OpReg src1))
2860 returnUs (Any IntRep code__2)
2863 trivialUCode instr x
2864 = getRegister x `thenUs` \ register ->
2865 -- getNewRegNCG IntRep `thenUs` \ tmp ->
2868 code = registerCode register dst
2869 src = registerName register dst
2870 in code . if isFixed register && dst /= src
2871 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
2873 else mkSeqInstr (instr (OpReg src))
2875 returnUs (Any IntRep code__2)
2878 trivialFCode pk _ instrr _ _ (StInd pk' mem) y
2879 = getRegister y `thenUs` \ register2 ->
2880 --getNewRegNCG (registerRep register2)
2881 -- `thenUs` \ tmp2 ->
2882 getAmode mem `thenUs` \ amode ->
2884 code1 = amodeCode amode
2885 src1 = amodeAddr amode
2888 code2 = registerCode register2 dst
2889 src2 = registerName register2 dst
2890 in asmParThen [code1 asmVoid,code2 asmVoid] .
2891 mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
2893 returnUs (Any pk code__2)
2895 trivialFCode pk instr _ _ _ x (StInd pk' mem)
2896 = getRegister x `thenUs` \ register1 ->
2897 --getNewRegNCG (registerRep register1)
2898 -- `thenUs` \ tmp1 ->
2899 getAmode mem `thenUs` \ amode ->
2901 code2 = amodeCode amode
2902 src2 = amodeAddr amode
2905 code1 = registerCode register1 dst
2906 src1 = registerName register1 dst
2907 in asmParThen [code2 asmVoid,code1 asmVoid] .
2908 mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
2910 returnUs (Any pk code__2)
2912 trivialFCode pk _ _ _ instrpr x y
2913 = getRegister x `thenUs` \ register1 ->
2914 getRegister y `thenUs` \ register2 ->
2915 --getNewRegNCG (registerRep register1)
2916 -- `thenUs` \ tmp1 ->
2917 --getNewRegNCG (registerRep register2)
2918 -- `thenUs` \ tmp2 ->
2919 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2921 pk1 = registerRep register1
2922 code1 = registerCode register1 st0 --tmp1
2923 src1 = registerName register1 st0 --tmp1
2925 pk2 = registerRep register2
2928 code2 = registerCode register2 dst
2929 src2 = registerName register2 dst
2930 in asmParThen [code1 asmVoid, code2 asmVoid] .
2933 returnUs (Any pk1 code__2)
2936 trivialUFCode pk instr (StInd pk' mem)
2937 = getAmode mem `thenUs` \ amode ->
2939 code = amodeCode amode
2940 src = amodeAddr amode
2941 code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
2944 returnUs (Any pk code__2)
2946 trivialUFCode pk instr x
2947 = getRegister x `thenUs` \ register ->
2948 --getNewRegNCG pk `thenUs` \ tmp ->
2951 code = registerCode register dst
2952 src = registerName register dst
2953 in code . mkSeqInstrs [instr]
2955 returnUs (Any pk code__2)
2957 #endif {- i386_TARGET_ARCH -}
2958 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2959 #if sparc_TARGET_ARCH
2961 trivialCode instr x (StInt y)
2963 = getRegister x `thenUs` \ register ->
2964 getNewRegNCG IntRep `thenUs` \ tmp ->
2966 code = registerCode register tmp
2967 src1 = registerName register tmp
2968 src2 = ImmInt (fromInteger y)
2969 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2971 returnUs (Any IntRep code__2)
2973 trivialCode instr x y
2974 = getRegister x `thenUs` \ register1 ->
2975 getRegister y `thenUs` \ register2 ->
2976 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2977 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2979 code1 = registerCode register1 tmp1 asmVoid
2980 src1 = registerName register1 tmp1
2981 code2 = registerCode register2 tmp2 asmVoid
2982 src2 = registerName register2 tmp2
2983 code__2 dst = asmParThen [code1, code2] .
2984 mkSeqInstr (instr src1 (RIReg src2) dst)
2986 returnUs (Any IntRep code__2)
2989 trivialFCode pk instr x y
2990 = getRegister x `thenUs` \ register1 ->
2991 getRegister y `thenUs` \ register2 ->
2992 getNewRegNCG (registerRep register1)
2994 getNewRegNCG (registerRep register2)
2996 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2998 promote x = asmInstr (FxTOy F DF x tmp)
3000 pk1 = registerRep register1
3001 code1 = registerCode register1 tmp1
3002 src1 = registerName register1 tmp1
3004 pk2 = registerRep register2
3005 code2 = registerCode register2 tmp2
3006 src2 = registerName register2 tmp2
3010 asmParThen [code1 asmVoid, code2 asmVoid] .
3011 mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
3012 else if pk1 == FloatRep then
3013 asmParThen [code1 (promote src1), code2 asmVoid] .
3014 mkSeqInstr (instr DF tmp src2 dst)
3016 asmParThen [code1 asmVoid, code2 (promote src2)] .
3017 mkSeqInstr (instr DF src1 tmp dst)
3019 returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3022 trivialUCode instr x
3023 = getRegister x `thenUs` \ register ->
3024 getNewRegNCG IntRep `thenUs` \ tmp ->
3026 code = registerCode register tmp
3027 src = registerName register tmp
3028 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3030 returnUs (Any IntRep code__2)
3033 trivialUFCode pk instr x
3034 = getRegister x `thenUs` \ register ->
3035 getNewRegNCG pk `thenUs` \ tmp ->
3037 code = registerCode register tmp
3038 src = registerName register tmp
3039 code__2 dst = code . mkSeqInstr (instr src dst)
3041 returnUs (Any pk code__2)
3043 #endif {- sparc_TARGET_ARCH -}
3046 %************************************************************************
3048 \subsubsection{Coercing to/from integer/floating-point...}
3050 %************************************************************************
3052 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3053 to be generated. Here we just change the type on the Register passed
3054 on up. The code is machine-independent.
3056 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3057 conversions. We have to store temporaries in memory to move
3058 between the integer and the floating point register sets.
3061 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
3062 coerceFltCode :: StixTree -> UniqSM Register
3064 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
3065 coerceFP2Int :: StixTree -> UniqSM Register
3068 = getRegister x `thenUs` \ register ->
3071 Fixed _ reg code -> Fixed pk reg code
3072 Any _ code -> Any pk code
3077 = getRegister x `thenUs` \ register ->
3080 Fixed _ reg code -> Fixed DoubleRep reg code
3081 Any _ code -> Any DoubleRep code
3086 #if alpha_TARGET_ARCH
3089 = getRegister x `thenUs` \ register ->
3090 getNewRegNCG IntRep `thenUs` \ reg ->
3092 code = registerCode register reg
3093 src = registerName register reg
3095 code__2 dst = code . mkSeqInstrs [
3097 LD TF dst (spRel 0),
3100 returnUs (Any DoubleRep code__2)
3104 = getRegister x `thenUs` \ register ->
3105 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3107 code = registerCode register tmp
3108 src = registerName register tmp
3110 code__2 dst = code . mkSeqInstrs [
3112 ST TF tmp (spRel 0),
3115 returnUs (Any IntRep code__2)
3117 #endif {- alpha_TARGET_ARCH -}
3118 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3119 #if i386_TARGET_ARCH
3122 = getRegister x `thenUs` \ register ->
3123 getNewRegNCG IntRep `thenUs` \ reg ->
3125 code = registerCode register reg
3126 src = registerName register reg
3128 code__2 dst = code . mkSeqInstrs [
3129 -- to fix: should spill instead of using R1
3130 MOV L (OpReg src) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
3131 FILD (primRepToSize pk) (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
3133 returnUs (Any pk code__2)
3137 = getRegister x `thenUs` \ register ->
3138 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3140 code = registerCode register tmp
3141 src = registerName register tmp
3142 pk = registerRep register
3144 code__2 dst = code . mkSeqInstrs [
3146 FIST L (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)),
3147 MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
3149 returnUs (Any IntRep code__2)
3151 #endif {- i386_TARGET_ARCH -}
3152 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3153 #if sparc_TARGET_ARCH
3156 = getRegister x `thenUs` \ register ->
3157 getNewRegNCG IntRep `thenUs` \ reg ->
3159 code = registerCode register reg
3160 src = registerName register reg
3162 code__2 dst = code . mkSeqInstrs [
3163 ST W src (spRel (-2)),
3164 LD W (spRel (-2)) dst,
3165 FxTOy W (primRepToSize pk) dst dst]
3167 returnUs (Any pk code__2)
3171 = getRegister x `thenUs` \ register ->
3172 getNewRegNCG IntRep `thenUs` \ reg ->
3173 getNewRegNCG FloatRep `thenUs` \ tmp ->
3175 code = registerCode register reg
3176 src = registerName register reg
3177 pk = registerRep register
3179 code__2 dst = code . mkSeqInstrs [
3180 FxTOy (primRepToSize pk) W src tmp,
3181 ST W tmp (spRel (-2)),
3182 LD W (spRel (-2)) dst]
3184 returnUs (Any IntRep code__2)
3186 #endif {- sparc_TARGET_ARCH -}
3189 %************************************************************************
3191 \subsubsection{Coercing integer to @Char@...}
3193 %************************************************************************
3195 Integer to character conversion. Where applicable, we try to do this
3196 in one step if the original object is in memory.
3199 chrCode :: StixTree -> UniqSM Register
3201 #if alpha_TARGET_ARCH
3204 = getRegister x `thenUs` \ register ->
3205 getNewRegNCG IntRep `thenUs` \ reg ->
3207 code = registerCode register reg
3208 src = registerName register reg
3209 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3211 returnUs (Any IntRep code__2)
3213 #endif {- alpha_TARGET_ARCH -}
3214 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3215 #if i386_TARGET_ARCH
3218 = getRegister x `thenUs` \ register ->
3219 --getNewRegNCG IntRep `thenUs` \ reg ->
3222 code = registerCode register dst
3223 src = registerName register dst
3225 if isFixed register && src /= dst
3226 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3227 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3228 else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3230 returnUs (Any IntRep code__2)
3232 #endif {- i386_TARGET_ARCH -}
3233 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3234 #if sparc_TARGET_ARCH
3236 chrCode (StInd pk mem)
3237 = getAmode mem `thenUs` \ amode ->
3239 code = amodeCode amode
3240 src = amodeAddr amode
3241 src_off = addrOffset src 3
3242 src__2 = case src_off of Just x -> x
3243 code__2 dst = if maybeToBool src_off then
3244 code . mkSeqInstr (LD BU src__2 dst)
3246 code . mkSeqInstrs [
3247 LD (primRepToSize pk) src dst,
3248 AND False dst (RIImm (ImmInt 255)) dst]
3250 returnUs (Any pk code__2)
3253 = getRegister x `thenUs` \ register ->
3254 getNewRegNCG IntRep `thenUs` \ reg ->
3256 code = registerCode register reg
3257 src = registerName register reg
3258 code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3260 returnUs (Any IntRep code__2)
3262 #endif {- sparc_TARGET_ARCH -}