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( fake0, 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 d)
509 = getUniqLabelNCG `thenUs` \ lbl ->
510 let code dst = mkSeqInstrs [
513 DATA DF [ImmDouble d],
515 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
518 returnUs (Any DoubleRep code)
521 getRegister (StPrim primop [x]) -- unary PrimOps
523 IntNegOp -> trivialUCode (NEGI L) x
524 NotOp -> trivialUCode (NOT L) x
526 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
527 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
529 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
530 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
532 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
533 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
535 OrdOp -> coerceIntCode IntRep x
538 Float2IntOp -> coerceFP2Int x
539 Int2FloatOp -> coerceInt2FP FloatRep x
540 Double2IntOp -> coerceFP2Int x
541 Int2DoubleOp -> coerceInt2FP DoubleRep x
545 fixed_x = if is_float_op -- promote to double
546 then StPrim Float2DoubleOp [x]
549 getRegister (StCall fn cCallConv DoubleRep [x])
553 FloatExpOp -> (True, SLIT("exp"))
554 FloatLogOp -> (True, SLIT("log"))
556 FloatSinOp -> (True, SLIT("sin"))
557 FloatCosOp -> (True, SLIT("cos"))
558 FloatTanOp -> (True, SLIT("tan"))
560 FloatAsinOp -> (True, SLIT("asin"))
561 FloatAcosOp -> (True, SLIT("acos"))
562 FloatAtanOp -> (True, SLIT("atan"))
564 FloatSinhOp -> (True, SLIT("sinh"))
565 FloatCoshOp -> (True, SLIT("cosh"))
566 FloatTanhOp -> (True, SLIT("tanh"))
568 DoubleExpOp -> (False, SLIT("exp"))
569 DoubleLogOp -> (False, SLIT("log"))
571 DoubleSinOp -> (False, SLIT("sin"))
572 DoubleCosOp -> (False, SLIT("cos"))
573 DoubleTanOp -> (False, SLIT("tan"))
575 DoubleAsinOp -> (False, SLIT("asin"))
576 DoubleAcosOp -> (False, SLIT("acos"))
577 DoubleAtanOp -> (False, SLIT("atan"))
579 DoubleSinhOp -> (False, SLIT("sinh"))
580 DoubleCoshOp -> (False, SLIT("cosh"))
581 DoubleTanhOp -> (False, SLIT("tanh"))
583 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
585 CharGtOp -> condIntReg GTT x y
586 CharGeOp -> condIntReg GE x y
587 CharEqOp -> condIntReg EQQ x y
588 CharNeOp -> condIntReg NE x y
589 CharLtOp -> condIntReg LTT x y
590 CharLeOp -> condIntReg LE x y
592 IntGtOp -> condIntReg GTT x y
593 IntGeOp -> condIntReg GE x y
594 IntEqOp -> condIntReg EQQ x y
595 IntNeOp -> condIntReg NE x y
596 IntLtOp -> condIntReg LTT x y
597 IntLeOp -> condIntReg LE x y
599 WordGtOp -> condIntReg GU x y
600 WordGeOp -> condIntReg GEU x y
601 WordEqOp -> condIntReg EQQ x y
602 WordNeOp -> condIntReg NE x y
603 WordLtOp -> condIntReg LU x y
604 WordLeOp -> condIntReg LEU x y
606 AddrGtOp -> condIntReg GU x y
607 AddrGeOp -> condIntReg GEU x y
608 AddrEqOp -> condIntReg EQQ x y
609 AddrNeOp -> condIntReg NE x y
610 AddrLtOp -> condIntReg LU x y
611 AddrLeOp -> condIntReg LEU x y
613 FloatGtOp -> condFltReg GTT x y
614 FloatGeOp -> condFltReg GE x y
615 FloatEqOp -> condFltReg EQQ x y
616 FloatNeOp -> condFltReg NE x y
617 FloatLtOp -> condFltReg LTT x y
618 FloatLeOp -> condFltReg LE x y
620 DoubleGtOp -> condFltReg GTT x y
621 DoubleGeOp -> condFltReg GE x y
622 DoubleEqOp -> condFltReg EQQ x y
623 DoubleNeOp -> condFltReg NE x y
624 DoubleLtOp -> condFltReg LTT x y
625 DoubleLeOp -> condFltReg LE x y
627 IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)...
628 -- this should be optimised by the generic Opts,
629 -- I don't know why it is not (sometimes)!
631 [x, StInt 0] -> getRegister x
636 IntSubOp -> sub_code L x y
637 IntQuotOp -> quot_code L x y True{-division-}
638 IntRemOp -> quot_code L x y False{-remainder-}
639 IntMulOp -> trivialCode (IMUL L) x y {-True-}
641 FloatAddOp -> trivialFCode FloatRep GADD x y
642 FloatSubOp -> trivialFCode FloatRep GSUB x y
643 FloatMulOp -> trivialFCode FloatRep GMUL x y
644 FloatDivOp -> trivialFCode FloatRep GDIV x y
646 DoubleAddOp -> trivialFCode DoubleRep GADD x y
647 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
648 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
649 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
651 AndOp -> trivialCode (AND L) x y {-True-}
652 OrOp -> trivialCode (OR L) x y {-True-}
653 XorOp -> trivialCode (XOR L) x y {-True-}
655 {- Shift ops on x86s have constraints on their source, it
656 either has to be Imm, CL or 1
657 => trivialCode's is not restrictive enough (sigh.)
660 SllOp -> shift_code (SHL L) x y {-False-}
661 SrlOp -> shift_code (SHR L) x y {-False-}
663 ISllOp -> shift_code (SHL L) x y {-False-}
664 ISraOp -> shift_code (SAR L) x y {-False-}
665 ISrlOp -> shift_code (SHR L) x y {-False-}
667 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
668 [promote x, promote y])
669 where promote x = StPrim Float2DoubleOp [x]
670 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
675 shift_code :: (Operand -> Operand -> Instr)
680 {- Case1: shift length as immediate -}
681 -- Code is the same as the first eq. for trivialCode -- sigh.
682 shift_code instr x y{-amount-}
684 = getRegister x `thenUs` \ register ->
686 op_imm = OpImm imm__2
689 code = registerCode register dst
690 src = registerName register dst
692 mkSeqInstr (COMMENT SLIT("shift_code")) .
694 if isFixed register && src /= dst
696 mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
697 instr op_imm (OpReg dst)]
699 mkSeqInstr (instr op_imm (OpReg src))
701 returnUs (Any IntRep code__2)
704 imm__2 = case imm of Just x -> x
706 {- Case2: shift length is complex (non-immediate) -}
707 shift_code instr x y{-amount-}
708 = getRegister y `thenUs` \ register1 ->
709 getRegister x `thenUs` \ register2 ->
711 -- Note: we force the shift length to be loaded
712 -- into ECX, so that we can use CL when shifting.
713 -- (only register location we are allowed
714 -- to put shift amounts.)
716 -- The shift instruction is fed ECX as src reg,
717 -- but we coerce this into CL when printing out.
718 src1 = registerName register1 ecx
719 code1 = if src1 /= ecx then -- if it is not in ecx already, force it!
720 registerCode register1 ecx .
721 mkSeqInstr (MOV L (OpReg src1) (OpReg ecx))
723 registerCode register1 ecx
726 code2 = registerCode register2 eax
727 src2 = registerName register2 eax
730 mkSeqInstr (instr (OpReg ecx) (OpReg eax))
732 returnUs (Fixed IntRep eax code__2)
735 add_code :: Size -> StixTree -> StixTree -> UniqSM Register
737 add_code sz x (StInt y)
738 = getRegister x `thenUs` \ register ->
739 getNewRegNCG IntRep `thenUs` \ tmp ->
741 code = registerCode register tmp
742 src1 = registerName register tmp
743 src2 = ImmInt (fromInteger y)
746 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
749 returnUs (Any IntRep code__2)
752 = getRegister x `thenUs` \ register1 ->
753 getRegister y `thenUs` \ register2 ->
754 getNewRegNCG IntRep `thenUs` \ tmp1 ->
755 getNewRegNCG IntRep `thenUs` \ tmp2 ->
757 code1 = registerCode register1 tmp1 asmVoid
758 src1 = registerName register1 tmp1
759 code2 = registerCode register2 tmp2 asmVoid
760 src2 = registerName register2 tmp2
762 = asmParThen [code1, code2] .
763 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1))
767 returnUs (Any IntRep code__2)
770 sub_code :: Size -> StixTree -> StixTree -> UniqSM Register
772 sub_code sz x (StInt y)
773 = getRegister x `thenUs` \ register ->
774 getNewRegNCG IntRep `thenUs` \ tmp ->
776 code = registerCode register tmp
777 src1 = registerName register tmp
778 src2 = ImmInt (-(fromInteger y))
781 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
784 returnUs (Any IntRep code__2)
786 sub_code sz x y = trivialCode (SUB sz) x y {-False-}
791 -> StixTree -> StixTree
792 -> Bool -- True => division, False => remainder operation
795 -- x must go into eax, edx must be a sign-extension of eax, and y
796 -- should go in some other register (or memory), so that we get
797 -- edx:eax / reg -> eax (remainder in edx) Currently we chose to
798 -- put y in memory (if it is not there already)
800 quot_code sz x (StInd pk mem) is_division
801 = getRegister x `thenUs` \ register1 ->
802 getNewRegNCG IntRep `thenUs` \ tmp1 ->
803 getAmode mem `thenUs` \ amode ->
805 code1 = registerCode register1 tmp1 asmVoid
806 src1 = registerName register1 tmp1
807 code2 = amodeCode amode asmVoid
808 src2 = amodeAddr amode
809 code__2 = asmParThen [code1, code2] .
810 mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
812 IDIV sz (OpAddr src2)]
814 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
816 quot_code sz x (StInt i) is_division
817 = getRegister x `thenUs` \ register1 ->
818 getNewRegNCG IntRep `thenUs` \ tmp1 ->
820 code1 = registerCode register1 tmp1 asmVoid
821 src1 = registerName register1 tmp1
822 src2 = ImmInt (fromInteger i)
823 code__2 = asmParThen [code1] .
824 mkSeqInstrs [-- we put src2 in (ebx)
826 (OpAddr (AddrBaseIndex (Just ebx) Nothing
827 (ImmInt OFFSET_R1))),
828 MOV L (OpReg src1) (OpReg eax),
830 IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing
834 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
836 quot_code sz x y is_division
837 = getRegister x `thenUs` \ register1 ->
838 getNewRegNCG IntRep `thenUs` \ tmp1 ->
839 getRegister y `thenUs` \ register2 ->
840 getNewRegNCG IntRep `thenUs` \ tmp2 ->
842 code1 = registerCode register1 tmp1 asmVoid
843 src1 = registerName register1 tmp1
844 code2 = registerCode register2 tmp2 asmVoid
845 src2 = registerName register2 tmp2
846 code__2 = asmParThen [code1, code2] .
847 if src2 == ecx || src2 == esi
849 MOV L (OpReg src1) (OpReg eax),
853 else mkSeqInstrs [ -- we put src2 in (ebx)
855 (OpAddr (AddrBaseIndex (Just ebx) Nothing
856 (ImmInt OFFSET_R1))),
857 MOV L (OpReg src1) (OpReg eax),
859 IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing
863 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
864 -----------------------
866 getRegister (StInd pk mem)
867 = getAmode mem `thenUs` \ amode ->
869 code = amodeCode amode
870 src = amodeAddr amode
871 size = primRepToSize pk
873 if pk == DoubleRep || pk == FloatRep
874 then mkSeqInstr (GLD size src dst)
875 else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
877 returnUs (Any pk code__2)
879 getRegister (StInt i)
881 src = ImmInt (fromInteger i)
882 code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
884 returnUs (Any IntRep code)
889 code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
891 returnUs (Any PtrRep code)
894 imm__2 = case imm of Just x -> x
896 #endif {- i386_TARGET_ARCH -}
897 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
898 #if sparc_TARGET_ARCH
900 getRegister (StDouble d)
901 = getUniqLabelNCG `thenUs` \ lbl ->
902 getNewRegNCG PtrRep `thenUs` \ tmp ->
903 let code dst = mkSeqInstrs [
906 DATA DF [ImmDouble d],
908 SETHI (HI (ImmCLbl lbl)) tmp,
909 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
911 returnUs (Any DoubleRep code)
913 getRegister (StPrim primop [x]) -- unary PrimOps
915 IntNegOp -> trivialUCode (SUB False False g0) x
916 NotOp -> trivialUCode (XNOR False g0) x
918 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
920 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
922 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
923 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
925 OrdOp -> coerceIntCode IntRep x
928 Float2IntOp -> coerceFP2Int x
929 Int2FloatOp -> coerceInt2FP FloatRep x
930 Double2IntOp -> coerceFP2Int x
931 Int2DoubleOp -> coerceInt2FP DoubleRep x
935 fixed_x = if is_float_op -- promote to double
936 then StPrim Float2DoubleOp [x]
939 getRegister (StCall fn cCallConv DoubleRep [x])
943 FloatExpOp -> (True, SLIT("exp"))
944 FloatLogOp -> (True, SLIT("log"))
945 FloatSqrtOp -> (True, SLIT("sqrt"))
947 FloatSinOp -> (True, SLIT("sin"))
948 FloatCosOp -> (True, SLIT("cos"))
949 FloatTanOp -> (True, SLIT("tan"))
951 FloatAsinOp -> (True, SLIT("asin"))
952 FloatAcosOp -> (True, SLIT("acos"))
953 FloatAtanOp -> (True, SLIT("atan"))
955 FloatSinhOp -> (True, SLIT("sinh"))
956 FloatCoshOp -> (True, SLIT("cosh"))
957 FloatTanhOp -> (True, SLIT("tanh"))
959 DoubleExpOp -> (False, SLIT("exp"))
960 DoubleLogOp -> (False, SLIT("log"))
961 DoubleSqrtOp -> (True, SLIT("sqrt"))
963 DoubleSinOp -> (False, SLIT("sin"))
964 DoubleCosOp -> (False, SLIT("cos"))
965 DoubleTanOp -> (False, SLIT("tan"))
967 DoubleAsinOp -> (False, SLIT("asin"))
968 DoubleAcosOp -> (False, SLIT("acos"))
969 DoubleAtanOp -> (False, SLIT("atan"))
971 DoubleSinhOp -> (False, SLIT("sinh"))
972 DoubleCoshOp -> (False, SLIT("cosh"))
973 DoubleTanhOp -> (False, SLIT("tanh"))
974 _ -> panic ("Monadic PrimOp not handled: " ++ show primop)
976 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
978 CharGtOp -> condIntReg GTT x y
979 CharGeOp -> condIntReg GE x y
980 CharEqOp -> condIntReg EQQ x y
981 CharNeOp -> condIntReg NE x y
982 CharLtOp -> condIntReg LTT x y
983 CharLeOp -> condIntReg LE x y
985 IntGtOp -> condIntReg GTT x y
986 IntGeOp -> condIntReg GE x y
987 IntEqOp -> condIntReg EQQ x y
988 IntNeOp -> condIntReg NE x y
989 IntLtOp -> condIntReg LTT x y
990 IntLeOp -> condIntReg LE x y
992 WordGtOp -> condIntReg GU x y
993 WordGeOp -> condIntReg GEU x y
994 WordEqOp -> condIntReg EQQ x y
995 WordNeOp -> condIntReg NE x y
996 WordLtOp -> condIntReg LU x y
997 WordLeOp -> condIntReg LEU x y
999 AddrGtOp -> condIntReg GU x y
1000 AddrGeOp -> condIntReg GEU x y
1001 AddrEqOp -> condIntReg EQQ x y
1002 AddrNeOp -> condIntReg NE x y
1003 AddrLtOp -> condIntReg LU x y
1004 AddrLeOp -> condIntReg LEU x y
1006 FloatGtOp -> condFltReg GTT x y
1007 FloatGeOp -> condFltReg GE x y
1008 FloatEqOp -> condFltReg EQQ x y
1009 FloatNeOp -> condFltReg NE x y
1010 FloatLtOp -> condFltReg LTT x y
1011 FloatLeOp -> condFltReg LE x y
1013 DoubleGtOp -> condFltReg GTT x y
1014 DoubleGeOp -> condFltReg GE x y
1015 DoubleEqOp -> condFltReg EQQ x y
1016 DoubleNeOp -> condFltReg NE x y
1017 DoubleLtOp -> condFltReg LTT x y
1018 DoubleLeOp -> condFltReg LE x y
1020 IntAddOp -> trivialCode (ADD False False) x y
1021 IntSubOp -> trivialCode (SUB False False) x y
1023 -- ToDo: teach about V8+ SPARC mul/div instructions
1024 IntMulOp -> imul_div SLIT(".umul") x y
1025 IntQuotOp -> imul_div SLIT(".div") x y
1026 IntRemOp -> imul_div SLIT(".rem") x y
1028 FloatAddOp -> trivialFCode FloatRep FADD x y
1029 FloatSubOp -> trivialFCode FloatRep FSUB x y
1030 FloatMulOp -> trivialFCode FloatRep FMUL x y
1031 FloatDivOp -> trivialFCode FloatRep FDIV x y
1033 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1034 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1035 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1036 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1038 AndOp -> trivialCode (AND False) x y
1039 OrOp -> trivialCode (OR False) x y
1040 XorOp -> trivialCode (XOR False) x y
1041 SllOp -> trivialCode SLL x y
1042 SrlOp -> trivialCode SRL x y
1044 ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
1045 ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
1046 ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
1048 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
1049 where promote x = StPrim Float2DoubleOp [x]
1050 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
1051 -- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
1053 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1055 getRegister (StInd pk mem)
1056 = getAmode mem `thenUs` \ amode ->
1058 code = amodeCode amode
1059 src = amodeAddr amode
1060 size = primRepToSize pk
1061 code__2 dst = code . mkSeqInstr (LD size src dst)
1063 returnUs (Any pk code__2)
1065 getRegister (StInt i)
1068 src = ImmInt (fromInteger i)
1069 code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
1071 returnUs (Any IntRep code)
1076 code dst = mkSeqInstrs [
1077 SETHI (HI imm__2) dst,
1078 OR False dst (RIImm (LO imm__2)) dst]
1080 returnUs (Any PtrRep code)
1083 imm__2 = case imm of Just x -> x
1085 #endif {- sparc_TARGET_ARCH -}
1088 %************************************************************************
1090 \subsection{The @Amode@ type}
1092 %************************************************************************
1094 @Amode@s: Memory addressing modes passed up the tree.
1096 data Amode = Amode MachRegsAddr InstrBlock
1098 amodeAddr (Amode addr _) = addr
1099 amodeCode (Amode _ code) = code
1102 Now, given a tree (the argument to an StInd) that references memory,
1103 produce a suitable addressing mode.
1106 getAmode :: StixTree -> UniqSM Amode
1108 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1110 #if alpha_TARGET_ARCH
1112 getAmode (StPrim IntSubOp [x, StInt i])
1113 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1114 getRegister x `thenUs` \ register ->
1116 code = registerCode register tmp
1117 reg = registerName register tmp
1118 off = ImmInt (-(fromInteger i))
1120 returnUs (Amode (AddrRegImm reg off) code)
1122 getAmode (StPrim IntAddOp [x, StInt i])
1123 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1124 getRegister x `thenUs` \ register ->
1126 code = registerCode register tmp
1127 reg = registerName register tmp
1128 off = ImmInt (fromInteger i)
1130 returnUs (Amode (AddrRegImm reg off) code)
1134 = returnUs (Amode (AddrImm imm__2) id)
1137 imm__2 = case imm of Just x -> x
1140 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1141 getRegister other `thenUs` \ register ->
1143 code = registerCode register tmp
1144 reg = registerName register tmp
1146 returnUs (Amode (AddrReg reg) code)
1148 #endif {- alpha_TARGET_ARCH -}
1149 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1150 #if i386_TARGET_ARCH
1152 getAmode (StPrim IntSubOp [x, StInt i])
1153 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1154 getRegister x `thenUs` \ register ->
1156 code = registerCode register tmp
1157 reg = registerName register tmp
1158 off = ImmInt (-(fromInteger i))
1160 returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1162 getAmode (StPrim IntAddOp [x, StInt i])
1165 code = mkSeqInstrs []
1167 returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
1170 imm__2 = case imm of Just x -> x
1172 getAmode (StPrim IntAddOp [x, StInt i])
1173 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1174 getRegister x `thenUs` \ register ->
1176 code = registerCode register tmp
1177 reg = registerName register tmp
1178 off = ImmInt (fromInteger i)
1180 returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1182 getAmode (StPrim IntAddOp [x, y])
1183 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1184 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1185 getRegister x `thenUs` \ register1 ->
1186 getRegister y `thenUs` \ register2 ->
1188 code1 = registerCode register1 tmp1 asmVoid
1189 reg1 = registerName register1 tmp1
1190 code2 = registerCode register2 tmp2 asmVoid
1191 reg2 = registerName register2 tmp2
1192 code__2 = asmParThen [code1, code2]
1194 returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
1199 code = mkSeqInstrs []
1201 returnUs (Amode (ImmAddr imm__2 0) code)
1204 imm__2 = case imm of Just x -> x
1207 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1208 getRegister other `thenUs` \ register ->
1210 code = registerCode register tmp
1211 reg = registerName register tmp
1214 returnUs (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1216 #endif {- i386_TARGET_ARCH -}
1217 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1218 #if sparc_TARGET_ARCH
1220 getAmode (StPrim IntSubOp [x, StInt i])
1222 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1223 getRegister x `thenUs` \ register ->
1225 code = registerCode register tmp
1226 reg = registerName register tmp
1227 off = ImmInt (-(fromInteger i))
1229 returnUs (Amode (AddrRegImm reg off) code)
1232 getAmode (StPrim IntAddOp [x, StInt i])
1234 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1235 getRegister x `thenUs` \ register ->
1237 code = registerCode register tmp
1238 reg = registerName register tmp
1239 off = ImmInt (fromInteger i)
1241 returnUs (Amode (AddrRegImm reg off) code)
1243 getAmode (StPrim IntAddOp [x, y])
1244 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1245 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1246 getRegister x `thenUs` \ register1 ->
1247 getRegister y `thenUs` \ register2 ->
1249 code1 = registerCode register1 tmp1 asmVoid
1250 reg1 = registerName register1 tmp1
1251 code2 = registerCode register2 tmp2 asmVoid
1252 reg2 = registerName register2 tmp2
1253 code__2 = asmParThen [code1, code2]
1255 returnUs (Amode (AddrRegReg reg1 reg2) code__2)
1259 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1261 code = mkSeqInstr (SETHI (HI imm__2) tmp)
1263 returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
1266 imm__2 = case imm of Just x -> x
1269 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1270 getRegister other `thenUs` \ register ->
1272 code = registerCode register tmp
1273 reg = registerName register tmp
1276 returnUs (Amode (AddrRegImm reg off) code)
1278 #endif {- sparc_TARGET_ARCH -}
1281 %************************************************************************
1283 \subsection{The @CondCode@ type}
1285 %************************************************************************
1287 Condition codes passed up the tree.
1289 data CondCode = CondCode Bool Cond InstrBlock
1291 condName (CondCode _ cond _) = cond
1292 condFloat (CondCode is_float _ _) = is_float
1293 condCode (CondCode _ _ code) = code
1296 Set up a condition code for a conditional branch.
1299 getCondCode :: StixTree -> UniqSM CondCode
1301 #if alpha_TARGET_ARCH
1302 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1303 #endif {- alpha_TARGET_ARCH -}
1304 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1306 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1307 -- yes, they really do seem to want exactly the same!
1309 getCondCode (StPrim primop [x, y])
1311 CharGtOp -> condIntCode GTT x y
1312 CharGeOp -> condIntCode GE x y
1313 CharEqOp -> condIntCode EQQ x y
1314 CharNeOp -> condIntCode NE x y
1315 CharLtOp -> condIntCode LTT x y
1316 CharLeOp -> condIntCode LE x y
1318 IntGtOp -> condIntCode GTT x y
1319 IntGeOp -> condIntCode GE x y
1320 IntEqOp -> condIntCode EQQ x y
1321 IntNeOp -> condIntCode NE x y
1322 IntLtOp -> condIntCode LTT x y
1323 IntLeOp -> condIntCode LE x y
1325 WordGtOp -> condIntCode GU x y
1326 WordGeOp -> condIntCode GEU x y
1327 WordEqOp -> condIntCode EQQ x y
1328 WordNeOp -> condIntCode NE x y
1329 WordLtOp -> condIntCode LU x y
1330 WordLeOp -> condIntCode LEU x y
1332 AddrGtOp -> condIntCode GU x y
1333 AddrGeOp -> condIntCode GEU x y
1334 AddrEqOp -> condIntCode EQQ x y
1335 AddrNeOp -> condIntCode NE x y
1336 AddrLtOp -> condIntCode LU x y
1337 AddrLeOp -> condIntCode LEU x y
1339 FloatGtOp -> condFltCode GTT x y
1340 FloatGeOp -> condFltCode GE x y
1341 FloatEqOp -> condFltCode EQQ x y
1342 FloatNeOp -> condFltCode NE x y
1343 FloatLtOp -> condFltCode LTT x y
1344 FloatLeOp -> condFltCode LE x y
1346 DoubleGtOp -> condFltCode GTT x y
1347 DoubleGeOp -> condFltCode GE x y
1348 DoubleEqOp -> condFltCode EQQ x y
1349 DoubleNeOp -> condFltCode NE x y
1350 DoubleLtOp -> condFltCode LTT x y
1351 DoubleLeOp -> condFltCode LE x y
1353 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1358 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1359 passed back up the tree.
1362 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode
1364 #if alpha_TARGET_ARCH
1365 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1366 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1367 #endif {- alpha_TARGET_ARCH -}
1369 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1370 #if i386_TARGET_ARCH
1372 condIntCode cond (StInd _ x) y
1374 = getAmode x `thenUs` \ amode ->
1376 code1 = amodeCode amode asmVoid
1377 y__2 = amodeAddr amode
1378 code__2 = asmParThen [code1] .
1379 mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
1381 returnUs (CondCode False cond code__2)
1384 imm__2 = case imm of Just x -> x
1386 condIntCode cond x (StInt 0)
1387 = getRegister x `thenUs` \ register1 ->
1388 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1390 code1 = registerCode register1 tmp1 asmVoid
1391 src1 = registerName register1 tmp1
1392 code__2 = asmParThen [code1] .
1393 mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
1395 returnUs (CondCode False cond code__2)
1397 condIntCode cond x y
1399 = getRegister x `thenUs` \ register1 ->
1400 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1402 code1 = registerCode register1 tmp1 asmVoid
1403 src1 = registerName register1 tmp1
1404 code__2 = asmParThen [code1] .
1405 mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
1407 returnUs (CondCode False cond code__2)
1410 imm__2 = case imm of Just x -> x
1412 condIntCode cond (StInd _ x) y
1413 = getAmode x `thenUs` \ amode ->
1414 getRegister y `thenUs` \ register2 ->
1415 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1417 code1 = amodeCode amode asmVoid
1418 src1 = amodeAddr amode
1419 code2 = registerCode register2 tmp2 asmVoid
1420 src2 = registerName register2 tmp2
1421 code__2 = asmParThen [code1, code2] .
1422 mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
1424 returnUs (CondCode False cond code__2)
1426 condIntCode cond y (StInd _ x)
1427 = getAmode x `thenUs` \ amode ->
1428 getRegister y `thenUs` \ register2 ->
1429 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1431 code1 = amodeCode amode asmVoid
1432 src1 = amodeAddr amode
1433 code2 = registerCode register2 tmp2 asmVoid
1434 src2 = registerName register2 tmp2
1435 code__2 = asmParThen [code1, code2] .
1436 mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
1438 returnUs (CondCode False cond code__2)
1440 condIntCode cond x y
1441 = getRegister x `thenUs` \ register1 ->
1442 getRegister y `thenUs` \ register2 ->
1443 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1444 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1446 code1 = registerCode register1 tmp1 asmVoid
1447 src1 = registerName register1 tmp1
1448 code2 = registerCode register2 tmp2 asmVoid
1449 src2 = registerName register2 tmp2
1450 code__2 = asmParThen [code1, code2] .
1451 mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
1453 returnUs (CondCode False cond code__2)
1456 condFltCode cond x y
1457 = getRegister x `thenUs` \ register1 ->
1458 getRegister y `thenUs` \ register2 ->
1459 getNewRegNCG (registerRep register1)
1461 getNewRegNCG (registerRep register2)
1463 getNewRegNCG DoubleRep `thenUs` \ tmp ->
1465 pk1 = registerRep register1
1466 code1 = registerCode register1 tmp1
1467 src1 = registerName register1 tmp1
1469 pk2 = registerRep register2
1470 code2 = registerCode register2 tmp2
1471 src2 = registerName register2 tmp2
1473 code__2 = asmParThen [code1 asmVoid, code2 asmVoid] .
1474 mkSeqInstr (GCMP (primRepToSize pk1) src1 src2)
1476 {- On the 486, the flags set by FP compare are the unsigned ones!
1477 (This looks like a HACK to me. WDP 96/03)
1479 fix_FP_cond :: Cond -> Cond
1481 fix_FP_cond GE = GEU
1482 fix_FP_cond GTT = GU
1483 fix_FP_cond LTT = LU
1484 fix_FP_cond LE = LEU
1485 fix_FP_cond any = any
1487 returnUs (CondCode True (fix_FP_cond cond) code__2)
1491 #endif {- i386_TARGET_ARCH -}
1492 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1493 #if sparc_TARGET_ARCH
1495 condIntCode cond x (StInt y)
1497 = getRegister x `thenUs` \ register ->
1498 getNewRegNCG IntRep `thenUs` \ tmp ->
1500 code = registerCode register tmp
1501 src1 = registerName register tmp
1502 src2 = ImmInt (fromInteger y)
1503 code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
1505 returnUs (CondCode False cond code__2)
1507 condIntCode cond x y
1508 = getRegister x `thenUs` \ register1 ->
1509 getRegister y `thenUs` \ register2 ->
1510 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1511 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1513 code1 = registerCode register1 tmp1 asmVoid
1514 src1 = registerName register1 tmp1
1515 code2 = registerCode register2 tmp2 asmVoid
1516 src2 = registerName register2 tmp2
1517 code__2 = asmParThen [code1, code2] .
1518 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
1520 returnUs (CondCode False cond code__2)
1523 condFltCode cond x y
1524 = getRegister x `thenUs` \ register1 ->
1525 getRegister y `thenUs` \ register2 ->
1526 getNewRegNCG (registerRep register1)
1528 getNewRegNCG (registerRep register2)
1530 getNewRegNCG DoubleRep `thenUs` \ tmp ->
1532 promote x = asmInstr (FxTOy F DF x tmp)
1534 pk1 = registerRep register1
1535 code1 = registerCode register1 tmp1
1536 src1 = registerName register1 tmp1
1538 pk2 = registerRep register2
1539 code2 = registerCode register2 tmp2
1540 src2 = registerName register2 tmp2
1544 asmParThen [code1 asmVoid, code2 asmVoid] .
1545 mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
1546 else if pk1 == FloatRep then
1547 asmParThen [code1 (promote src1), code2 asmVoid] .
1548 mkSeqInstr (FCMP True DF tmp src2)
1550 asmParThen [code1 asmVoid, code2 (promote src2)] .
1551 mkSeqInstr (FCMP True DF src1 tmp)
1553 returnUs (CondCode True cond code__2)
1555 #endif {- sparc_TARGET_ARCH -}
1558 %************************************************************************
1560 \subsection{Generating assignments}
1562 %************************************************************************
1564 Assignments are really at the heart of the whole code generation
1565 business. Almost all top-level nodes of any real importance are
1566 assignments, which correspond to loads, stores, or register transfers.
1567 If we're really lucky, some of the register transfers will go away,
1568 because we can use the destination register to complete the code
1569 generation for the right hand side. This only fails when the right
1570 hand side is forced into a fixed register (e.g. the result of a call).
1573 assignIntCode, assignFltCode
1574 :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
1576 #if alpha_TARGET_ARCH
1578 assignIntCode pk (StInd _ dst) src
1579 = getNewRegNCG IntRep `thenUs` \ tmp ->
1580 getAmode dst `thenUs` \ amode ->
1581 getRegister src `thenUs` \ register ->
1583 code1 = amodeCode amode asmVoid
1584 dst__2 = amodeAddr amode
1585 code2 = registerCode register tmp asmVoid
1586 src__2 = registerName register tmp
1587 sz = primRepToSize pk
1588 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1592 assignIntCode pk dst src
1593 = getRegister dst `thenUs` \ register1 ->
1594 getRegister src `thenUs` \ register2 ->
1596 dst__2 = registerName register1 zeroh
1597 code = registerCode register2 dst__2
1598 src__2 = registerName register2 dst__2
1599 code__2 = if isFixed register2
1600 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1605 #endif {- alpha_TARGET_ARCH -}
1606 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1607 #if i386_TARGET_ARCH
1609 assignIntCode pk (StInd _ dst) src
1610 = getAmode dst `thenUs` \ amode ->
1611 get_op_RI src `thenUs` \ (codesrc, opsrc, sz) ->
1613 code1 = amodeCode amode asmVoid
1614 dst__2 = amodeAddr amode
1615 code__2 = asmParThen [code1, codesrc asmVoid] .
1616 mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
1622 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
1626 = returnUs (asmParThen [], OpImm imm_op, L)
1629 imm_op = case imm of Just x -> x
1632 = getRegister op `thenUs` \ register ->
1633 getNewRegNCG (registerRep register)
1636 code = registerCode register tmp
1637 reg = registerName register tmp
1638 pk = registerRep register
1639 sz = primRepToSize pk
1641 returnUs (code, OpReg reg, sz)
1643 assignIntCode pk dst (StInd _ src)
1644 = getNewRegNCG IntRep `thenUs` \ tmp ->
1645 getAmode src `thenUs` \ amode ->
1646 getRegister dst `thenUs` \ register ->
1648 code1 = amodeCode amode asmVoid
1649 src__2 = amodeAddr amode
1650 code2 = registerCode register tmp asmVoid
1651 dst__2 = registerName register tmp
1652 sz = primRepToSize pk
1653 code__2 = asmParThen [code1, code2] .
1654 mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
1658 assignIntCode pk dst src
1659 = getRegister dst `thenUs` \ register1 ->
1660 getRegister src `thenUs` \ register2 ->
1661 getNewRegNCG IntRep `thenUs` \ tmp ->
1663 dst__2 = registerName register1 tmp
1664 code = registerCode register2 dst__2
1665 src__2 = registerName register2 dst__2
1666 code__2 = if isFixed register2 && dst__2 /= src__2
1667 then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
1672 #endif {- i386_TARGET_ARCH -}
1673 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1674 #if sparc_TARGET_ARCH
1676 assignIntCode pk (StInd _ dst) src
1677 = getNewRegNCG IntRep `thenUs` \ tmp ->
1678 getAmode dst `thenUs` \ amode ->
1679 getRegister src `thenUs` \ register ->
1681 code1 = amodeCode amode asmVoid
1682 dst__2 = amodeAddr amode
1683 code2 = registerCode register tmp asmVoid
1684 src__2 = registerName register tmp
1685 sz = primRepToSize pk
1686 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1690 assignIntCode pk dst src
1691 = getRegister dst `thenUs` \ register1 ->
1692 getRegister src `thenUs` \ register2 ->
1694 dst__2 = registerName register1 g0
1695 code = registerCode register2 dst__2
1696 src__2 = registerName register2 dst__2
1697 code__2 = if isFixed register2
1698 then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
1703 #endif {- sparc_TARGET_ARCH -}
1706 % --------------------------------
1707 Floating-point assignments:
1708 % --------------------------------
1710 #if alpha_TARGET_ARCH
1712 assignFltCode pk (StInd _ dst) src
1713 = getNewRegNCG pk `thenUs` \ tmp ->
1714 getAmode dst `thenUs` \ amode ->
1715 getRegister src `thenUs` \ register ->
1717 code1 = amodeCode amode asmVoid
1718 dst__2 = amodeAddr amode
1719 code2 = registerCode register tmp asmVoid
1720 src__2 = registerName register tmp
1721 sz = primRepToSize pk
1722 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1726 assignFltCode pk dst src
1727 = getRegister dst `thenUs` \ register1 ->
1728 getRegister src `thenUs` \ register2 ->
1730 dst__2 = registerName register1 zeroh
1731 code = registerCode register2 dst__2
1732 src__2 = registerName register2 dst__2
1733 code__2 = if isFixed register2
1734 then code . mkSeqInstr (FMOV src__2 dst__2)
1739 #endif {- alpha_TARGET_ARCH -}
1740 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1741 #if i386_TARGET_ARCH
1743 assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
1744 = getNewRegNCG IntRep `thenUs` \ tmp ->
1745 getAmode src `thenUs` \ amodesrc ->
1746 getAmode dst `thenUs` \ amodedst ->
1748 codesrc1 = amodeCode amodesrc asmVoid
1749 addrsrc1 = amodeAddr amodesrc
1750 codedst1 = amodeCode amodedst asmVoid
1751 addrdst1 = amodeAddr amodedst
1752 addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x
1753 addrdst2 = case (addrOffset addrdst1 4) of Just x -> x
1755 code__2 = asmParThen [codesrc1, codedst1] .
1756 mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
1757 MOV L (OpReg tmp) (OpAddr addrdst1)]
1760 then [MOV L (OpAddr addrsrc2) (OpReg tmp),
1761 MOV L (OpReg tmp) (OpAddr addrdst2)]
1766 assignFltCode pk (StInd _ dst) src
1767 = getNewRegNCG pk `thenUs` \ tmp ->
1768 getAmode dst `thenUs` \ amode ->
1769 getRegister src `thenUs` \ register ->
1771 sz = primRepToSize pk
1772 dst__2 = amodeAddr amode
1774 code1 = amodeCode amode asmVoid
1775 code2 = registerCode register tmp asmVoid
1777 src__2 = registerName register tmp
1779 code__2 = asmParThen [code1, code2] .
1780 mkSeqInstr (GST sz src__2 dst__2)
1784 assignFltCode pk dst src
1785 = getRegister dst `thenUs` \ register1 ->
1786 getRegister src `thenUs` \ register2 ->
1787 getNewRegNCG pk `thenUs` \ tmp ->
1789 -- the register which is dst
1790 dst__2 = registerName register1 tmp
1791 -- the register into which src is computed, preferably dst__2
1792 src__2 = registerName register2 dst__2
1793 -- code to compute src into src__2
1794 code = registerCode register2 dst__2
1796 code__2 = if isFixed register2
1797 then code . mkSeqInstr (GMOV src__2 dst__2)
1802 #endif {- i386_TARGET_ARCH -}
1803 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1804 #if sparc_TARGET_ARCH
1806 assignFltCode pk (StInd _ dst) src
1807 = getNewRegNCG pk `thenUs` \ tmp1 ->
1808 getAmode dst `thenUs` \ amode ->
1809 getRegister src `thenUs` \ register ->
1811 sz = primRepToSize pk
1812 dst__2 = amodeAddr amode
1814 code1 = amodeCode amode asmVoid
1815 code2 = registerCode register tmp1 asmVoid
1817 src__2 = registerName register tmp1
1818 pk__2 = registerRep register
1819 sz__2 = primRepToSize pk__2
1821 code__2 = asmParThen [code1, code2] .
1823 mkSeqInstr (ST sz src__2 dst__2)
1825 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1829 assignFltCode pk dst src
1830 = getRegister dst `thenUs` \ register1 ->
1831 getRegister src `thenUs` \ register2 ->
1833 pk__2 = registerRep register2
1834 sz__2 = primRepToSize pk__2
1836 getNewRegNCG pk__2 `thenUs` \ tmp ->
1838 sz = primRepToSize pk
1839 dst__2 = registerName register1 g0 -- must be Fixed
1842 reg__2 = if pk /= pk__2 then tmp else dst__2
1844 code = registerCode register2 reg__2
1846 src__2 = registerName register2 reg__2
1850 code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
1851 else if isFixed register2 then
1852 code . mkSeqInstr (FMOV sz src__2 dst__2)
1858 #endif {- sparc_TARGET_ARCH -}
1861 %************************************************************************
1863 \subsection{Generating an unconditional branch}
1865 %************************************************************************
1867 We accept two types of targets: an immediate CLabel or a tree that
1868 gets evaluated into a register. Any CLabels which are AsmTemporaries
1869 are assumed to be in the local block of code, close enough for a
1870 branch instruction. Other CLabels are assumed to be far away.
1872 (If applicable) Do not fill the delay slots here; you will confuse the
1876 genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
1878 #if alpha_TARGET_ARCH
1880 genJump (StCLbl lbl)
1881 | isAsmTemp lbl = returnInstr (BR target)
1882 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1884 target = ImmCLbl lbl
1887 = getRegister tree `thenUs` \ register ->
1888 getNewRegNCG PtrRep `thenUs` \ tmp ->
1890 dst = registerName register pv
1891 code = registerCode register pv
1892 target = registerName register pv
1894 if isFixed register then
1895 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1897 returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1899 #endif {- alpha_TARGET_ARCH -}
1900 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1901 #if i386_TARGET_ARCH
1904 genJump (StCLbl lbl)
1905 | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
1906 | otherwise = returnInstrs [JMP (OpImm target)]
1908 target = ImmCLbl lbl
1911 genJump (StInd pk mem)
1912 = getAmode mem `thenUs` \ amode ->
1914 code = amodeCode amode
1915 target = amodeAddr amode
1917 returnSeq code [JMP (OpAddr target)]
1921 = returnInstr (JMP (OpImm target))
1924 = getRegister tree `thenUs` \ register ->
1925 getNewRegNCG PtrRep `thenUs` \ tmp ->
1927 code = registerCode register tmp
1928 target = registerName register tmp
1930 returnSeq code [JMP (OpReg target)]
1933 target = case imm of Just x -> x
1935 #endif {- i386_TARGET_ARCH -}
1936 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1937 #if sparc_TARGET_ARCH
1939 genJump (StCLbl lbl)
1940 | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
1941 | otherwise = returnInstrs [CALL target 0 True, NOP]
1943 target = ImmCLbl lbl
1946 = getRegister tree `thenUs` \ register ->
1947 getNewRegNCG PtrRep `thenUs` \ tmp ->
1949 code = registerCode register tmp
1950 target = registerName register tmp
1952 returnSeq code [JMP (AddrRegReg target g0), NOP]
1954 #endif {- sparc_TARGET_ARCH -}
1957 %************************************************************************
1959 \subsection{Conditional jumps}
1961 %************************************************************************
1963 Conditional jumps are always to local labels, so we can use branch
1964 instructions. We peek at the arguments to decide what kind of
1967 ALPHA: For comparisons with 0, we're laughing, because we can just do
1968 the desired conditional branch.
1970 I386: First, we have to ensure that the condition
1971 codes are set according to the supplied comparison operation.
1973 SPARC: First, we have to ensure that the condition codes are set
1974 according to the supplied comparison operation. We generate slightly
1975 different code for floating point comparisons, because a floating
1976 point operation cannot directly precede a @BF@. We assume the worst
1977 and fill that slot with a @NOP@.
1979 SPARC: Do not fill the delay slots here; you will confuse the register
1984 :: CLabel -- the branch target
1985 -> StixTree -- the condition on which to branch
1986 -> UniqSM InstrBlock
1988 #if alpha_TARGET_ARCH
1990 genCondJump lbl (StPrim op [x, StInt 0])
1991 = getRegister x `thenUs` \ register ->
1992 getNewRegNCG (registerRep register)
1995 code = registerCode register tmp
1996 value = registerName register tmp
1997 pk = registerRep register
1998 target = ImmCLbl lbl
2000 returnSeq code [BI (cmpOp op) value target]
2002 cmpOp CharGtOp = GTT
2004 cmpOp CharEqOp = EQQ
2006 cmpOp CharLtOp = LTT
2015 cmpOp WordGeOp = ALWAYS
2016 cmpOp WordEqOp = EQQ
2018 cmpOp WordLtOp = NEVER
2019 cmpOp WordLeOp = EQQ
2021 cmpOp AddrGeOp = ALWAYS
2022 cmpOp AddrEqOp = EQQ
2024 cmpOp AddrLtOp = NEVER
2025 cmpOp AddrLeOp = EQQ
2027 genCondJump lbl (StPrim op [x, StDouble 0.0])
2028 = getRegister x `thenUs` \ register ->
2029 getNewRegNCG (registerRep register)
2032 code = registerCode register tmp
2033 value = registerName register tmp
2034 pk = registerRep register
2035 target = ImmCLbl lbl
2037 returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
2039 cmpOp FloatGtOp = GTT
2040 cmpOp FloatGeOp = GE
2041 cmpOp FloatEqOp = EQQ
2042 cmpOp FloatNeOp = NE
2043 cmpOp FloatLtOp = LTT
2044 cmpOp FloatLeOp = LE
2045 cmpOp DoubleGtOp = GTT
2046 cmpOp DoubleGeOp = GE
2047 cmpOp DoubleEqOp = EQQ
2048 cmpOp DoubleNeOp = NE
2049 cmpOp DoubleLtOp = LTT
2050 cmpOp DoubleLeOp = LE
2052 genCondJump lbl (StPrim op [x, y])
2054 = trivialFCode pr instr x y `thenUs` \ register ->
2055 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2057 code = registerCode register tmp
2058 result = registerName register tmp
2059 target = ImmCLbl lbl
2061 returnUs (code . mkSeqInstr (BF cond result target))
2063 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2065 fltCmpOp op = case op of
2079 (instr, cond) = case op of
2080 FloatGtOp -> (FCMP TF LE, EQQ)
2081 FloatGeOp -> (FCMP TF LTT, EQQ)
2082 FloatEqOp -> (FCMP TF EQQ, NE)
2083 FloatNeOp -> (FCMP TF EQQ, EQQ)
2084 FloatLtOp -> (FCMP TF LTT, NE)
2085 FloatLeOp -> (FCMP TF LE, NE)
2086 DoubleGtOp -> (FCMP TF LE, EQQ)
2087 DoubleGeOp -> (FCMP TF LTT, EQQ)
2088 DoubleEqOp -> (FCMP TF EQQ, NE)
2089 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2090 DoubleLtOp -> (FCMP TF LTT, NE)
2091 DoubleLeOp -> (FCMP TF LE, NE)
2093 genCondJump lbl (StPrim op [x, y])
2094 = trivialCode instr x y `thenUs` \ register ->
2095 getNewRegNCG IntRep `thenUs` \ tmp ->
2097 code = registerCode register tmp
2098 result = registerName register tmp
2099 target = ImmCLbl lbl
2101 returnUs (code . mkSeqInstr (BI cond result target))
2103 (instr, cond) = case op of
2104 CharGtOp -> (CMP LE, EQQ)
2105 CharGeOp -> (CMP LTT, EQQ)
2106 CharEqOp -> (CMP EQQ, NE)
2107 CharNeOp -> (CMP EQQ, EQQ)
2108 CharLtOp -> (CMP LTT, NE)
2109 CharLeOp -> (CMP LE, NE)
2110 IntGtOp -> (CMP LE, EQQ)
2111 IntGeOp -> (CMP LTT, EQQ)
2112 IntEqOp -> (CMP EQQ, NE)
2113 IntNeOp -> (CMP EQQ, EQQ)
2114 IntLtOp -> (CMP LTT, NE)
2115 IntLeOp -> (CMP LE, NE)
2116 WordGtOp -> (CMP ULE, EQQ)
2117 WordGeOp -> (CMP ULT, EQQ)
2118 WordEqOp -> (CMP EQQ, NE)
2119 WordNeOp -> (CMP EQQ, EQQ)
2120 WordLtOp -> (CMP ULT, NE)
2121 WordLeOp -> (CMP ULE, NE)
2122 AddrGtOp -> (CMP ULE, EQQ)
2123 AddrGeOp -> (CMP ULT, EQQ)
2124 AddrEqOp -> (CMP EQQ, NE)
2125 AddrNeOp -> (CMP EQQ, EQQ)
2126 AddrLtOp -> (CMP ULT, NE)
2127 AddrLeOp -> (CMP ULE, NE)
2129 #endif {- alpha_TARGET_ARCH -}
2130 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2131 #if i386_TARGET_ARCH
2133 genCondJump lbl bool
2134 = getCondCode bool `thenUs` \ condition ->
2136 code = condCode condition
2137 cond = condName condition
2138 target = ImmCLbl lbl
2140 returnSeq code [JXX cond lbl]
2142 #endif {- i386_TARGET_ARCH -}
2143 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2144 #if sparc_TARGET_ARCH
2146 genCondJump lbl bool
2147 = getCondCode bool `thenUs` \ condition ->
2149 code = condCode condition
2150 cond = condName condition
2151 target = ImmCLbl lbl
2154 if condFloat condition then
2155 [NOP, BF cond False target, NOP]
2157 [BI cond False target, NOP]
2160 #endif {- sparc_TARGET_ARCH -}
2163 %************************************************************************
2165 \subsection{Generating C calls}
2167 %************************************************************************
2169 Now the biggest nightmare---calls. Most of the nastiness is buried in
2170 @get_arg@, which moves the arguments to the correct registers/stack
2171 locations. Apart from that, the code is easy.
2173 (If applicable) Do not fill the delay slots here; you will confuse the
2178 :: FAST_STRING -- function to call
2180 -> PrimRep -- type of the result
2181 -> [StixTree] -- arguments (of mixed type)
2182 -> UniqSM InstrBlock
2184 #if alpha_TARGET_ARCH
2186 genCCall fn cconv kind args
2187 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2188 `thenUs` \ ((unused,_), argCode) ->
2190 nRegs = length allArgRegs - length unused
2191 code = asmParThen (map ($ asmVoid) argCode)
2194 LDA pv (AddrImm (ImmLab (ptext fn))),
2195 JSR ra (AddrReg pv) nRegs,
2196 LDGP gp (AddrReg ra)]
2198 ------------------------
2199 {- Try to get a value into a specific register (or registers) for
2200 a call. The first 6 arguments go into the appropriate
2201 argument register (separate registers for integer and floating
2202 point arguments, but used in lock-step), and the remaining
2203 arguments are dumped to the stack, beginning at 0(sp). Our
2204 first argument is a pair of the list of remaining argument
2205 registers to be assigned for this call and the next stack
2206 offset to use for overflowing arguments. This way,
2207 @get_Arg@ can be applied to all of a call's arguments using
2211 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2212 -> StixTree -- Current argument
2213 -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2215 -- We have to use up all of our argument registers first...
2217 get_arg ((iDst,fDst):dsts, offset) arg
2218 = getRegister arg `thenUs` \ register ->
2220 reg = if isFloatingRep pk then fDst else iDst
2221 code = registerCode register reg
2222 src = registerName register reg
2223 pk = registerRep register
2226 if isFloatingRep pk then
2227 ((dsts, offset), if isFixed register then
2228 code . mkSeqInstr (FMOV src fDst)
2231 ((dsts, offset), if isFixed register then
2232 code . mkSeqInstr (OR src (RIReg src) iDst)
2235 -- Once we have run out of argument registers, we move to the
2238 get_arg ([], offset) arg
2239 = getRegister arg `thenUs` \ register ->
2240 getNewRegNCG (registerRep register)
2243 code = registerCode register tmp
2244 src = registerName register tmp
2245 pk = registerRep register
2246 sz = primRepToSize pk
2248 returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2250 #endif {- alpha_TARGET_ARCH -}
2251 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2252 #if i386_TARGET_ARCH
2254 genCCall fn cconv kind [StInt i]
2255 | fn == SLIT ("PerformGC_wrapper")
2256 = let call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2257 CALL (ImmLit (ptext (if underscorePrefix
2258 then (SLIT ("_PerformGC_wrapper"))
2259 else (SLIT ("PerformGC_wrapper")))))]
2264 genCCall fn cconv kind args
2265 = mapUs get_call_arg args `thenUs` \ sizes_and_argCodes ->
2267 (sizes, argCode) = unzip sizes_and_argCodes
2268 tot_arg_size = sum (map (\sz -> case sz of DF -> 8; _ -> 4) sizes)
2270 code2 = asmParThen (map ($ asmVoid) (reverse argCode))
2271 call = [CALL fn__2 ,
2272 ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)
2275 returnSeq (code2) call
2278 -- function names that begin with '.' are assumed to be special
2279 -- internally generated names like '.mul,' which don't get an
2280 -- underscore prefix
2281 -- ToDo:needed (WDP 96/03) ???
2282 fn__2 = case (_HEAD_ fn) of
2283 '.' -> ImmLit (ptext fn)
2284 _ -> ImmLab (ptext fn)
2287 get_call_arg :: StixTree{-current argument-}
2288 -> UniqSM (Size, InstrBlock) -- arg size, code
2291 = get_op arg `thenUs` \ (code, op, sz) ->
2293 DF -> --getNewRegNCG DoubleRep `thenUs` \ tmp ->
2296 --mkSeqInstr (GLD DF op tmp) .
2297 mkSeqInstr (SUB L (OpImm (ImmInt 8)) (OpReg esp)) .
2298 mkSeqInstr (GST DF {-tmp-}op (AddrBaseIndex
2300 Nothing (ImmInt 0)))
2303 code . mkSeqInstr (PUSH sz (OpReg op)))
2308 -> UniqSM (InstrBlock, {-Operand-}Reg, Size) -- code, operator, size
2311 = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
2313 get_op (StInd pk mem)
2314 = getAmode mem `thenUs` \ amode ->
2316 code = amodeCode amode --asmVoid
2317 addr = amodeAddr amode
2318 sz = primRepToSize pk
2320 returnUs (code, OpAddr addr, sz)
2323 = getRegister op `thenUs` \ register ->
2324 getNewRegNCG (registerRep register)
2327 code = registerCode register tmp
2328 reg = registerName register tmp
2329 pk = registerRep register
2330 sz = primRepToSize pk
2332 returnUs (code, {-OpReg-} reg, sz)
2334 #endif {- i386_TARGET_ARCH -}
2335 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2336 #if sparc_TARGET_ARCH
2338 genCCall fn cconv kind args
2339 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2340 `thenUs` \ ((unused,_), argCode) ->
2342 nRegs = length allArgRegs - length unused
2343 call = CALL fn__2 nRegs False
2344 code = asmParThen (map ($ asmVoid) argCode)
2346 returnSeq code [call, NOP]
2348 -- function names that begin with '.' are assumed to be special
2349 -- internally generated names like '.mul,' which don't get an
2350 -- underscore prefix
2351 -- ToDo:needed (WDP 96/03) ???
2352 fn__2 = case (_HEAD_ fn) of
2353 '.' -> ImmLit (ptext fn)
2354 _ -> ImmLab (ptext fn)
2356 ------------------------------------
2357 {- Try to get a value into a specific register (or registers) for
2358 a call. The SPARC calling convention is an absolute
2359 nightmare. The first 6x32 bits of arguments are mapped into
2360 %o0 through %o5, and the remaining arguments are dumped to the
2361 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2362 first argument is a pair of the list of remaining argument
2363 registers to be assigned for this call and the next stack
2364 offset to use for overflowing arguments. This way,
2365 @get_arg@ can be applied to all of a call's arguments using
2369 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2370 -> StixTree -- Current argument
2371 -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2373 -- We have to use up all of our argument registers first...
2375 get_arg (dst:dsts, offset) arg
2376 = getRegister arg `thenUs` \ register ->
2377 getNewRegNCG (registerRep register)
2380 reg = if isFloatingRep pk then tmp else dst
2381 code = registerCode register reg
2382 src = registerName register reg
2383 pk = registerRep register
2385 returnUs (case pk of
2388 [] -> (([], offset + 1), code . mkSeqInstrs [
2389 -- conveniently put the second part in the right stack
2390 -- location, and load the first part into %o5
2391 ST DF src (spRel (offset - 1)),
2392 LD W (spRel (offset - 1)) dst])
2393 (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2394 ST DF src (spRel (-2)),
2395 LD W (spRel (-2)) dst,
2396 LD W (spRel (-1)) dst__2])
2397 FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2398 ST F src (spRel (-2)),
2399 LD W (spRel (-2)) dst])
2400 _ -> ((dsts, offset), if isFixed register then
2401 code . mkSeqInstr (OR False g0 (RIReg src) dst)
2404 -- Once we have run out of argument registers, we move to the
2407 get_arg ([], offset) arg
2408 = getRegister arg `thenUs` \ register ->
2409 getNewRegNCG (registerRep register)
2412 code = registerCode register tmp
2413 src = registerName register tmp
2414 pk = registerRep register
2415 sz = primRepToSize pk
2416 words = if pk == DoubleRep then 2 else 1
2418 returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2420 #endif {- sparc_TARGET_ARCH -}
2423 %************************************************************************
2425 \subsection{Support bits}
2427 %************************************************************************
2429 %************************************************************************
2431 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2433 %************************************************************************
2435 Turn those condition codes into integers now (when they appear on
2436 the right hand side of an assignment).
2438 (If applicable) Do not fill the delay slots here; you will confuse the
2442 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2444 #if alpha_TARGET_ARCH
2445 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2446 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2447 #endif {- alpha_TARGET_ARCH -}
2449 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2450 #if i386_TARGET_ARCH
2453 = condIntCode cond x y `thenUs` \ condition ->
2454 getNewRegNCG IntRep `thenUs` \ tmp ->
2455 --getRegister dst `thenUs` \ register ->
2457 --code2 = registerCode register tmp asmVoid
2458 --dst__2 = registerName register tmp
2459 code = condCode condition
2460 cond = condName condition
2461 -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2462 code__2 dst = code . mkSeqInstrs [
2463 SETCC cond (OpReg tmp),
2464 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2465 MOV L (OpReg tmp) (OpReg dst)]
2467 returnUs (Any IntRep code__2)
2470 = getUniqLabelNCG `thenUs` \ lbl1 ->
2471 getUniqLabelNCG `thenUs` \ lbl2 ->
2472 condFltCode cond x y `thenUs` \ condition ->
2474 code = condCode condition
2475 cond = condName condition
2476 code__2 dst = code . mkSeqInstrs [
2478 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2481 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2484 returnUs (Any IntRep code__2)
2486 #endif {- i386_TARGET_ARCH -}
2487 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2488 #if sparc_TARGET_ARCH
2490 condIntReg EQQ x (StInt 0)
2491 = getRegister x `thenUs` \ register ->
2492 getNewRegNCG IntRep `thenUs` \ tmp ->
2494 code = registerCode register tmp
2495 src = registerName register tmp
2496 code__2 dst = code . mkSeqInstrs [
2497 SUB False True g0 (RIReg src) g0,
2498 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2500 returnUs (Any IntRep code__2)
2503 = getRegister x `thenUs` \ register1 ->
2504 getRegister y `thenUs` \ register2 ->
2505 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2506 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2508 code1 = registerCode register1 tmp1 asmVoid
2509 src1 = registerName register1 tmp1
2510 code2 = registerCode register2 tmp2 asmVoid
2511 src2 = registerName register2 tmp2
2512 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2513 XOR False src1 (RIReg src2) dst,
2514 SUB False True g0 (RIReg dst) g0,
2515 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2517 returnUs (Any IntRep code__2)
2519 condIntReg NE x (StInt 0)
2520 = getRegister x `thenUs` \ register ->
2521 getNewRegNCG IntRep `thenUs` \ tmp ->
2523 code = registerCode register tmp
2524 src = registerName register tmp
2525 code__2 dst = code . mkSeqInstrs [
2526 SUB False True g0 (RIReg src) g0,
2527 ADD True False g0 (RIImm (ImmInt 0)) dst]
2529 returnUs (Any IntRep code__2)
2532 = getRegister x `thenUs` \ register1 ->
2533 getRegister y `thenUs` \ register2 ->
2534 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2535 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2537 code1 = registerCode register1 tmp1 asmVoid
2538 src1 = registerName register1 tmp1
2539 code2 = registerCode register2 tmp2 asmVoid
2540 src2 = registerName register2 tmp2
2541 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2542 XOR False src1 (RIReg src2) dst,
2543 SUB False True g0 (RIReg dst) g0,
2544 ADD True False g0 (RIImm (ImmInt 0)) dst]
2546 returnUs (Any IntRep code__2)
2549 = getUniqLabelNCG `thenUs` \ lbl1 ->
2550 getUniqLabelNCG `thenUs` \ lbl2 ->
2551 condIntCode cond x y `thenUs` \ condition ->
2553 code = condCode condition
2554 cond = condName condition
2555 code__2 dst = code . mkSeqInstrs [
2556 BI cond False (ImmCLbl lbl1), NOP,
2557 OR False g0 (RIImm (ImmInt 0)) dst,
2558 BI ALWAYS False (ImmCLbl lbl2), NOP,
2560 OR False g0 (RIImm (ImmInt 1)) dst,
2563 returnUs (Any IntRep code__2)
2566 = getUniqLabelNCG `thenUs` \ lbl1 ->
2567 getUniqLabelNCG `thenUs` \ lbl2 ->
2568 condFltCode cond x y `thenUs` \ condition ->
2570 code = condCode condition
2571 cond = condName condition
2572 code__2 dst = code . mkSeqInstrs [
2574 BF cond False (ImmCLbl lbl1), NOP,
2575 OR False g0 (RIImm (ImmInt 0)) dst,
2576 BI ALWAYS False (ImmCLbl lbl2), NOP,
2578 OR False g0 (RIImm (ImmInt 1)) dst,
2581 returnUs (Any IntRep code__2)
2583 #endif {- sparc_TARGET_ARCH -}
2586 %************************************************************************
2588 \subsubsection{@trivial*Code@: deal with trivial instructions}
2590 %************************************************************************
2592 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2593 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2594 for constants on the right hand side, because that's where the generic
2595 optimizer will have put them.
2597 Similarly, for unary instructions, we don't have to worry about
2598 matching an StInt as the argument, because genericOpt will already
2599 have handled the constant-folding.
2603 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2604 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2605 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2607 -> StixTree -> StixTree -- the two arguments
2612 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2613 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2614 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2616 -> StixTree -> StixTree -- the two arguments
2620 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2621 ,IF_ARCH_i386 ((Operand -> Instr)
2622 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2624 -> StixTree -- the one argument
2629 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2630 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2631 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2633 -> StixTree -- the one argument
2636 #if alpha_TARGET_ARCH
2638 trivialCode instr x (StInt y)
2640 = getRegister x `thenUs` \ register ->
2641 getNewRegNCG IntRep `thenUs` \ tmp ->
2643 code = registerCode register tmp
2644 src1 = registerName register tmp
2645 src2 = ImmInt (fromInteger y)
2646 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2648 returnUs (Any IntRep code__2)
2650 trivialCode instr x y
2651 = getRegister x `thenUs` \ register1 ->
2652 getRegister y `thenUs` \ register2 ->
2653 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2654 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2656 code1 = registerCode register1 tmp1 asmVoid
2657 src1 = registerName register1 tmp1
2658 code2 = registerCode register2 tmp2 asmVoid
2659 src2 = registerName register2 tmp2
2660 code__2 dst = asmParThen [code1, code2] .
2661 mkSeqInstr (instr src1 (RIReg src2) dst)
2663 returnUs (Any IntRep code__2)
2666 trivialUCode instr x
2667 = getRegister x `thenUs` \ register ->
2668 getNewRegNCG IntRep `thenUs` \ tmp ->
2670 code = registerCode register tmp
2671 src = registerName register tmp
2672 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2674 returnUs (Any IntRep code__2)
2677 trivialFCode _ instr x y
2678 = getRegister x `thenUs` \ register1 ->
2679 getRegister y `thenUs` \ register2 ->
2680 getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
2681 getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
2683 code1 = registerCode register1 tmp1
2684 src1 = registerName register1 tmp1
2686 code2 = registerCode register2 tmp2
2687 src2 = registerName register2 tmp2
2689 code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2690 mkSeqInstr (instr src1 src2 dst)
2692 returnUs (Any DoubleRep code__2)
2694 trivialUFCode _ instr x
2695 = getRegister x `thenUs` \ register ->
2696 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2698 code = registerCode register tmp
2699 src = registerName register tmp
2700 code__2 dst = code . mkSeqInstr (instr src dst)
2702 returnUs (Any DoubleRep code__2)
2704 #endif {- alpha_TARGET_ARCH -}
2705 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2706 #if i386_TARGET_ARCH
2708 trivialCode instr x y
2710 = getRegister x `thenUs` \ register1 ->
2712 code__2 dst = let code1 = registerCode register1 dst
2713 src1 = registerName register1 dst
2715 if isFixed register1 && src1 /= dst
2716 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2717 instr (OpImm imm__2) (OpReg dst)]
2719 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
2721 returnUs (Any IntRep code__2)
2724 imm__2 = case imm of Just x -> x
2726 trivialCode instr x y
2728 = getRegister y `thenUs` \ register1 ->
2730 code__2 dst = let code1 = registerCode register1 dst
2731 src1 = registerName register1 dst
2733 if isFixed register1 && src1 /= dst
2734 then mkSeqInstrs [MOV L (OpImm imm__2) (OpReg dst),
2735 instr (OpReg src1) (OpReg dst)]
2737 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
2739 returnUs (Any IntRep code__2)
2742 imm__2 = case imm of Just x -> x
2744 trivialCode instr x y
2745 = getRegister x `thenUs` \ register1 ->
2746 getRegister y `thenUs` \ register2 ->
2747 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2749 code2 = registerCode register2 tmp2 asmVoid
2750 src2 = registerName register2 tmp2
2752 code1 = registerCode register1 dst asmVoid
2753 src1 = registerName register1 dst
2754 in asmParThen [code1, code2] .
2755 if isFixed register1 && src1 /= dst
2756 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2757 instr (OpReg src2) (OpReg dst)]
2759 mkSeqInstr (instr (OpReg src2) (OpReg src1))
2761 returnUs (Any IntRep code__2)
2764 trivialUCode instr x
2765 = getRegister x `thenUs` \ register ->
2768 code = registerCode register dst
2769 src = registerName register dst
2770 in code . if isFixed register && dst /= src
2771 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
2773 else mkSeqInstr (instr (OpReg src))
2775 returnUs (Any IntRep code__2)
2779 trivialFCode pk _ instrr _ _ (StInd pk' mem) y
2780 = getRegister y `thenUs` \ register2 ->
2781 getAmode mem `thenUs` \ amode ->
2783 code1 = amodeCode amode
2784 src1 = amodeAddr amode
2787 code2 = registerCode register2 dst
2788 src2 = registerName register2 dst
2789 in asmParThen [code1 asmVoid,code2 asmVoid] .
2790 mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
2792 returnUs (Any pk code__2)
2794 trivialFCode pk instr _ _ _ x (StInd pk' mem)
2795 = getRegister x `thenUs` \ register1 ->
2796 getAmode mem `thenUs` \ amode ->
2798 code2 = amodeCode amode
2799 src2 = amodeAddr amode
2802 code1 = registerCode register1 dst
2803 src1 = registerName register1 dst
2804 in asmParThen [code2 asmVoid,code1 asmVoid] .
2805 mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
2807 returnUs (Any pk code__2)
2809 trivialFCode pk _ _ _ instrpr x y
2810 = getRegister x `thenUs` \ register1 ->
2811 getRegister y `thenUs` \ register2 ->
2812 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2814 pk1 = registerRep register1
2815 code1 = registerCode register1 st0 --tmp1
2816 src1 = registerName register1 st0 --tmp1
2818 pk2 = registerRep register2
2821 code2 = registerCode register2 dst
2822 src2 = registerName register2 dst
2823 in asmParThen [code1 asmVoid, code2 asmVoid] .
2826 returnUs (Any pk1 code__2)
2829 trivialFCode pk instr x y
2830 = getRegister x `thenUs` \ register1 ->
2831 getRegister y `thenUs` \ register2 ->
2832 getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
2833 getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
2835 code1 = registerCode register1 tmp1
2836 src1 = registerName register1 tmp1
2838 code2 = registerCode register2 tmp2
2839 src2 = registerName register2 tmp2
2841 code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2842 mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
2844 returnUs (Any DoubleRep code__2)
2848 trivialUFCode pk instr x
2849 = getRegister x `thenUs` \ register ->
2850 getNewRegNCG pk `thenUs` \ tmp ->
2852 code = registerCode register tmp
2853 src = registerName register tmp
2854 code__2 dst = code . mkSeqInstr (instr src dst)
2856 returnUs (Any pk code__2)
2859 trivialUFCode pk instr (StInd pk' mem)
2860 = getAmode mem `thenUs` \ amode ->
2862 code = amodeCode amode
2863 src = amodeAddr amode
2864 code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
2867 returnUs (Any pk code__2)
2869 trivialUFCode pk instr x
2870 = getRegister x `thenUs` \ register ->
2873 code = registerCode register dst
2874 src = registerName register dst
2875 in code . mkSeqInstrs [instr]
2877 returnUs (Any pk code__2)
2879 #endif {- i386_TARGET_ARCH -}
2880 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2881 #if sparc_TARGET_ARCH
2883 trivialCode instr x (StInt y)
2885 = getRegister x `thenUs` \ register ->
2886 getNewRegNCG IntRep `thenUs` \ tmp ->
2888 code = registerCode register tmp
2889 src1 = registerName register tmp
2890 src2 = ImmInt (fromInteger y)
2891 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2893 returnUs (Any IntRep code__2)
2895 trivialCode instr x y
2896 = getRegister x `thenUs` \ register1 ->
2897 getRegister y `thenUs` \ register2 ->
2898 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2899 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2901 code1 = registerCode register1 tmp1 asmVoid
2902 src1 = registerName register1 tmp1
2903 code2 = registerCode register2 tmp2 asmVoid
2904 src2 = registerName register2 tmp2
2905 code__2 dst = asmParThen [code1, code2] .
2906 mkSeqInstr (instr src1 (RIReg src2) dst)
2908 returnUs (Any IntRep code__2)
2911 trivialFCode pk instr x y
2912 = getRegister x `thenUs` \ register1 ->
2913 getRegister y `thenUs` \ register2 ->
2914 getNewRegNCG (registerRep register1)
2916 getNewRegNCG (registerRep register2)
2918 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2920 promote x = asmInstr (FxTOy F DF x tmp)
2922 pk1 = registerRep register1
2923 code1 = registerCode register1 tmp1
2924 src1 = registerName register1 tmp1
2926 pk2 = registerRep register2
2927 code2 = registerCode register2 tmp2
2928 src2 = registerName register2 tmp2
2932 asmParThen [code1 asmVoid, code2 asmVoid] .
2933 mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
2934 else if pk1 == FloatRep then
2935 asmParThen [code1 (promote src1), code2 asmVoid] .
2936 mkSeqInstr (instr DF tmp src2 dst)
2938 asmParThen [code1 asmVoid, code2 (promote src2)] .
2939 mkSeqInstr (instr DF src1 tmp dst)
2941 returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
2944 trivialUCode instr x
2945 = getRegister x `thenUs` \ register ->
2946 getNewRegNCG IntRep `thenUs` \ tmp ->
2948 code = registerCode register tmp
2949 src = registerName register tmp
2950 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2952 returnUs (Any IntRep code__2)
2955 trivialUFCode pk instr x
2956 = getRegister x `thenUs` \ register ->
2957 getNewRegNCG pk `thenUs` \ tmp ->
2959 code = registerCode register tmp
2960 src = registerName register tmp
2961 code__2 dst = code . mkSeqInstr (instr src dst)
2963 returnUs (Any pk code__2)
2965 #endif {- sparc_TARGET_ARCH -}
2968 %************************************************************************
2970 \subsubsection{Coercing to/from integer/floating-point...}
2972 %************************************************************************
2974 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
2975 to be generated. Here we just change the type on the Register passed
2976 on up. The code is machine-independent.
2978 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
2979 conversions. We have to store temporaries in memory to move
2980 between the integer and the floating point register sets.
2983 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
2984 coerceFltCode :: StixTree -> UniqSM Register
2986 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
2987 coerceFP2Int :: StixTree -> UniqSM Register
2990 = getRegister x `thenUs` \ register ->
2993 Fixed _ reg code -> Fixed pk reg code
2994 Any _ code -> Any pk code
2999 = getRegister x `thenUs` \ register ->
3002 Fixed _ reg code -> Fixed DoubleRep reg code
3003 Any _ code -> Any DoubleRep code
3008 #if alpha_TARGET_ARCH
3011 = getRegister x `thenUs` \ register ->
3012 getNewRegNCG IntRep `thenUs` \ reg ->
3014 code = registerCode register reg
3015 src = registerName register reg
3017 code__2 dst = code . mkSeqInstrs [
3019 LD TF dst (spRel 0),
3022 returnUs (Any DoubleRep code__2)
3026 = getRegister x `thenUs` \ register ->
3027 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3029 code = registerCode register tmp
3030 src = registerName register tmp
3032 code__2 dst = code . mkSeqInstrs [
3034 ST TF tmp (spRel 0),
3037 returnUs (Any IntRep code__2)
3039 #endif {- alpha_TARGET_ARCH -}
3040 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3041 #if i386_TARGET_ARCH
3044 = getRegister x `thenUs` \ register ->
3045 getNewRegNCG IntRep `thenUs` \ reg ->
3047 code = registerCode register reg
3048 src = registerName register reg
3049 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3050 code__2 dst = code .
3051 mkSeqInstr (opc src dst)
3053 returnUs (Any pk code__2)
3057 = getRegister x `thenUs` \ register ->
3058 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3060 code = registerCode register tmp
3061 src = registerName register tmp
3062 pk = registerRep register
3064 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3065 code__2 dst = code .
3066 mkSeqInstr (opc src dst)
3068 returnUs (Any IntRep code__2)
3070 #endif {- i386_TARGET_ARCH -}
3071 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3072 #if sparc_TARGET_ARCH
3075 = getRegister x `thenUs` \ register ->
3076 getNewRegNCG IntRep `thenUs` \ reg ->
3078 code = registerCode register reg
3079 src = registerName register reg
3081 code__2 dst = code . mkSeqInstrs [
3082 ST W src (spRel (-2)),
3083 LD W (spRel (-2)) dst,
3084 FxTOy W (primRepToSize pk) dst dst]
3086 returnUs (Any pk code__2)
3090 = getRegister x `thenUs` \ register ->
3091 getNewRegNCG IntRep `thenUs` \ reg ->
3092 getNewRegNCG FloatRep `thenUs` \ tmp ->
3094 code = registerCode register reg
3095 src = registerName register reg
3096 pk = registerRep register
3098 code__2 dst = code . mkSeqInstrs [
3099 FxTOy (primRepToSize pk) W src tmp,
3100 ST W tmp (spRel (-2)),
3101 LD W (spRel (-2)) dst]
3103 returnUs (Any IntRep code__2)
3105 #endif {- sparc_TARGET_ARCH -}
3108 %************************************************************************
3110 \subsubsection{Coercing integer to @Char@...}
3112 %************************************************************************
3114 Integer to character conversion. Where applicable, we try to do this
3115 in one step if the original object is in memory.
3118 chrCode :: StixTree -> UniqSM Register
3120 #if alpha_TARGET_ARCH
3123 = getRegister x `thenUs` \ register ->
3124 getNewRegNCG IntRep `thenUs` \ reg ->
3126 code = registerCode register reg
3127 src = registerName register reg
3128 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3130 returnUs (Any IntRep code__2)
3132 #endif {- alpha_TARGET_ARCH -}
3133 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3134 #if i386_TARGET_ARCH
3137 = getRegister x `thenUs` \ register ->
3138 --getNewRegNCG IntRep `thenUs` \ reg ->
3141 code = registerCode register dst
3142 src = registerName register dst
3144 if isFixed register && src /= dst
3145 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3146 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3147 else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3149 returnUs (Any IntRep code__2)
3151 #endif {- i386_TARGET_ARCH -}
3152 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3153 #if sparc_TARGET_ARCH
3155 chrCode (StInd pk mem)
3156 = getAmode mem `thenUs` \ amode ->
3158 code = amodeCode amode
3159 src = amodeAddr amode
3160 src_off = addrOffset src 3
3161 src__2 = case src_off of Just x -> x
3162 code__2 dst = if maybeToBool src_off then
3163 code . mkSeqInstr (LD BU src__2 dst)
3165 code . mkSeqInstrs [
3166 LD (primRepToSize pk) src dst,
3167 AND False dst (RIImm (ImmInt 255)) dst]
3169 returnUs (Any pk code__2)
3172 = getRegister x `thenUs` \ register ->
3173 getNewRegNCG IntRep `thenUs` \ reg ->
3175 code = registerCode register reg
3176 src = registerName register reg
3177 code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3179 returnUs (Any IntRep code__2)
3181 #endif {- sparc_TARGET_ARCH -}