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(..),
31 pprStixTrees, ppStixReg
33 import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
39 Code extractor for an entire stix tree---stix statement level.
42 stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock
44 stmt2Instrs stmt = case stmt of
45 StComment s -> returnInstr (COMMENT s)
46 StSegment seg -> returnInstr (SEGMENT seg)
48 StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab))
49 StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id)
50 StLabel lab -> returnInstr (LABEL lab)
52 StJump arg -> genJump arg
53 StCondJump lab arg -> genCondJump lab arg
54 StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args
57 | isFloatingRep pk -> assignFltCode pk dst src
58 | otherwise -> assignIntCode pk dst src
61 -- When falling through on the Alpha, we still have to load pv
62 -- with the address of the next routine, so that it can load gp.
63 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
67 -> mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
68 returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms))
69 (foldr (.) id codes xs))
71 getData :: StixTree -> UniqSM (InstrBlock, Imm)
73 getData (StInt i) = returnUs (id, ImmInteger i)
74 getData (StDouble d) = returnUs (id, ImmDouble d)
75 getData (StLitLbl s) = returnUs (id, ImmLab s)
76 getData (StCLbl l) = returnUs (id, ImmCLbl l)
77 getData (StString s) =
78 getUniqLabelNCG `thenUs` \ lbl ->
79 returnUs (mkSeqInstrs [LABEL lbl,
80 ASCII True (_UNPK_ s)],
82 -- the linker can handle simple arithmetic...
83 getData (StIndex rep (StCLbl lbl) (StInt off)) =
84 returnUs (id, ImmIndex lbl (fromInteger (off * sizeOf rep)))
87 %************************************************************************
89 \subsection{General things for putting together code sequences}
91 %************************************************************************
94 type InstrList = OrdList Instr
95 type InstrBlock = InstrList -> InstrList
100 asmInstr :: Instr -> InstrList
101 asmInstr i = mkUnitList i
103 asmSeq :: [Instr] -> InstrList
104 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
106 asmParThen :: [InstrList] -> InstrBlock
107 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
109 returnInstr :: Instr -> UniqSM InstrBlock
110 returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
112 returnInstrs :: [Instr] -> UniqSM InstrBlock
113 returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
115 returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock
116 returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
118 mkSeqInstr :: Instr -> InstrBlock
119 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
121 mkSeqInstrs :: [Instr] -> InstrBlock
122 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
126 mangleIndexTree :: StixTree -> StixTree
128 mangleIndexTree (StIndex pk base (StInt i))
129 = StPrim IntAddOp [base, off]
131 off = StInt (i * sizeOf pk)
133 mangleIndexTree (StIndex pk base off)
137 in ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
138 if s == 0 then off else StPrim SllOp [off, StInt s]
141 shift DoubleRep = 3::Integer
142 shift CharRep = 0::Integer
143 shift _ = IF_ARCH_alpha(3,2)
147 maybeImm :: StixTree -> Maybe Imm
149 maybeImm (StLitLbl s) = Just (ImmLab s)
150 maybeImm (StCLbl l) = Just (ImmCLbl l)
152 maybeImm (StIndex rep (StCLbl l) (StInt off)) =
153 Just (ImmIndex l (fromInteger (off * sizeOf rep)))
156 | i >= toInteger minInt && i <= toInteger maxInt
157 = Just (ImmInt (fromInteger i))
159 = Just (ImmInteger i)
164 %************************************************************************
166 \subsection{The @Register@ type}
168 %************************************************************************
170 @Register@s passed up the tree. If the stix code forces the register
171 to live in a pre-decided machine register, it comes out as @Fixed@;
172 otherwise, it comes out as @Any@, and the parent can decide which
173 register to put it in.
177 = Fixed PrimRep Reg InstrBlock
178 | Any PrimRep (Reg -> InstrBlock)
180 registerCode :: Register -> Reg -> InstrBlock
181 registerCode (Fixed _ _ code) reg = code
182 registerCode (Any _ code) reg = code reg
184 registerCodeF (Fixed _ _ code) = code
185 registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
187 registerName :: Register -> Reg -> Reg
188 registerName (Fixed _ reg _) _ = reg
189 registerName (Any _ _) reg = reg
191 registerNameF (Fixed _ reg _) = reg
192 registerNameF (Any _ _) = pprPanic "registerNameF" empty
194 registerRep :: Register -> PrimRep
195 registerRep (Fixed pk _ _) = pk
196 registerRep (Any pk _) = pk
198 isFixed, isFloat :: Register -> Bool
199 isFixed (Fixed _ _ _) = True
200 isFixed (Any _ _) = False
202 isFloat = not . isFixed
205 Generate code to get a subtree into a @Register@:
207 getRegister :: StixTree -> UniqSM Register
209 getRegister (StReg (StixMagicId stgreg))
210 = case (magicIdRegMaybe stgreg) of
211 Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id)
214 getRegister (StReg (StixTemp u pk))
215 = returnUs (Fixed pk (UnmappedReg u pk) id)
217 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
219 getRegister (StCall fn cconv kind args)
220 = genCCall fn cconv kind args `thenUs` \ call ->
221 returnUs (Fixed kind reg call)
223 reg = if isFloatingRep kind
224 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
225 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
227 getRegister (StString s)
228 = getUniqLabelNCG `thenUs` \ lbl ->
230 imm_lbl = ImmCLbl lbl
232 code dst = mkSeqInstrs [
235 ASCII True (_UNPK_ s),
237 #if alpha_TARGET_ARCH
238 LDA dst (AddrImm imm_lbl)
241 MOV L (OpImm imm_lbl) (OpReg dst)
243 #if sparc_TARGET_ARCH
244 SETHI (HI imm_lbl) dst,
245 OR False dst (RIImm (LO imm_lbl)) dst
249 returnUs (Any PtrRep code)
253 -- end of machine-"independent" bit; here we go on the rest...
255 #if alpha_TARGET_ARCH
257 getRegister (StDouble d)
258 = getUniqLabelNCG `thenUs` \ lbl ->
259 getNewRegNCG PtrRep `thenUs` \ tmp ->
260 let code dst = mkSeqInstrs [
263 DATA TF [ImmLab (rational d)],
265 LDA tmp (AddrImm (ImmCLbl lbl)),
266 LD TF dst (AddrReg tmp)]
268 returnUs (Any DoubleRep code)
270 getRegister (StPrim primop [x]) -- unary PrimOps
272 IntNegOp -> trivialUCode (NEG Q False) x
274 NotOp -> trivialUCode NOT x
276 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
277 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
279 OrdOp -> coerceIntCode IntRep x
282 Float2IntOp -> coerceFP2Int x
283 Int2FloatOp -> coerceInt2FP pr x
284 Double2IntOp -> coerceFP2Int x
285 Int2DoubleOp -> coerceInt2FP pr x
287 Double2FloatOp -> coerceFltCode x
288 Float2DoubleOp -> coerceFltCode x
290 other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
292 fn = case other_op of
293 FloatExpOp -> SLIT("exp")
294 FloatLogOp -> SLIT("log")
295 FloatSqrtOp -> SLIT("sqrt")
296 FloatSinOp -> SLIT("sin")
297 FloatCosOp -> SLIT("cos")
298 FloatTanOp -> SLIT("tan")
299 FloatAsinOp -> SLIT("asin")
300 FloatAcosOp -> SLIT("acos")
301 FloatAtanOp -> SLIT("atan")
302 FloatSinhOp -> SLIT("sinh")
303 FloatCoshOp -> SLIT("cosh")
304 FloatTanhOp -> SLIT("tanh")
305 DoubleExpOp -> SLIT("exp")
306 DoubleLogOp -> SLIT("log")
307 DoubleSqrtOp -> SLIT("sqrt")
308 DoubleSinOp -> SLIT("sin")
309 DoubleCosOp -> SLIT("cos")
310 DoubleTanOp -> SLIT("tan")
311 DoubleAsinOp -> SLIT("asin")
312 DoubleAcosOp -> SLIT("acos")
313 DoubleAtanOp -> SLIT("atan")
314 DoubleSinhOp -> SLIT("sinh")
315 DoubleCoshOp -> SLIT("cosh")
316 DoubleTanhOp -> SLIT("tanh")
318 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
320 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
322 CharGtOp -> trivialCode (CMP LTT) y x
323 CharGeOp -> trivialCode (CMP LE) y x
324 CharEqOp -> trivialCode (CMP EQQ) x y
325 CharNeOp -> int_NE_code x y
326 CharLtOp -> trivialCode (CMP LTT) x y
327 CharLeOp -> trivialCode (CMP LE) x y
329 IntGtOp -> trivialCode (CMP LTT) y x
330 IntGeOp -> trivialCode (CMP LE) y x
331 IntEqOp -> trivialCode (CMP EQQ) x y
332 IntNeOp -> int_NE_code x y
333 IntLtOp -> trivialCode (CMP LTT) x y
334 IntLeOp -> trivialCode (CMP LE) x y
336 WordGtOp -> trivialCode (CMP ULT) y x
337 WordGeOp -> trivialCode (CMP ULE) x y
338 WordEqOp -> trivialCode (CMP EQQ) x y
339 WordNeOp -> int_NE_code x y
340 WordLtOp -> trivialCode (CMP ULT) x y
341 WordLeOp -> trivialCode (CMP ULE) x y
343 AddrGtOp -> trivialCode (CMP ULT) y x
344 AddrGeOp -> trivialCode (CMP ULE) y x
345 AddrEqOp -> trivialCode (CMP EQQ) x y
346 AddrNeOp -> int_NE_code x y
347 AddrLtOp -> trivialCode (CMP ULT) x y
348 AddrLeOp -> trivialCode (CMP ULE) x y
350 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
351 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
352 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
353 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
354 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
355 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
357 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
358 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
359 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
360 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
361 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
362 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
364 IntAddOp -> trivialCode (ADD Q False) x y
365 IntSubOp -> trivialCode (SUB Q False) x y
366 IntMulOp -> trivialCode (MUL Q False) x y
367 IntQuotOp -> trivialCode (DIV Q False) x y
368 IntRemOp -> trivialCode (REM Q False) x y
370 WordQuotOp -> trivialCode (DIV Q True) x y
371 WordRemOp -> trivialCode (REM Q True) x y
373 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
374 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
375 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
376 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
378 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
379 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
380 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
381 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
383 AndOp -> trivialCode AND x y
384 OrOp -> trivialCode OR x y
385 XorOp -> trivialCode XOR x y
386 SllOp -> trivialCode SLL x y
387 SrlOp -> trivialCode SRL x y
389 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
390 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
391 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
393 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
394 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
396 {- ------------------------------------------------------------
397 Some bizarre special code for getting condition codes into
398 registers. Integer non-equality is a test for equality
399 followed by an XOR with 1. (Integer comparisons always set
400 the result register to 0 or 1.) Floating point comparisons of
401 any kind leave the result in a floating point register, so we
402 need to wrangle an integer register out of things.
404 int_NE_code :: StixTree -> StixTree -> UniqSM Register
407 = trivialCode (CMP EQQ) x y `thenUs` \ register ->
408 getNewRegNCG IntRep `thenUs` \ tmp ->
410 code = registerCode register tmp
411 src = registerName register tmp
412 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
414 returnUs (Any IntRep code__2)
416 {- ------------------------------------------------------------
417 Comments for int_NE_code also apply to cmpF_code
420 :: (Reg -> Reg -> Reg -> Instr)
422 -> StixTree -> StixTree
425 cmpF_code instr cond x y
426 = trivialFCode pr instr x y `thenUs` \ register ->
427 getNewRegNCG DoubleRep `thenUs` \ tmp ->
428 getUniqLabelNCG `thenUs` \ lbl ->
430 code = registerCode register tmp
431 result = registerName register tmp
433 code__2 dst = code . mkSeqInstrs [
434 OR zeroh (RIImm (ImmInt 1)) dst,
435 BF cond result (ImmCLbl lbl),
436 OR zeroh (RIReg zeroh) dst,
439 returnUs (Any IntRep code__2)
441 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
442 ------------------------------------------------------------
444 getRegister (StInd pk mem)
445 = getAmode mem `thenUs` \ amode ->
447 code = amodeCode amode
448 src = amodeAddr amode
449 size = primRepToSize pk
450 code__2 dst = code . mkSeqInstr (LD size dst src)
452 returnUs (Any pk code__2)
454 getRegister (StInt i)
457 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
459 returnUs (Any IntRep code)
462 code dst = mkSeqInstr (LDI Q dst src)
464 returnUs (Any IntRep code)
466 src = ImmInt (fromInteger i)
471 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
473 returnUs (Any PtrRep code)
476 imm__2 = case imm of Just x -> x
478 #endif {- alpha_TARGET_ARCH -}
479 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
482 getRegister (StDouble d)
483 = getUniqLabelNCG `thenUs` \ lbl ->
484 let code dst = mkSeqInstrs [
487 DATA DF [ImmDouble d],
489 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
492 returnUs (Any DoubleRep code)
494 -- incorrectly assumes that %esp doesn't move (as does spilling); ToDo: fix
495 getRegister (StScratchWord i)
497 = let code dst = mkSeqInstr (LEA L (OpAddr (spRel (i+1))) (OpReg dst))
498 in returnUs (Any PtrRep code)
500 getRegister (StPrim primop [x]) -- unary PrimOps
502 IntNegOp -> trivialUCode (NEGI L) x
503 NotOp -> trivialUCode (NOT L) x
505 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
506 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
508 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
509 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
511 FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
512 DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
514 FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
515 DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
517 FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
518 DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
520 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
521 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
523 OrdOp -> coerceIntCode IntRep x
526 Float2IntOp -> coerceFP2Int x
527 Int2FloatOp -> coerceInt2FP FloatRep x
528 Double2IntOp -> coerceFP2Int x
529 Int2DoubleOp -> coerceInt2FP DoubleRep x
533 fixed_x = if is_float_op -- promote to double
534 then StPrim Float2DoubleOp [x]
537 getRegister (StCall fn cCallConv DoubleRep [x])
541 FloatExpOp -> (True, SLIT("exp"))
542 FloatLogOp -> (True, SLIT("log"))
544 --FloatSinOp -> (True, SLIT("sin"))
545 --FloatCosOp -> (True, SLIT("cos"))
546 --FloatTanOp -> (True, SLIT("tan"))
548 FloatAsinOp -> (True, SLIT("asin"))
549 FloatAcosOp -> (True, SLIT("acos"))
550 FloatAtanOp -> (True, SLIT("atan"))
552 FloatSinhOp -> (True, SLIT("sinh"))
553 FloatCoshOp -> (True, SLIT("cosh"))
554 FloatTanhOp -> (True, SLIT("tanh"))
556 DoubleExpOp -> (False, SLIT("exp"))
557 DoubleLogOp -> (False, SLIT("log"))
559 --DoubleSinOp -> (False, SLIT("sin"))
560 --DoubleCosOp -> (False, SLIT("cos"))
561 --DoubleTanOp -> (False, SLIT("tan"))
563 DoubleAsinOp -> (False, SLIT("asin"))
564 DoubleAcosOp -> (False, SLIT("acos"))
565 DoubleAtanOp -> (False, SLIT("atan"))
567 DoubleSinhOp -> (False, SLIT("sinh"))
568 DoubleCoshOp -> (False, SLIT("cosh"))
569 DoubleTanhOp -> (False, SLIT("tanh"))
572 -> pprPanic "getRegister(x86,unary primop)"
573 (pprStixTrees [StPrim primop [x]])
575 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
577 CharGtOp -> condIntReg GTT x y
578 CharGeOp -> condIntReg GE x y
579 CharEqOp -> condIntReg EQQ x y
580 CharNeOp -> condIntReg NE x y
581 CharLtOp -> condIntReg LTT x y
582 CharLeOp -> condIntReg LE x y
584 IntGtOp -> condIntReg GTT x y
585 IntGeOp -> condIntReg GE x y
586 IntEqOp -> condIntReg EQQ x y
587 IntNeOp -> condIntReg NE x y
588 IntLtOp -> condIntReg LTT x y
589 IntLeOp -> condIntReg LE x y
591 WordGtOp -> condIntReg GU x y
592 WordGeOp -> condIntReg GEU x y
593 WordEqOp -> condIntReg EQQ x y
594 WordNeOp -> condIntReg NE x y
595 WordLtOp -> condIntReg LU x y
596 WordLeOp -> condIntReg LEU x y
598 AddrGtOp -> condIntReg GU x y
599 AddrGeOp -> condIntReg GEU x y
600 AddrEqOp -> condIntReg EQQ x y
601 AddrNeOp -> condIntReg NE x y
602 AddrLtOp -> condIntReg LU x y
603 AddrLeOp -> condIntReg LEU x y
605 FloatGtOp -> condFltReg GTT x y
606 FloatGeOp -> condFltReg GE x y
607 FloatEqOp -> condFltReg EQQ x y
608 FloatNeOp -> condFltReg NE x y
609 FloatLtOp -> condFltReg LTT x y
610 FloatLeOp -> condFltReg LE x y
612 DoubleGtOp -> condFltReg GTT x y
613 DoubleGeOp -> condFltReg GE x y
614 DoubleEqOp -> condFltReg EQQ x y
615 DoubleNeOp -> condFltReg NE x y
616 DoubleLtOp -> condFltReg LTT x y
617 DoubleLeOp -> condFltReg LE x y
619 IntAddOp -> add_code L x y
620 IntSubOp -> sub_code L x y
621 IntQuotOp -> quot_code L x y True{-division-}
622 IntRemOp -> quot_code L x y False{-remainder-}
623 IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
625 FloatAddOp -> trivialFCode FloatRep GADD x y
626 FloatSubOp -> trivialFCode FloatRep GSUB x y
627 FloatMulOp -> trivialFCode FloatRep GMUL x y
628 FloatDivOp -> trivialFCode FloatRep GDIV x y
630 DoubleAddOp -> trivialFCode DoubleRep GADD x y
631 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
632 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
633 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
635 AndOp -> let op = AND L in trivialCode op (Just op) x y
636 OrOp -> let op = OR L in trivialCode op (Just op) x y
637 XorOp -> let op = XOR L in trivialCode op (Just op) x y
639 {- Shift ops on x86s have constraints on their source, it
640 either has to be Imm, CL or 1
641 => trivialCode's is not restrictive enough (sigh.)
644 SllOp -> shift_code (SHL L) x y {-False-}
645 SrlOp -> shift_code (SHR L) x y {-False-}
646 ISllOp -> shift_code (SHL L) x y {-False-}
647 ISraOp -> shift_code (SAR L) x y {-False-}
648 ISrlOp -> shift_code (SHR L) x y {-False-}
650 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
651 [promote x, promote y])
652 where promote x = StPrim Float2DoubleOp [x]
653 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
656 -> pprPanic "getRegister(x86,dyadic primop)"
657 (pprStixTrees [StPrim primop [x, y]])
661 shift_code :: (Imm -> Operand -> Instr)
666 {- Case1: shift length as immediate -}
667 -- Code is the same as the first eq. for trivialCode -- sigh.
668 shift_code instr x y{-amount-}
670 = getRegister x `thenUs` \ regx ->
673 then registerCode regx dst `bind` \ code_x ->
675 mkSeqInstr (instr imm__2 (OpReg dst))
676 else registerCodeF regx `bind` \ code_x ->
677 registerNameF regx `bind` \ r_x ->
679 mkSeqInstr (MOV L (OpReg r_x) (OpReg dst)) .
680 mkSeqInstr (instr imm__2 (OpReg dst))
682 returnUs (Any IntRep mkcode)
685 imm__2 = case imm of Just x -> x
687 {- Case2: shift length is complex (non-immediate) -}
688 -- Since ECX is always used as a spill temporary, we can't
689 -- use it here to do non-immediate shifts. No big deal --
690 -- they are only very rare, and we can use an equivalent
691 -- test-and-jump sequence which doesn't use ECX.
692 -- DO NOT USE REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
693 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
694 shift_code instr x y{-amount-}
695 = getRegister x `thenUs` \ register1 ->
696 getRegister y `thenUs` \ register2 ->
697 getUniqLabelNCG `thenUs` \ lbl_test3 ->
698 getUniqLabelNCG `thenUs` \ lbl_test2 ->
699 getUniqLabelNCG `thenUs` \ lbl_test1 ->
700 getUniqLabelNCG `thenUs` \ lbl_test0 ->
701 getUniqLabelNCG `thenUs` \ lbl_after ->
702 getNewRegNCG IntRep `thenUs` \ tmp ->
704 = let src_val = registerName register1 dst
705 code_val = registerCode register1 dst
706 src_amt = registerName register2 tmp
707 code_amt = registerCode register2 tmp
712 mkSeqInstr (MOV L (OpReg src_amt) r_tmp) .
714 mkSeqInstr (MOV L (OpReg src_val) r_dst) .
716 COMMENT (_PK_ "begin shift sequence"),
717 MOV L (OpReg src_val) r_dst,
718 MOV L (OpReg src_amt) r_tmp,
720 BT L (ImmInt 4) r_tmp,
722 instr (ImmInt 16) r_dst,
725 BT L (ImmInt 3) r_tmp,
727 instr (ImmInt 8) r_dst,
730 BT L (ImmInt 2) r_tmp,
732 instr (ImmInt 4) r_dst,
735 BT L (ImmInt 1) r_tmp,
737 instr (ImmInt 2) r_dst,
740 BT L (ImmInt 0) r_tmp,
742 instr (ImmInt 1) r_dst,
745 COMMENT (_PK_ "end shift sequence")
748 returnUs (Any IntRep code__2)
751 add_code :: Size -> StixTree -> StixTree -> UniqSM Register
753 add_code sz x (StInt y)
754 = getRegister x `thenUs` \ register ->
755 getNewRegNCG IntRep `thenUs` \ tmp ->
757 code = registerCode register tmp
758 src1 = registerName register tmp
759 src2 = ImmInt (fromInteger y)
762 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
765 returnUs (Any IntRep code__2)
768 = getRegister x `thenUs` \ register1 ->
769 getRegister y `thenUs` \ register2 ->
770 getNewRegNCG IntRep `thenUs` \ tmp1 ->
771 getNewRegNCG IntRep `thenUs` \ tmp2 ->
773 code1 = registerCode register1 tmp1 asmVoid
774 src1 = registerName register1 tmp1
775 code2 = registerCode register2 tmp2 asmVoid
776 src2 = registerName register2 tmp2
778 = asmParThen [code1, code2] .
779 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1))
783 returnUs (Any IntRep code__2)
786 sub_code :: Size -> StixTree -> StixTree -> UniqSM Register
788 sub_code sz x (StInt y)
789 = getRegister x `thenUs` \ register ->
790 getNewRegNCG IntRep `thenUs` \ tmp ->
792 code = registerCode register tmp
793 src1 = registerName register tmp
794 src2 = ImmInt (-(fromInteger y))
797 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
800 returnUs (Any IntRep code__2)
802 sub_code sz x y = trivialCode (SUB sz) Nothing x y
807 -> StixTree -> StixTree
808 -> Bool -- True => division, False => remainder operation
811 -- x must go into eax, edx must be a sign-extension of eax, and y
812 -- should go in some other register (or memory), so that we get
813 -- edx:eax / reg -> eax (remainder in edx) Currently we chose to
814 -- put y in memory (if it is not there already)
816 -- quot_code needs further checking in the Rules-of-the-Game(x86) audit
817 quot_code sz x (StInd pk mem) is_division
818 = getRegister x `thenUs` \ register1 ->
819 getNewRegNCG IntRep `thenUs` \ tmp1 ->
820 getAmode mem `thenUs` \ amode ->
822 code1 = registerCode register1 tmp1 asmVoid
823 src1 = registerName register1 tmp1
824 code2 = amodeCode amode asmVoid
825 src2 = amodeAddr amode
826 code__2 = asmParThen [code1, code2] .
827 mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
829 IDIV sz (OpAddr src2)]
831 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
833 quot_code sz x (StInt i) is_division
834 = getRegister x `thenUs` \ register1 ->
835 getNewRegNCG IntRep `thenUs` \ tmp1 ->
837 code1 = registerCode register1 tmp1 asmVoid
838 src1 = registerName register1 tmp1
839 src2 = ImmInt (fromInteger i)
840 code__2 = asmParThen [code1] .
841 mkSeqInstrs [-- we put src2 in (ebx)
843 (OpAddr (AddrBaseIndex (Just ebx) Nothing
844 (ImmInt OFFSET_R1))),
845 MOV L (OpReg src1) (OpReg eax),
847 IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing
851 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
853 quot_code sz x y is_division
854 = getRegister x `thenUs` \ register1 ->
855 getNewRegNCG IntRep `thenUs` \ tmp1 ->
856 getRegister y `thenUs` \ register2 ->
857 getNewRegNCG IntRep `thenUs` \ tmp2 ->
859 code1 = registerCode register1 tmp1 asmVoid
860 src1 = registerName register1 tmp1
861 code2 = registerCode register2 tmp2 asmVoid
862 src2 = registerName register2 tmp2
863 code__2 = asmParThen [code1, code2] .
864 if src2 == ecx || src2 == esi
866 MOV L (OpReg src1) (OpReg eax),
870 else mkSeqInstrs [ -- we put src2 in (ebx)
872 (OpAddr (AddrBaseIndex (Just ebx) Nothing
873 (ImmInt OFFSET_R1))),
874 MOV L (OpReg src1) (OpReg eax),
876 IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing
880 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
881 -----------------------
883 getRegister (StInd pk mem)
884 = getAmode mem `thenUs` \ amode ->
886 code = amodeCode amode
887 src = amodeAddr amode
888 size = primRepToSize pk
890 if pk == DoubleRep || pk == FloatRep
891 then mkSeqInstr (GLD size src dst)
892 else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
894 returnUs (Any pk code__2)
896 getRegister (StInt i)
898 src = ImmInt (fromInteger i)
899 code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
901 returnUs (Any IntRep code)
906 code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
908 returnUs (Any PtrRep code)
910 = pprPanic "getRegister(x86)" (pprStixTrees [leaf])
913 imm__2 = case imm of Just x -> x
915 #endif {- i386_TARGET_ARCH -}
916 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
917 #if sparc_TARGET_ARCH
919 getRegister (StDouble d)
920 = getUniqLabelNCG `thenUs` \ lbl ->
921 getNewRegNCG PtrRep `thenUs` \ tmp ->
922 let code dst = mkSeqInstrs [
925 DATA DF [ImmDouble d],
927 SETHI (HI (ImmCLbl lbl)) tmp,
928 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
930 returnUs (Any DoubleRep code)
932 getRegister (StPrim primop [x]) -- unary PrimOps
934 IntNegOp -> trivialUCode (SUB False False g0) x
935 NotOp -> trivialUCode (XNOR False g0) x
937 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
939 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
941 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
942 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
944 OrdOp -> coerceIntCode IntRep x
947 Float2IntOp -> coerceFP2Int x
948 Int2FloatOp -> coerceInt2FP FloatRep x
949 Double2IntOp -> coerceFP2Int x
950 Int2DoubleOp -> coerceInt2FP DoubleRep x
954 fixed_x = if is_float_op -- promote to double
955 then StPrim Float2DoubleOp [x]
958 getRegister (StCall fn cCallConv DoubleRep [x])
962 FloatExpOp -> (True, SLIT("exp"))
963 FloatLogOp -> (True, SLIT("log"))
964 FloatSqrtOp -> (True, SLIT("sqrt"))
966 FloatSinOp -> (True, SLIT("sin"))
967 FloatCosOp -> (True, SLIT("cos"))
968 FloatTanOp -> (True, SLIT("tan"))
970 FloatAsinOp -> (True, SLIT("asin"))
971 FloatAcosOp -> (True, SLIT("acos"))
972 FloatAtanOp -> (True, SLIT("atan"))
974 FloatSinhOp -> (True, SLIT("sinh"))
975 FloatCoshOp -> (True, SLIT("cosh"))
976 FloatTanhOp -> (True, SLIT("tanh"))
978 DoubleExpOp -> (False, SLIT("exp"))
979 DoubleLogOp -> (False, SLIT("log"))
980 DoubleSqrtOp -> (True, SLIT("sqrt"))
982 DoubleSinOp -> (False, SLIT("sin"))
983 DoubleCosOp -> (False, SLIT("cos"))
984 DoubleTanOp -> (False, SLIT("tan"))
986 DoubleAsinOp -> (False, SLIT("asin"))
987 DoubleAcosOp -> (False, SLIT("acos"))
988 DoubleAtanOp -> (False, SLIT("atan"))
990 DoubleSinhOp -> (False, SLIT("sinh"))
991 DoubleCoshOp -> (False, SLIT("cosh"))
992 DoubleTanhOp -> (False, SLIT("tanh"))
993 _ -> panic ("Monadic PrimOp not handled: " ++ show primop)
995 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
997 CharGtOp -> condIntReg GTT x y
998 CharGeOp -> condIntReg GE x y
999 CharEqOp -> condIntReg EQQ x y
1000 CharNeOp -> condIntReg NE x y
1001 CharLtOp -> condIntReg LTT x y
1002 CharLeOp -> condIntReg LE x y
1004 IntGtOp -> condIntReg GTT x y
1005 IntGeOp -> condIntReg GE x y
1006 IntEqOp -> condIntReg EQQ x y
1007 IntNeOp -> condIntReg NE x y
1008 IntLtOp -> condIntReg LTT x y
1009 IntLeOp -> condIntReg LE x y
1011 WordGtOp -> condIntReg GU x y
1012 WordGeOp -> condIntReg GEU x y
1013 WordEqOp -> condIntReg EQQ x y
1014 WordNeOp -> condIntReg NE x y
1015 WordLtOp -> condIntReg LU x y
1016 WordLeOp -> condIntReg LEU x y
1018 AddrGtOp -> condIntReg GU x y
1019 AddrGeOp -> condIntReg GEU x y
1020 AddrEqOp -> condIntReg EQQ x y
1021 AddrNeOp -> condIntReg NE x y
1022 AddrLtOp -> condIntReg LU x y
1023 AddrLeOp -> condIntReg LEU x y
1025 FloatGtOp -> condFltReg GTT x y
1026 FloatGeOp -> condFltReg GE x y
1027 FloatEqOp -> condFltReg EQQ x y
1028 FloatNeOp -> condFltReg NE x y
1029 FloatLtOp -> condFltReg LTT x y
1030 FloatLeOp -> condFltReg LE x y
1032 DoubleGtOp -> condFltReg GTT x y
1033 DoubleGeOp -> condFltReg GE x y
1034 DoubleEqOp -> condFltReg EQQ x y
1035 DoubleNeOp -> condFltReg NE x y
1036 DoubleLtOp -> condFltReg LTT x y
1037 DoubleLeOp -> condFltReg LE x y
1039 IntAddOp -> trivialCode (ADD False False) x y
1040 IntSubOp -> trivialCode (SUB False False) x y
1042 -- ToDo: teach about V8+ SPARC mul/div instructions
1043 IntMulOp -> imul_div SLIT(".umul") x y
1044 IntQuotOp -> imul_div SLIT(".div") x y
1045 IntRemOp -> imul_div SLIT(".rem") x y
1047 FloatAddOp -> trivialFCode FloatRep FADD x y
1048 FloatSubOp -> trivialFCode FloatRep FSUB x y
1049 FloatMulOp -> trivialFCode FloatRep FMUL x y
1050 FloatDivOp -> trivialFCode FloatRep FDIV x y
1052 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1053 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1054 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1055 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1057 AndOp -> trivialCode (AND False) x y
1058 OrOp -> trivialCode (OR False) x y
1059 XorOp -> trivialCode (XOR False) x y
1060 SllOp -> trivialCode SLL x y
1061 SrlOp -> trivialCode SRL x y
1063 ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
1064 ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
1065 ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
1067 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
1068 where promote x = StPrim Float2DoubleOp [x]
1069 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
1070 -- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
1072 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1074 getRegister (StInd pk mem)
1075 = getAmode mem `thenUs` \ amode ->
1077 code = amodeCode amode
1078 src = amodeAddr amode
1079 size = primRepToSize pk
1080 code__2 dst = code . mkSeqInstr (LD size src dst)
1082 returnUs (Any pk code__2)
1084 getRegister (StInt i)
1087 src = ImmInt (fromInteger i)
1088 code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
1090 returnUs (Any IntRep code)
1095 code dst = mkSeqInstrs [
1096 SETHI (HI imm__2) dst,
1097 OR False dst (RIImm (LO imm__2)) dst]
1099 returnUs (Any PtrRep code)
1102 imm__2 = case imm of Just x -> x
1104 #endif {- sparc_TARGET_ARCH -}
1107 %************************************************************************
1109 \subsection{The @Amode@ type}
1111 %************************************************************************
1113 @Amode@s: Memory addressing modes passed up the tree.
1115 data Amode = Amode MachRegsAddr InstrBlock
1117 amodeAddr (Amode addr _) = addr
1118 amodeCode (Amode _ code) = code
1121 Now, given a tree (the argument to an StInd) that references memory,
1122 produce a suitable addressing mode.
1125 getAmode :: StixTree -> UniqSM Amode
1127 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1129 #if alpha_TARGET_ARCH
1131 getAmode (StPrim IntSubOp [x, StInt i])
1132 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1133 getRegister x `thenUs` \ register ->
1135 code = registerCode register tmp
1136 reg = registerName register tmp
1137 off = ImmInt (-(fromInteger i))
1139 returnUs (Amode (AddrRegImm reg off) code)
1141 getAmode (StPrim IntAddOp [x, StInt i])
1142 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1143 getRegister x `thenUs` \ register ->
1145 code = registerCode register tmp
1146 reg = registerName register tmp
1147 off = ImmInt (fromInteger i)
1149 returnUs (Amode (AddrRegImm reg off) code)
1153 = returnUs (Amode (AddrImm imm__2) id)
1156 imm__2 = case imm of Just x -> x
1159 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1160 getRegister other `thenUs` \ register ->
1162 code = registerCode register tmp
1163 reg = registerName register tmp
1165 returnUs (Amode (AddrReg reg) code)
1167 #endif {- alpha_TARGET_ARCH -}
1168 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1169 #if i386_TARGET_ARCH
1171 getAmode (StPrim IntSubOp [x, StInt i])
1172 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1173 getRegister x `thenUs` \ register ->
1175 code = registerCode register tmp
1176 reg = registerName register tmp
1177 off = ImmInt (-(fromInteger i))
1179 returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1181 getAmode (StPrim IntAddOp [x, StInt i])
1184 code = mkSeqInstrs []
1186 returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
1189 imm__2 = case imm of Just x -> x
1191 getAmode (StPrim IntAddOp [x, StInt i])
1192 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1193 getRegister x `thenUs` \ register ->
1195 code = registerCode register tmp
1196 reg = registerName register tmp
1197 off = ImmInt (fromInteger i)
1199 returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1201 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1202 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1203 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1204 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1205 getRegister x `thenUs` \ register1 ->
1206 getRegister y `thenUs` \ register2 ->
1208 code1 = registerCode register1 tmp1 asmVoid
1209 reg1 = registerName register1 tmp1
1210 code2 = registerCode register2 tmp2 asmVoid
1211 reg2 = registerName register2 tmp2
1212 code__2 = asmParThen [code1, code2]
1213 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1215 returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1221 code = mkSeqInstrs []
1223 returnUs (Amode (ImmAddr imm__2 0) code)
1226 imm__2 = case imm of Just x -> x
1229 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1230 getRegister other `thenUs` \ register ->
1232 code = registerCode register tmp
1233 reg = registerName register tmp
1236 returnUs (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1238 #endif {- i386_TARGET_ARCH -}
1239 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1240 #if sparc_TARGET_ARCH
1242 getAmode (StPrim IntSubOp [x, StInt i])
1244 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1245 getRegister x `thenUs` \ register ->
1247 code = registerCode register tmp
1248 reg = registerName register tmp
1249 off = ImmInt (-(fromInteger i))
1251 returnUs (Amode (AddrRegImm reg off) code)
1254 getAmode (StPrim IntAddOp [x, StInt i])
1256 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1257 getRegister x `thenUs` \ register ->
1259 code = registerCode register tmp
1260 reg = registerName register tmp
1261 off = ImmInt (fromInteger i)
1263 returnUs (Amode (AddrRegImm reg off) code)
1265 getAmode (StPrim IntAddOp [x, y])
1266 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1267 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1268 getRegister x `thenUs` \ register1 ->
1269 getRegister y `thenUs` \ register2 ->
1271 code1 = registerCode register1 tmp1 asmVoid
1272 reg1 = registerName register1 tmp1
1273 code2 = registerCode register2 tmp2 asmVoid
1274 reg2 = registerName register2 tmp2
1275 code__2 = asmParThen [code1, code2]
1277 returnUs (Amode (AddrRegReg reg1 reg2) code__2)
1281 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1283 code = mkSeqInstr (SETHI (HI imm__2) tmp)
1285 returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
1288 imm__2 = case imm of Just x -> x
1291 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1292 getRegister other `thenUs` \ register ->
1294 code = registerCode register tmp
1295 reg = registerName register tmp
1298 returnUs (Amode (AddrRegImm reg off) code)
1300 #endif {- sparc_TARGET_ARCH -}
1303 %************************************************************************
1305 \subsection{The @CondCode@ type}
1307 %************************************************************************
1309 Condition codes passed up the tree.
1311 data CondCode = CondCode Bool Cond InstrBlock
1313 condName (CondCode _ cond _) = cond
1314 condFloat (CondCode is_float _ _) = is_float
1315 condCode (CondCode _ _ code) = code
1318 Set up a condition code for a conditional branch.
1321 getCondCode :: StixTree -> UniqSM CondCode
1323 #if alpha_TARGET_ARCH
1324 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1325 #endif {- alpha_TARGET_ARCH -}
1326 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1328 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1329 -- yes, they really do seem to want exactly the same!
1331 getCondCode (StPrim primop [x, y])
1333 CharGtOp -> condIntCode GTT x y
1334 CharGeOp -> condIntCode GE x y
1335 CharEqOp -> condIntCode EQQ x y
1336 CharNeOp -> condIntCode NE x y
1337 CharLtOp -> condIntCode LTT x y
1338 CharLeOp -> condIntCode LE x y
1340 IntGtOp -> condIntCode GTT x y
1341 IntGeOp -> condIntCode GE x y
1342 IntEqOp -> condIntCode EQQ x y
1343 IntNeOp -> condIntCode NE x y
1344 IntLtOp -> condIntCode LTT x y
1345 IntLeOp -> condIntCode LE x y
1347 WordGtOp -> condIntCode GU x y
1348 WordGeOp -> condIntCode GEU x y
1349 WordEqOp -> condIntCode EQQ x y
1350 WordNeOp -> condIntCode NE x y
1351 WordLtOp -> condIntCode LU x y
1352 WordLeOp -> condIntCode LEU x y
1354 AddrGtOp -> condIntCode GU x y
1355 AddrGeOp -> condIntCode GEU x y
1356 AddrEqOp -> condIntCode EQQ x y
1357 AddrNeOp -> condIntCode NE x y
1358 AddrLtOp -> condIntCode LU x y
1359 AddrLeOp -> condIntCode LEU x y
1361 FloatGtOp -> condFltCode GTT x y
1362 FloatGeOp -> condFltCode GE x y
1363 FloatEqOp -> condFltCode EQQ x y
1364 FloatNeOp -> condFltCode NE x y
1365 FloatLtOp -> condFltCode LTT x y
1366 FloatLeOp -> condFltCode LE x y
1368 DoubleGtOp -> condFltCode GTT x y
1369 DoubleGeOp -> condFltCode GE x y
1370 DoubleEqOp -> condFltCode EQQ x y
1371 DoubleNeOp -> condFltCode NE x y
1372 DoubleLtOp -> condFltCode LTT x y
1373 DoubleLeOp -> condFltCode LE x y
1375 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1380 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1381 passed back up the tree.
1384 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode
1386 #if alpha_TARGET_ARCH
1387 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1388 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1389 #endif {- alpha_TARGET_ARCH -}
1391 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1392 #if i386_TARGET_ARCH
1394 -- some condIntCode clauses look pretty dodgy to me
1395 condIntCode cond (StInd _ x) y
1397 = getAmode x `thenUs` \ amode ->
1399 code1 = amodeCode amode asmVoid
1400 y__2 = amodeAddr amode
1401 code__2 = asmParThen [code1] .
1402 mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
1404 returnUs (CondCode False cond code__2)
1407 imm__2 = case imm of Just x -> x
1409 condIntCode cond x (StInt 0)
1410 = getRegister x `thenUs` \ register1 ->
1411 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1413 code1 = registerCode register1 tmp1 asmVoid
1414 src1 = registerName register1 tmp1
1415 code__2 = asmParThen [code1] .
1416 mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
1418 returnUs (CondCode False cond code__2)
1420 condIntCode cond x y
1422 = getRegister x `thenUs` \ register1 ->
1423 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1425 code1 = registerCode register1 tmp1 asmVoid
1426 src1 = registerName register1 tmp1
1427 code__2 = asmParThen [code1] .
1428 mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
1430 returnUs (CondCode False cond code__2)
1433 imm__2 = case imm of Just x -> x
1435 condIntCode cond (StInd _ x) y
1436 = getAmode x `thenUs` \ amode ->
1437 getRegister y `thenUs` \ register2 ->
1438 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1440 code1 = amodeCode amode asmVoid
1441 src1 = amodeAddr amode
1442 code2 = registerCode register2 tmp2 asmVoid
1443 src2 = registerName register2 tmp2
1444 code__2 = asmParThen [code1, code2] .
1445 mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
1447 returnUs (CondCode False cond code__2)
1449 condIntCode cond y (StInd _ x)
1450 = getAmode x `thenUs` \ amode ->
1451 getRegister y `thenUs` \ register2 ->
1452 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1454 code1 = amodeCode amode asmVoid
1455 src1 = amodeAddr amode
1456 code2 = registerCode register2 tmp2 asmVoid
1457 src2 = registerName register2 tmp2
1458 code__2 = asmParThen [code1, code2] .
1459 mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
1461 returnUs (CondCode False cond code__2)
1463 condIntCode cond x y
1464 = getRegister x `thenUs` \ register1 ->
1465 getRegister y `thenUs` \ register2 ->
1466 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1467 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1469 code1 = registerCode register1 tmp1 asmVoid
1470 src1 = registerName register1 tmp1
1471 code2 = registerCode register2 tmp2 asmVoid
1472 src2 = registerName register2 tmp2
1473 code__2 = asmParThen [code1, code2] .
1474 mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
1476 returnUs (CondCode False cond code__2)
1479 condFltCode cond x y
1480 = getRegister x `thenUs` \ register1 ->
1481 getRegister y `thenUs` \ register2 ->
1482 getNewRegNCG (registerRep register1)
1484 getNewRegNCG (registerRep register2)
1486 getNewRegNCG DoubleRep `thenUs` \ tmp ->
1488 pk1 = registerRep register1
1489 code1 = registerCode register1 tmp1
1490 src1 = registerName register1 tmp1
1492 pk2 = registerRep register2
1493 code2 = registerCode register2 tmp2
1494 src2 = registerName register2 tmp2
1496 code__2 = asmParThen [code1 asmVoid, code2 asmVoid] .
1497 mkSeqInstr (GCMP (primRepToSize pk1) src1 src2)
1499 {- On the 486, the flags set by FP compare are the unsigned ones!
1500 (This looks like a HACK to me. WDP 96/03)
1502 fix_FP_cond :: Cond -> Cond
1504 fix_FP_cond GE = GEU
1505 fix_FP_cond GTT = GU
1506 fix_FP_cond LTT = LU
1507 fix_FP_cond LE = LEU
1508 fix_FP_cond any = any
1510 returnUs (CondCode True (fix_FP_cond cond) code__2)
1514 #endif {- i386_TARGET_ARCH -}
1515 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1516 #if sparc_TARGET_ARCH
1518 condIntCode cond x (StInt y)
1520 = getRegister x `thenUs` \ register ->
1521 getNewRegNCG IntRep `thenUs` \ tmp ->
1523 code = registerCode register tmp
1524 src1 = registerName register tmp
1525 src2 = ImmInt (fromInteger y)
1526 code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
1528 returnUs (CondCode False cond code__2)
1530 condIntCode cond x y
1531 = getRegister x `thenUs` \ register1 ->
1532 getRegister y `thenUs` \ register2 ->
1533 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1534 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1536 code1 = registerCode register1 tmp1 asmVoid
1537 src1 = registerName register1 tmp1
1538 code2 = registerCode register2 tmp2 asmVoid
1539 src2 = registerName register2 tmp2
1540 code__2 = asmParThen [code1, code2] .
1541 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
1543 returnUs (CondCode False cond code__2)
1546 condFltCode cond x y
1547 = getRegister x `thenUs` \ register1 ->
1548 getRegister y `thenUs` \ register2 ->
1549 getNewRegNCG (registerRep register1)
1551 getNewRegNCG (registerRep register2)
1553 getNewRegNCG DoubleRep `thenUs` \ tmp ->
1555 promote x = asmInstr (FxTOy F DF x tmp)
1557 pk1 = registerRep register1
1558 code1 = registerCode register1 tmp1
1559 src1 = registerName register1 tmp1
1561 pk2 = registerRep register2
1562 code2 = registerCode register2 tmp2
1563 src2 = registerName register2 tmp2
1567 asmParThen [code1 asmVoid, code2 asmVoid] .
1568 mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
1569 else if pk1 == FloatRep then
1570 asmParThen [code1 (promote src1), code2 asmVoid] .
1571 mkSeqInstr (FCMP True DF tmp src2)
1573 asmParThen [code1 asmVoid, code2 (promote src2)] .
1574 mkSeqInstr (FCMP True DF src1 tmp)
1576 returnUs (CondCode True cond code__2)
1578 #endif {- sparc_TARGET_ARCH -}
1581 %************************************************************************
1583 \subsection{Generating assignments}
1585 %************************************************************************
1587 Assignments are really at the heart of the whole code generation
1588 business. Almost all top-level nodes of any real importance are
1589 assignments, which correspond to loads, stores, or register transfers.
1590 If we're really lucky, some of the register transfers will go away,
1591 because we can use the destination register to complete the code
1592 generation for the right hand side. This only fails when the right
1593 hand side is forced into a fixed register (e.g. the result of a call).
1596 assignIntCode, assignFltCode
1597 :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
1599 #if alpha_TARGET_ARCH
1601 assignIntCode pk (StInd _ dst) src
1602 = getNewRegNCG IntRep `thenUs` \ tmp ->
1603 getAmode dst `thenUs` \ amode ->
1604 getRegister src `thenUs` \ register ->
1606 code1 = amodeCode amode asmVoid
1607 dst__2 = amodeAddr amode
1608 code2 = registerCode register tmp asmVoid
1609 src__2 = registerName register tmp
1610 sz = primRepToSize pk
1611 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1615 assignIntCode pk dst src
1616 = getRegister dst `thenUs` \ register1 ->
1617 getRegister src `thenUs` \ register2 ->
1619 dst__2 = registerName register1 zeroh
1620 code = registerCode register2 dst__2
1621 src__2 = registerName register2 dst__2
1622 code__2 = if isFixed register2
1623 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1628 #endif {- alpha_TARGET_ARCH -}
1629 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1630 #if i386_TARGET_ARCH
1632 -- looks dodgy to me
1633 assignIntCode pk dd@(StInd _ dst) src
1634 = getAmode dst `thenUs` \ amode ->
1635 get_op_RI src `thenUs` \ (codesrc, opsrc) ->
1637 code1 = amodeCode amode asmVoid
1638 dst__2 = amodeAddr amode
1639 code__2 = asmParThen [code1, codesrc asmVoid] .
1640 mkSeqInstr (MOV (primRepToSize pk) opsrc (OpAddr dst__2))
1646 -> UniqSM (InstrBlock,Operand) -- code, operator
1650 = returnUs (asmParThen [], OpImm imm_op)
1653 imm_op = case imm of Just x -> x
1656 = getRegister op `thenUs` \ register ->
1657 getNewRegNCG (registerRep register)
1660 code = registerCode register tmp
1661 reg = registerName register tmp
1663 returnUs (code, OpReg reg)
1665 assignIntCode pk dst (StInd pks src)
1666 = getNewRegNCG IntRep `thenUs` \ tmp ->
1667 getAmode src `thenUs` \ amode ->
1668 getRegister dst `thenUs` \ register ->
1670 code1 = amodeCode amode asmVoid
1671 src__2 = amodeAddr amode
1672 code2 = registerCode register tmp asmVoid
1673 dst__2 = registerName register tmp
1674 szs = primRepToSize pks
1675 code__2 = asmParThen [code1, code2] .
1677 L -> mkSeqInstr (MOV L (OpAddr src__2) (OpReg dst__2))
1678 B -> mkSeqInstr (MOVZxL B (OpAddr src__2) (OpReg dst__2))
1682 assignIntCode pk dst src
1683 = getRegister dst `thenUs` \ register1 ->
1684 getRegister src `thenUs` \ register2 ->
1685 getNewRegNCG IntRep `thenUs` \ tmp ->
1687 dst__2 = registerName register1 tmp
1688 code = registerCode register2 dst__2
1689 src__2 = registerName register2 dst__2
1690 code__2 = if isFixed register2 && dst__2 /= src__2
1691 then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
1696 #endif {- i386_TARGET_ARCH -}
1697 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1698 #if sparc_TARGET_ARCH
1700 assignIntCode pk (StInd _ dst) src
1701 = getNewRegNCG IntRep `thenUs` \ tmp ->
1702 getAmode dst `thenUs` \ amode ->
1703 getRegister src `thenUs` \ register ->
1705 code1 = amodeCode amode asmVoid
1706 dst__2 = amodeAddr amode
1707 code2 = registerCode register tmp asmVoid
1708 src__2 = registerName register tmp
1709 sz = primRepToSize pk
1710 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1714 assignIntCode pk dst src
1715 = getRegister dst `thenUs` \ register1 ->
1716 getRegister src `thenUs` \ register2 ->
1718 dst__2 = registerName register1 g0
1719 code = registerCode register2 dst__2
1720 src__2 = registerName register2 dst__2
1721 code__2 = if isFixed register2
1722 then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
1727 #endif {- sparc_TARGET_ARCH -}
1730 % --------------------------------
1731 Floating-point assignments:
1732 % --------------------------------
1734 #if alpha_TARGET_ARCH
1736 assignFltCode pk (StInd _ dst) src
1737 = getNewRegNCG pk `thenUs` \ tmp ->
1738 getAmode dst `thenUs` \ amode ->
1739 getRegister src `thenUs` \ register ->
1741 code1 = amodeCode amode asmVoid
1742 dst__2 = amodeAddr amode
1743 code2 = registerCode register tmp asmVoid
1744 src__2 = registerName register tmp
1745 sz = primRepToSize pk
1746 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1750 assignFltCode pk dst src
1751 = getRegister dst `thenUs` \ register1 ->
1752 getRegister src `thenUs` \ register2 ->
1754 dst__2 = registerName register1 zeroh
1755 code = registerCode register2 dst__2
1756 src__2 = registerName register2 dst__2
1757 code__2 = if isFixed register2
1758 then code . mkSeqInstr (FMOV src__2 dst__2)
1763 #endif {- alpha_TARGET_ARCH -}
1764 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1765 #if i386_TARGET_ARCH
1767 assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
1768 = getNewRegNCG IntRep `thenUs` \ tmp ->
1769 getAmode src `thenUs` \ amodesrc ->
1770 getAmode dst `thenUs` \ amodedst ->
1772 codesrc1 = amodeCode amodesrc asmVoid
1773 addrsrc1 = amodeAddr amodesrc
1774 codedst1 = amodeCode amodedst asmVoid
1775 addrdst1 = amodeAddr amodedst
1776 addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x
1777 addrdst2 = case (addrOffset addrdst1 4) of Just x -> x
1779 code__2 = asmParThen [codesrc1, codedst1] .
1780 mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
1781 MOV L (OpReg tmp) (OpAddr addrdst1)]
1784 then [MOV L (OpAddr addrsrc2) (OpReg tmp),
1785 MOV L (OpReg tmp) (OpAddr addrdst2)]
1790 assignFltCode pk (StInd _ dst) src
1791 = getNewRegNCG pk `thenUs` \ tmp ->
1792 getAmode dst `thenUs` \ amode ->
1793 getRegister src `thenUs` \ register ->
1795 sz = primRepToSize pk
1796 dst__2 = amodeAddr amode
1798 code1 = amodeCode amode asmVoid
1799 code2 = registerCode register tmp asmVoid
1801 src__2 = registerName register tmp
1803 code__2 = asmParThen [code1, code2] .
1804 mkSeqInstr (GST sz src__2 dst__2)
1808 assignFltCode pk dst src
1809 = getRegister dst `thenUs` \ register1 ->
1810 getRegister src `thenUs` \ register2 ->
1811 getNewRegNCG pk `thenUs` \ tmp ->
1813 -- the register which is dst
1814 dst__2 = registerName register1 tmp
1815 -- the register into which src is computed, preferably dst__2
1816 src__2 = registerName register2 dst__2
1817 -- code to compute src into src__2
1818 code = registerCode register2 dst__2
1820 code__2 = if isFixed register2
1821 then code . mkSeqInstr (GMOV src__2 dst__2)
1826 #endif {- i386_TARGET_ARCH -}
1827 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1828 #if sparc_TARGET_ARCH
1830 assignFltCode pk (StInd _ dst) src
1831 = getNewRegNCG pk `thenUs` \ tmp1 ->
1832 getAmode dst `thenUs` \ amode ->
1833 getRegister src `thenUs` \ register ->
1835 sz = primRepToSize pk
1836 dst__2 = amodeAddr amode
1838 code1 = amodeCode amode asmVoid
1839 code2 = registerCode register tmp1 asmVoid
1841 src__2 = registerName register tmp1
1842 pk__2 = registerRep register
1843 sz__2 = primRepToSize pk__2
1845 code__2 = asmParThen [code1, code2] .
1847 mkSeqInstr (ST sz src__2 dst__2)
1849 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1853 assignFltCode pk dst src
1854 = getRegister dst `thenUs` \ register1 ->
1855 getRegister src `thenUs` \ register2 ->
1857 pk__2 = registerRep register2
1858 sz__2 = primRepToSize pk__2
1860 getNewRegNCG pk__2 `thenUs` \ tmp ->
1862 sz = primRepToSize pk
1863 dst__2 = registerName register1 g0 -- must be Fixed
1866 reg__2 = if pk /= pk__2 then tmp else dst__2
1868 code = registerCode register2 reg__2
1870 src__2 = registerName register2 reg__2
1874 code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
1875 else if isFixed register2 then
1876 code . mkSeqInstr (FMOV sz src__2 dst__2)
1882 #endif {- sparc_TARGET_ARCH -}
1885 %************************************************************************
1887 \subsection{Generating an unconditional branch}
1889 %************************************************************************
1891 We accept two types of targets: an immediate CLabel or a tree that
1892 gets evaluated into a register. Any CLabels which are AsmTemporaries
1893 are assumed to be in the local block of code, close enough for a
1894 branch instruction. Other CLabels are assumed to be far away.
1896 (If applicable) Do not fill the delay slots here; you will confuse the
1900 genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
1902 #if alpha_TARGET_ARCH
1904 genJump (StCLbl lbl)
1905 | isAsmTemp lbl = returnInstr (BR target)
1906 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1908 target = ImmCLbl lbl
1911 = getRegister tree `thenUs` \ register ->
1912 getNewRegNCG PtrRep `thenUs` \ tmp ->
1914 dst = registerName register pv
1915 code = registerCode register pv
1916 target = registerName register pv
1918 if isFixed register then
1919 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1921 returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1923 #endif {- alpha_TARGET_ARCH -}
1924 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1925 #if i386_TARGET_ARCH
1928 genJump (StCLbl lbl)
1929 | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
1930 | otherwise = returnInstrs [JMP (OpImm target)]
1932 target = ImmCLbl lbl
1935 genJump (StInd pk mem)
1936 = getAmode mem `thenUs` \ amode ->
1938 code = amodeCode amode
1939 target = amodeAddr amode
1941 returnSeq code [JMP (OpAddr target)]
1945 = returnInstr (JMP (OpImm target))
1948 = getRegister tree `thenUs` \ register ->
1949 getNewRegNCG PtrRep `thenUs` \ tmp ->
1951 code = registerCode register tmp
1952 target = registerName register tmp
1954 returnSeq code [JMP (OpReg target)]
1957 target = case imm of Just x -> x
1959 #endif {- i386_TARGET_ARCH -}
1960 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1961 #if sparc_TARGET_ARCH
1963 genJump (StCLbl lbl)
1964 | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
1965 | otherwise = returnInstrs [CALL target 0 True, NOP]
1967 target = ImmCLbl lbl
1970 = getRegister tree `thenUs` \ register ->
1971 getNewRegNCG PtrRep `thenUs` \ tmp ->
1973 code = registerCode register tmp
1974 target = registerName register tmp
1976 returnSeq code [JMP (AddrRegReg target g0), NOP]
1978 #endif {- sparc_TARGET_ARCH -}
1981 %************************************************************************
1983 \subsection{Conditional jumps}
1985 %************************************************************************
1987 Conditional jumps are always to local labels, so we can use branch
1988 instructions. We peek at the arguments to decide what kind of
1991 ALPHA: For comparisons with 0, we're laughing, because we can just do
1992 the desired conditional branch.
1994 I386: First, we have to ensure that the condition
1995 codes are set according to the supplied comparison operation.
1997 SPARC: First, we have to ensure that the condition codes are set
1998 according to the supplied comparison operation. We generate slightly
1999 different code for floating point comparisons, because a floating
2000 point operation cannot directly precede a @BF@. We assume the worst
2001 and fill that slot with a @NOP@.
2003 SPARC: Do not fill the delay slots here; you will confuse the register
2008 :: CLabel -- the branch target
2009 -> StixTree -- the condition on which to branch
2010 -> UniqSM InstrBlock
2012 #if alpha_TARGET_ARCH
2014 genCondJump lbl (StPrim op [x, StInt 0])
2015 = getRegister x `thenUs` \ register ->
2016 getNewRegNCG (registerRep register)
2019 code = registerCode register tmp
2020 value = registerName register tmp
2021 pk = registerRep register
2022 target = ImmCLbl lbl
2024 returnSeq code [BI (cmpOp op) value target]
2026 cmpOp CharGtOp = GTT
2028 cmpOp CharEqOp = EQQ
2030 cmpOp CharLtOp = LTT
2039 cmpOp WordGeOp = ALWAYS
2040 cmpOp WordEqOp = EQQ
2042 cmpOp WordLtOp = NEVER
2043 cmpOp WordLeOp = EQQ
2045 cmpOp AddrGeOp = ALWAYS
2046 cmpOp AddrEqOp = EQQ
2048 cmpOp AddrLtOp = NEVER
2049 cmpOp AddrLeOp = EQQ
2051 genCondJump lbl (StPrim op [x, StDouble 0.0])
2052 = getRegister x `thenUs` \ register ->
2053 getNewRegNCG (registerRep register)
2056 code = registerCode register tmp
2057 value = registerName register tmp
2058 pk = registerRep register
2059 target = ImmCLbl lbl
2061 returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
2063 cmpOp FloatGtOp = GTT
2064 cmpOp FloatGeOp = GE
2065 cmpOp FloatEqOp = EQQ
2066 cmpOp FloatNeOp = NE
2067 cmpOp FloatLtOp = LTT
2068 cmpOp FloatLeOp = LE
2069 cmpOp DoubleGtOp = GTT
2070 cmpOp DoubleGeOp = GE
2071 cmpOp DoubleEqOp = EQQ
2072 cmpOp DoubleNeOp = NE
2073 cmpOp DoubleLtOp = LTT
2074 cmpOp DoubleLeOp = LE
2076 genCondJump lbl (StPrim op [x, y])
2078 = trivialFCode pr instr x y `thenUs` \ register ->
2079 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2081 code = registerCode register tmp
2082 result = registerName register tmp
2083 target = ImmCLbl lbl
2085 returnUs (code . mkSeqInstr (BF cond result target))
2087 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2089 fltCmpOp op = case op of
2103 (instr, cond) = case op of
2104 FloatGtOp -> (FCMP TF LE, EQQ)
2105 FloatGeOp -> (FCMP TF LTT, EQQ)
2106 FloatEqOp -> (FCMP TF EQQ, NE)
2107 FloatNeOp -> (FCMP TF EQQ, EQQ)
2108 FloatLtOp -> (FCMP TF LTT, NE)
2109 FloatLeOp -> (FCMP TF LE, NE)
2110 DoubleGtOp -> (FCMP TF LE, EQQ)
2111 DoubleGeOp -> (FCMP TF LTT, EQQ)
2112 DoubleEqOp -> (FCMP TF EQQ, NE)
2113 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2114 DoubleLtOp -> (FCMP TF LTT, NE)
2115 DoubleLeOp -> (FCMP TF LE, NE)
2117 genCondJump lbl (StPrim op [x, y])
2118 = trivialCode instr x y `thenUs` \ register ->
2119 getNewRegNCG IntRep `thenUs` \ tmp ->
2121 code = registerCode register tmp
2122 result = registerName register tmp
2123 target = ImmCLbl lbl
2125 returnUs (code . mkSeqInstr (BI cond result target))
2127 (instr, cond) = case op of
2128 CharGtOp -> (CMP LE, EQQ)
2129 CharGeOp -> (CMP LTT, EQQ)
2130 CharEqOp -> (CMP EQQ, NE)
2131 CharNeOp -> (CMP EQQ, EQQ)
2132 CharLtOp -> (CMP LTT, NE)
2133 CharLeOp -> (CMP LE, NE)
2134 IntGtOp -> (CMP LE, EQQ)
2135 IntGeOp -> (CMP LTT, EQQ)
2136 IntEqOp -> (CMP EQQ, NE)
2137 IntNeOp -> (CMP EQQ, EQQ)
2138 IntLtOp -> (CMP LTT, NE)
2139 IntLeOp -> (CMP LE, NE)
2140 WordGtOp -> (CMP ULE, EQQ)
2141 WordGeOp -> (CMP ULT, EQQ)
2142 WordEqOp -> (CMP EQQ, NE)
2143 WordNeOp -> (CMP EQQ, EQQ)
2144 WordLtOp -> (CMP ULT, NE)
2145 WordLeOp -> (CMP ULE, NE)
2146 AddrGtOp -> (CMP ULE, EQQ)
2147 AddrGeOp -> (CMP ULT, EQQ)
2148 AddrEqOp -> (CMP EQQ, NE)
2149 AddrNeOp -> (CMP EQQ, EQQ)
2150 AddrLtOp -> (CMP ULT, NE)
2151 AddrLeOp -> (CMP ULE, NE)
2153 #endif {- alpha_TARGET_ARCH -}
2154 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2155 #if i386_TARGET_ARCH
2157 genCondJump lbl bool
2158 = getCondCode bool `thenUs` \ condition ->
2160 code = condCode condition
2161 cond = condName condition
2162 target = ImmCLbl lbl
2164 returnSeq code [JXX cond lbl]
2166 #endif {- i386_TARGET_ARCH -}
2167 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2168 #if sparc_TARGET_ARCH
2170 genCondJump lbl bool
2171 = getCondCode bool `thenUs` \ condition ->
2173 code = condCode condition
2174 cond = condName condition
2175 target = ImmCLbl lbl
2178 if condFloat condition then
2179 [NOP, BF cond False target, NOP]
2181 [BI cond False target, NOP]
2184 #endif {- sparc_TARGET_ARCH -}
2187 %************************************************************************
2189 \subsection{Generating C calls}
2191 %************************************************************************
2193 Now the biggest nightmare---calls. Most of the nastiness is buried in
2194 @get_arg@, which moves the arguments to the correct registers/stack
2195 locations. Apart from that, the code is easy.
2197 (If applicable) Do not fill the delay slots here; you will confuse the
2202 :: FAST_STRING -- function to call
2204 -> PrimRep -- type of the result
2205 -> [StixTree] -- arguments (of mixed type)
2206 -> UniqSM InstrBlock
2208 #if alpha_TARGET_ARCH
2210 genCCall fn cconv kind args
2211 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2212 `thenUs` \ ((unused,_), argCode) ->
2214 nRegs = length allArgRegs - length unused
2215 code = asmParThen (map ($ asmVoid) argCode)
2218 LDA pv (AddrImm (ImmLab (ptext fn))),
2219 JSR ra (AddrReg pv) nRegs,
2220 LDGP gp (AddrReg ra)]
2222 ------------------------
2223 {- Try to get a value into a specific register (or registers) for
2224 a call. The first 6 arguments go into the appropriate
2225 argument register (separate registers for integer and floating
2226 point arguments, but used in lock-step), and the remaining
2227 arguments are dumped to the stack, beginning at 0(sp). Our
2228 first argument is a pair of the list of remaining argument
2229 registers to be assigned for this call and the next stack
2230 offset to use for overflowing arguments. This way,
2231 @get_Arg@ can be applied to all of a call's arguments using
2235 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2236 -> StixTree -- Current argument
2237 -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2239 -- We have to use up all of our argument registers first...
2241 get_arg ((iDst,fDst):dsts, offset) arg
2242 = getRegister arg `thenUs` \ register ->
2244 reg = if isFloatingRep pk then fDst else iDst
2245 code = registerCode register reg
2246 src = registerName register reg
2247 pk = registerRep register
2250 if isFloatingRep pk then
2251 ((dsts, offset), if isFixed register then
2252 code . mkSeqInstr (FMOV src fDst)
2255 ((dsts, offset), if isFixed register then
2256 code . mkSeqInstr (OR src (RIReg src) iDst)
2259 -- Once we have run out of argument registers, we move to the
2262 get_arg ([], offset) arg
2263 = getRegister arg `thenUs` \ register ->
2264 getNewRegNCG (registerRep register)
2267 code = registerCode register tmp
2268 src = registerName register tmp
2269 pk = registerRep register
2270 sz = primRepToSize pk
2272 returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2274 #endif {- alpha_TARGET_ARCH -}
2275 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2276 #if i386_TARGET_ARCH
2278 genCCall fn cconv kind [StInt i]
2279 | fn == SLIT ("PerformGC_wrapper")
2280 = let call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2281 CALL (ImmLit (ptext (if underscorePrefix
2282 then (SLIT ("_PerformGC_wrapper"))
2283 else (SLIT ("PerformGC_wrapper")))))]
2288 genCCall fn cconv kind args
2289 = get_call_args args `thenUs` \ (tot_arg_size, argCode) ->
2291 code2 = asmParThen (map ($ asmVoid) argCode)
2292 call = [SUB L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
2294 ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)
2297 returnSeq code2 call
2300 -- function names that begin with '.' are assumed to be special
2301 -- internally generated names like '.mul,' which don't get an
2302 -- underscore prefix
2303 -- ToDo:needed (WDP 96/03) ???
2304 fn__2 = case (_HEAD_ fn) of
2305 '.' -> ImmLit (ptext fn)
2306 _ -> ImmLab (ptext fn)
2313 -- do get_call_arg on each arg, threading the total arg size along
2314 -- process the args right-to-left
2315 get_call_args :: [StixTree] -> UniqSM (Int, [InstrBlock])
2320 = returnUs (curr_sz, [])
2321 f curr_sz (arg:args)
2322 = f curr_sz args `thenUs` \ (new_sz, iblocks) ->
2323 get_call_arg arg new_sz `thenUs` \ (new_sz2, iblock) ->
2324 returnUs (new_sz2, iblock:iblocks)
2328 get_call_arg :: StixTree{-current argument-}
2329 -> Int{-running total of arg sizes seen so far-}
2330 -> UniqSM (Int, InstrBlock) -- updated tot argsz, code
2332 get_call_arg arg old_sz
2333 = get_op arg `thenUs` \ (code, reg, sz) ->
2334 let new_sz = old_sz + arg_size sz
2335 in if (case sz of DF -> True; F -> True; _ -> False)
2336 then returnUs (new_sz,
2338 mkSeqInstr (GST DF reg
2339 (AddrBaseIndex (Just esp)
2340 Nothing (ImmInt (- new_sz))))
2342 else returnUs (new_sz,
2344 mkSeqInstr (MOV L (OpReg reg)
2346 (AddrBaseIndex (Just esp)
2347 Nothing (ImmInt (- new_sz)))))
2352 -> UniqSM (InstrBlock, Reg, Size) -- code, reg, size
2355 = getRegister op `thenUs` \ register ->
2356 getNewRegNCG (registerRep register)
2359 code = registerCode register tmp
2360 reg = registerName register tmp
2361 pk = registerRep register
2362 sz = primRepToSize pk
2364 returnUs (code, reg, sz)
2366 #endif {- i386_TARGET_ARCH -}
2367 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2368 #if sparc_TARGET_ARCH
2370 genCCall fn cconv kind args
2371 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2372 `thenUs` \ ((unused,_), argCode) ->
2374 nRegs = length allArgRegs - length unused
2375 call = CALL fn__2 nRegs False
2376 code = asmParThen (map ($ asmVoid) argCode)
2378 returnSeq code [call, NOP]
2380 -- function names that begin with '.' are assumed to be special
2381 -- internally generated names like '.mul,' which don't get an
2382 -- underscore prefix
2383 -- ToDo:needed (WDP 96/03) ???
2384 fn__2 = case (_HEAD_ fn) of
2385 '.' -> ImmLit (ptext fn)
2386 _ -> ImmLab (ptext fn)
2388 ------------------------------------
2389 {- Try to get a value into a specific register (or registers) for
2390 a call. The SPARC calling convention is an absolute
2391 nightmare. The first 6x32 bits of arguments are mapped into
2392 %o0 through %o5, and the remaining arguments are dumped to the
2393 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2394 first argument is a pair of the list of remaining argument
2395 registers to be assigned for this call and the next stack
2396 offset to use for overflowing arguments. This way,
2397 @get_arg@ can be applied to all of a call's arguments using
2401 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2402 -> StixTree -- Current argument
2403 -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2405 -- We have to use up all of our argument registers first...
2407 get_arg (dst:dsts, offset) arg
2408 = getRegister arg `thenUs` \ register ->
2409 getNewRegNCG (registerRep register)
2412 reg = if isFloatingRep pk then tmp else dst
2413 code = registerCode register reg
2414 src = registerName register reg
2415 pk = registerRep register
2417 returnUs (case pk of
2420 [] -> (([], offset + 1), code . mkSeqInstrs [
2421 -- conveniently put the second part in the right stack
2422 -- location, and load the first part into %o5
2423 ST DF src (spRel (offset - 1)),
2424 LD W (spRel (offset - 1)) dst])
2425 (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2426 ST DF src (spRel (-2)),
2427 LD W (spRel (-2)) dst,
2428 LD W (spRel (-1)) dst__2])
2429 FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2430 ST F src (spRel (-2)),
2431 LD W (spRel (-2)) dst])
2432 _ -> ((dsts, offset), if isFixed register then
2433 code . mkSeqInstr (OR False g0 (RIReg src) dst)
2436 -- Once we have run out of argument registers, we move to the
2439 get_arg ([], offset) arg
2440 = getRegister arg `thenUs` \ register ->
2441 getNewRegNCG (registerRep register)
2444 code = registerCode register tmp
2445 src = registerName register tmp
2446 pk = registerRep register
2447 sz = primRepToSize pk
2448 words = if pk == DoubleRep then 2 else 1
2450 returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2452 #endif {- sparc_TARGET_ARCH -}
2455 %************************************************************************
2457 \subsection{Support bits}
2459 %************************************************************************
2461 %************************************************************************
2463 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2465 %************************************************************************
2467 Turn those condition codes into integers now (when they appear on
2468 the right hand side of an assignment).
2470 (If applicable) Do not fill the delay slots here; you will confuse the
2474 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2476 #if alpha_TARGET_ARCH
2477 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2478 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2479 #endif {- alpha_TARGET_ARCH -}
2481 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2482 #if i386_TARGET_ARCH
2485 = condIntCode cond x y `thenUs` \ condition ->
2486 getNewRegNCG IntRep `thenUs` \ tmp ->
2487 --getRegister dst `thenUs` \ register ->
2489 --code2 = registerCode register tmp asmVoid
2490 --dst__2 = registerName register tmp
2491 code = condCode condition
2492 cond = condName condition
2493 -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2494 code__2 dst = code . mkSeqInstrs [
2495 SETCC cond (OpReg tmp),
2496 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2497 MOV L (OpReg tmp) (OpReg dst)]
2499 returnUs (Any IntRep code__2)
2502 = getUniqLabelNCG `thenUs` \ lbl1 ->
2503 getUniqLabelNCG `thenUs` \ lbl2 ->
2504 condFltCode cond x y `thenUs` \ condition ->
2506 code = condCode condition
2507 cond = condName condition
2508 code__2 dst = code . mkSeqInstrs [
2510 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2513 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2516 returnUs (Any IntRep code__2)
2518 #endif {- i386_TARGET_ARCH -}
2519 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2520 #if sparc_TARGET_ARCH
2522 condIntReg EQQ x (StInt 0)
2523 = getRegister x `thenUs` \ register ->
2524 getNewRegNCG IntRep `thenUs` \ tmp ->
2526 code = registerCode register tmp
2527 src = registerName register tmp
2528 code__2 dst = code . mkSeqInstrs [
2529 SUB False True g0 (RIReg src) g0,
2530 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2532 returnUs (Any IntRep code__2)
2535 = getRegister x `thenUs` \ register1 ->
2536 getRegister y `thenUs` \ register2 ->
2537 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2538 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2540 code1 = registerCode register1 tmp1 asmVoid
2541 src1 = registerName register1 tmp1
2542 code2 = registerCode register2 tmp2 asmVoid
2543 src2 = registerName register2 tmp2
2544 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2545 XOR False src1 (RIReg src2) dst,
2546 SUB False True g0 (RIReg dst) g0,
2547 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2549 returnUs (Any IntRep code__2)
2551 condIntReg NE x (StInt 0)
2552 = getRegister x `thenUs` \ register ->
2553 getNewRegNCG IntRep `thenUs` \ tmp ->
2555 code = registerCode register tmp
2556 src = registerName register tmp
2557 code__2 dst = code . mkSeqInstrs [
2558 SUB False True g0 (RIReg src) g0,
2559 ADD True False g0 (RIImm (ImmInt 0)) dst]
2561 returnUs (Any IntRep code__2)
2564 = getRegister x `thenUs` \ register1 ->
2565 getRegister y `thenUs` \ register2 ->
2566 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2567 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2569 code1 = registerCode register1 tmp1 asmVoid
2570 src1 = registerName register1 tmp1
2571 code2 = registerCode register2 tmp2 asmVoid
2572 src2 = registerName register2 tmp2
2573 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2574 XOR False src1 (RIReg src2) dst,
2575 SUB False True g0 (RIReg dst) g0,
2576 ADD True False g0 (RIImm (ImmInt 0)) dst]
2578 returnUs (Any IntRep code__2)
2581 = getUniqLabelNCG `thenUs` \ lbl1 ->
2582 getUniqLabelNCG `thenUs` \ lbl2 ->
2583 condIntCode cond x y `thenUs` \ condition ->
2585 code = condCode condition
2586 cond = condName condition
2587 code__2 dst = code . mkSeqInstrs [
2588 BI cond False (ImmCLbl lbl1), NOP,
2589 OR False g0 (RIImm (ImmInt 0)) dst,
2590 BI ALWAYS False (ImmCLbl lbl2), NOP,
2592 OR False g0 (RIImm (ImmInt 1)) dst,
2595 returnUs (Any IntRep code__2)
2598 = getUniqLabelNCG `thenUs` \ lbl1 ->
2599 getUniqLabelNCG `thenUs` \ lbl2 ->
2600 condFltCode cond x y `thenUs` \ condition ->
2602 code = condCode condition
2603 cond = condName condition
2604 code__2 dst = code . mkSeqInstrs [
2606 BF cond False (ImmCLbl lbl1), NOP,
2607 OR False g0 (RIImm (ImmInt 0)) dst,
2608 BI ALWAYS False (ImmCLbl lbl2), NOP,
2610 OR False g0 (RIImm (ImmInt 1)) dst,
2613 returnUs (Any IntRep code__2)
2615 #endif {- sparc_TARGET_ARCH -}
2618 %************************************************************************
2620 \subsubsection{@trivial*Code@: deal with trivial instructions}
2622 %************************************************************************
2624 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2625 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2626 for constants on the right hand side, because that's where the generic
2627 optimizer will have put them.
2629 Similarly, for unary instructions, we don't have to worry about
2630 matching an StInt as the argument, because genericOpt will already
2631 have handled the constant-folding.
2635 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2636 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2637 -> Maybe (Operand -> Operand -> Instr)
2638 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2640 -> StixTree -> StixTree -- the two arguments
2645 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2646 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2647 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2649 -> StixTree -> StixTree -- the two arguments
2653 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2654 ,IF_ARCH_i386 ((Operand -> Instr)
2655 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2657 -> StixTree -- the one argument
2662 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2663 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2664 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2666 -> StixTree -- the one argument
2669 #if alpha_TARGET_ARCH
2671 trivialCode instr x (StInt y)
2673 = getRegister x `thenUs` \ register ->
2674 getNewRegNCG IntRep `thenUs` \ tmp ->
2676 code = registerCode register tmp
2677 src1 = registerName register tmp
2678 src2 = ImmInt (fromInteger y)
2679 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2681 returnUs (Any IntRep code__2)
2683 trivialCode instr x y
2684 = getRegister x `thenUs` \ register1 ->
2685 getRegister y `thenUs` \ register2 ->
2686 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2687 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2689 code1 = registerCode register1 tmp1 asmVoid
2690 src1 = registerName register1 tmp1
2691 code2 = registerCode register2 tmp2 asmVoid
2692 src2 = registerName register2 tmp2
2693 code__2 dst = asmParThen [code1, code2] .
2694 mkSeqInstr (instr src1 (RIReg src2) dst)
2696 returnUs (Any IntRep code__2)
2699 trivialUCode instr x
2700 = getRegister x `thenUs` \ register ->
2701 getNewRegNCG IntRep `thenUs` \ tmp ->
2703 code = registerCode register tmp
2704 src = registerName register tmp
2705 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2707 returnUs (Any IntRep code__2)
2710 trivialFCode _ instr x y
2711 = getRegister x `thenUs` \ register1 ->
2712 getRegister y `thenUs` \ register2 ->
2713 getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
2714 getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
2716 code1 = registerCode register1 tmp1
2717 src1 = registerName register1 tmp1
2719 code2 = registerCode register2 tmp2
2720 src2 = registerName register2 tmp2
2722 code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2723 mkSeqInstr (instr src1 src2 dst)
2725 returnUs (Any DoubleRep code__2)
2727 trivialUFCode _ instr x
2728 = getRegister x `thenUs` \ register ->
2729 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2731 code = registerCode register tmp
2732 src = registerName register tmp
2733 code__2 dst = code . mkSeqInstr (instr src dst)
2735 returnUs (Any DoubleRep code__2)
2737 #endif {- alpha_TARGET_ARCH -}
2738 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2739 #if i386_TARGET_ARCH
2741 The Rules of the Game are:
2743 * You cannot assume anything about the destination register dst;
2744 it may be anything, includind a fixed reg.
2746 * You may compute a value into a fixed reg, but you may not
2747 subsequently change the contents of that fixed reg. If you
2748 want to do so, first copy the value either to a temporary
2749 or into dst. You are free to modify dst even if it happens
2750 to be a fixed reg -- that's not your problem.
2752 * You cannot assume that a fixed reg will stay live over an
2753 arbitrary computation. The same applies to the dst reg.
2755 * Temporary regs obtained from getNewRegNCG are distinct from
2756 all other regs, and stay live over arbitrary computations.
2763 trivialCode instr maybe_revinstr a b
2766 = getRegister a `thenUs` \ rega ->
2769 then registerCode rega dst `bind` \ code_a ->
2771 mkSeqInstr (instr (OpImm imm_b) (OpReg dst))
2772 else registerCodeF rega `bind` \ code_a ->
2773 registerNameF rega `bind` \ r_a ->
2775 mkSeqInstr (MOV L (OpReg r_a) (OpReg dst)) .
2776 mkSeqInstr (instr (OpImm imm_b) (OpReg dst))
2778 returnUs (Any IntRep mkcode)
2781 = getRegister b `thenUs` \ regb ->
2782 getNewRegNCG IntRep `thenUs` \ tmp ->
2783 let revinstr_avail = maybeToBool maybe_revinstr
2784 revinstr = case maybe_revinstr of Just ri -> ri
2788 then registerCode regb dst `bind` \ code_b ->
2790 mkSeqInstr (revinstr (OpImm imm_a) (OpReg dst))
2791 else registerCodeF regb `bind` \ code_b ->
2792 registerNameF regb `bind` \ r_b ->
2794 mkSeqInstr (MOV L (OpReg r_b) (OpReg dst)) .
2795 mkSeqInstr (revinstr (OpImm imm_a) (OpReg dst))
2799 then registerCode regb tmp `bind` \ code_b ->
2801 mkSeqInstr (MOV L (OpImm imm_a) (OpReg dst)) .
2802 mkSeqInstr (instr (OpReg tmp) (OpReg dst))
2803 else registerCodeF regb `bind` \ code_b ->
2804 registerNameF regb `bind` \ r_b ->
2806 mkSeqInstr (MOV L (OpReg r_b) (OpReg tmp)) .
2807 mkSeqInstr (MOV L (OpImm imm_a) (OpReg dst)) .
2808 mkSeqInstr (instr (OpReg tmp) (OpReg dst))
2810 returnUs (Any IntRep mkcode)
2813 = getRegister a `thenUs` \ rega ->
2814 getRegister b `thenUs` \ regb ->
2815 getNewRegNCG IntRep `thenUs` \ tmp ->
2817 = case (isFloat rega, isFloat regb) of
2819 -> registerCode regb tmp `bind` \ code_b ->
2820 registerCode rega dst `bind` \ code_a ->
2823 mkSeqInstr (instr (OpReg tmp) (OpReg dst))
2825 -> registerCode rega tmp `bind` \ code_a ->
2826 registerCodeF regb `bind` \ code_b ->
2827 registerNameF regb `bind` \ r_b ->
2830 mkSeqInstr (instr (OpReg r_b) (OpReg tmp)) .
2831 mkSeqInstr (MOV L (OpReg tmp) (OpReg dst))
2833 -> registerCode regb tmp `bind` \ code_b ->
2834 registerCodeF rega `bind` \ code_a ->
2835 registerNameF rega `bind` \ r_a ->
2838 mkSeqInstr (MOV L (OpReg r_a) (OpReg dst)) .
2839 mkSeqInstr (instr (OpReg tmp) (OpReg dst))
2841 -> registerCodeF rega `bind` \ code_a ->
2842 registerNameF rega `bind` \ r_a ->
2843 registerCodeF regb `bind` \ code_b ->
2844 registerNameF regb `bind` \ r_b ->
2846 mkSeqInstr (MOV L (OpReg r_a) (OpReg tmp)) .
2848 mkSeqInstr (instr (OpReg r_b) (OpReg tmp)) .
2849 mkSeqInstr (MOV L (OpReg tmp) (OpReg dst))
2851 returnUs (Any IntRep mkcode)
2854 maybe_imm_a = maybeImm a
2855 is_imm_a = maybeToBool maybe_imm_a
2856 imm_a = case maybe_imm_a of Just imm -> imm
2858 maybe_imm_b = maybeImm b
2859 is_imm_b = maybeToBool maybe_imm_b
2860 imm_b = case maybe_imm_b of Just imm -> imm
2864 trivialUCode instr x
2865 = getRegister x `thenUs` \ register ->
2867 code__2 dst = let code = registerCode register dst
2868 src = registerName register dst
2870 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 instr x y
2879 = getRegister x `thenUs` \ register1 ->
2880 getRegister y `thenUs` \ register2 ->
2881 getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
2882 getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
2884 code1 = registerCode register1 tmp1
2885 src1 = registerName register1 tmp1
2887 code2 = registerCode register2 tmp2
2888 src2 = registerName register2 tmp2
2890 code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2891 mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
2893 returnUs (Any DoubleRep code__2)
2897 trivialUFCode pk instr x
2898 = getRegister x `thenUs` \ register ->
2899 getNewRegNCG pk `thenUs` \ tmp ->
2901 code = registerCode register tmp
2902 src = registerName register tmp
2903 code__2 dst = code . mkSeqInstr (instr src dst)
2905 returnUs (Any pk code__2)
2907 #endif {- i386_TARGET_ARCH -}
2908 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2909 #if sparc_TARGET_ARCH
2911 trivialCode instr x (StInt y)
2913 = getRegister x `thenUs` \ register ->
2914 getNewRegNCG IntRep `thenUs` \ tmp ->
2916 code = registerCode register tmp
2917 src1 = registerName register tmp
2918 src2 = ImmInt (fromInteger y)
2919 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2921 returnUs (Any IntRep code__2)
2923 trivialCode instr x y
2924 = getRegister x `thenUs` \ register1 ->
2925 getRegister y `thenUs` \ register2 ->
2926 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2927 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2929 code1 = registerCode register1 tmp1 asmVoid
2930 src1 = registerName register1 tmp1
2931 code2 = registerCode register2 tmp2 asmVoid
2932 src2 = registerName register2 tmp2
2933 code__2 dst = asmParThen [code1, code2] .
2934 mkSeqInstr (instr src1 (RIReg src2) dst)
2936 returnUs (Any IntRep code__2)
2939 trivialFCode pk instr x y
2940 = getRegister x `thenUs` \ register1 ->
2941 getRegister y `thenUs` \ register2 ->
2942 getNewRegNCG (registerRep register1)
2944 getNewRegNCG (registerRep register2)
2946 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2948 promote x = asmInstr (FxTOy F DF x tmp)
2950 pk1 = registerRep register1
2951 code1 = registerCode register1 tmp1
2952 src1 = registerName register1 tmp1
2954 pk2 = registerRep register2
2955 code2 = registerCode register2 tmp2
2956 src2 = registerName register2 tmp2
2960 asmParThen [code1 asmVoid, code2 asmVoid] .
2961 mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
2962 else if pk1 == FloatRep then
2963 asmParThen [code1 (promote src1), code2 asmVoid] .
2964 mkSeqInstr (instr DF tmp src2 dst)
2966 asmParThen [code1 asmVoid, code2 (promote src2)] .
2967 mkSeqInstr (instr DF src1 tmp dst)
2969 returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
2972 trivialUCode instr x
2973 = getRegister x `thenUs` \ register ->
2974 getNewRegNCG IntRep `thenUs` \ tmp ->
2976 code = registerCode register tmp
2977 src = registerName register tmp
2978 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2980 returnUs (Any IntRep code__2)
2983 trivialUFCode pk instr x
2984 = getRegister x `thenUs` \ register ->
2985 getNewRegNCG pk `thenUs` \ tmp ->
2987 code = registerCode register tmp
2988 src = registerName register tmp
2989 code__2 dst = code . mkSeqInstr (instr src dst)
2991 returnUs (Any pk code__2)
2993 #endif {- sparc_TARGET_ARCH -}
2996 %************************************************************************
2998 \subsubsection{Coercing to/from integer/floating-point...}
3000 %************************************************************************
3002 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3003 to be generated. Here we just change the type on the Register passed
3004 on up. The code is machine-independent.
3006 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3007 conversions. We have to store temporaries in memory to move
3008 between the integer and the floating point register sets.
3011 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
3012 coerceFltCode :: StixTree -> UniqSM Register
3014 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
3015 coerceFP2Int :: StixTree -> UniqSM Register
3018 = getRegister x `thenUs` \ register ->
3021 Fixed _ reg code -> Fixed pk reg code
3022 Any _ code -> Any pk code
3027 = getRegister x `thenUs` \ register ->
3030 Fixed _ reg code -> Fixed DoubleRep reg code
3031 Any _ code -> Any DoubleRep code
3036 #if alpha_TARGET_ARCH
3039 = getRegister x `thenUs` \ register ->
3040 getNewRegNCG IntRep `thenUs` \ reg ->
3042 code = registerCode register reg
3043 src = registerName register reg
3045 code__2 dst = code . mkSeqInstrs [
3047 LD TF dst (spRel 0),
3050 returnUs (Any DoubleRep code__2)
3054 = getRegister x `thenUs` \ register ->
3055 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3057 code = registerCode register tmp
3058 src = registerName register tmp
3060 code__2 dst = code . mkSeqInstrs [
3062 ST TF tmp (spRel 0),
3065 returnUs (Any IntRep code__2)
3067 #endif {- alpha_TARGET_ARCH -}
3068 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3069 #if i386_TARGET_ARCH
3072 = getRegister x `thenUs` \ register ->
3073 getNewRegNCG IntRep `thenUs` \ reg ->
3075 code = registerCode register reg
3076 src = registerName register reg
3077 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3078 code__2 dst = code .
3079 mkSeqInstr (opc src dst)
3081 returnUs (Any pk code__2)
3085 = getRegister x `thenUs` \ register ->
3086 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3088 code = registerCode register tmp
3089 src = registerName register tmp
3090 pk = registerRep register
3092 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3093 code__2 dst = code .
3094 mkSeqInstr (opc src dst)
3096 returnUs (Any IntRep code__2)
3098 #endif {- i386_TARGET_ARCH -}
3099 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3100 #if sparc_TARGET_ARCH
3103 = getRegister x `thenUs` \ register ->
3104 getNewRegNCG IntRep `thenUs` \ reg ->
3106 code = registerCode register reg
3107 src = registerName register reg
3109 code__2 dst = code . mkSeqInstrs [
3110 ST W src (spRel (-2)),
3111 LD W (spRel (-2)) dst,
3112 FxTOy W (primRepToSize pk) dst dst]
3114 returnUs (Any pk code__2)
3118 = getRegister x `thenUs` \ register ->
3119 getNewRegNCG IntRep `thenUs` \ reg ->
3120 getNewRegNCG FloatRep `thenUs` \ tmp ->
3122 code = registerCode register reg
3123 src = registerName register reg
3124 pk = registerRep register
3126 code__2 dst = code . mkSeqInstrs [
3127 FxTOy (primRepToSize pk) W src tmp,
3128 ST W tmp (spRel (-2)),
3129 LD W (spRel (-2)) dst]
3131 returnUs (Any IntRep code__2)
3133 #endif {- sparc_TARGET_ARCH -}
3136 %************************************************************************
3138 \subsubsection{Coercing integer to @Char@...}
3140 %************************************************************************
3142 Integer to character conversion. Where applicable, we try to do this
3143 in one step if the original object is in memory.
3146 chrCode :: StixTree -> UniqSM Register
3148 #if alpha_TARGET_ARCH
3151 = getRegister x `thenUs` \ register ->
3152 getNewRegNCG IntRep `thenUs` \ reg ->
3154 code = registerCode register reg
3155 src = registerName register reg
3156 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3158 returnUs (Any IntRep code__2)
3160 #endif {- alpha_TARGET_ARCH -}
3161 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3162 #if i386_TARGET_ARCH
3165 = getRegister x `thenUs` \ register ->
3168 code = registerCode register dst
3169 src = registerName register dst
3171 if isFixed register && src /= dst
3172 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3173 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3174 else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3176 returnUs (Any IntRep code__2)
3178 #endif {- i386_TARGET_ARCH -}
3179 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3180 #if sparc_TARGET_ARCH
3182 chrCode (StInd pk mem)
3183 = getAmode mem `thenUs` \ amode ->
3185 code = amodeCode amode
3186 src = amodeAddr amode
3187 src_off = addrOffset src 3
3188 src__2 = case src_off of Just x -> x
3189 code__2 dst = if maybeToBool src_off then
3190 code . mkSeqInstr (LD BU src__2 dst)
3192 code . mkSeqInstrs [
3193 LD (primRepToSize pk) src dst,
3194 AND False dst (RIImm (ImmInt 255)) dst]
3196 returnUs (Any pk code__2)
3199 = getRegister x `thenUs` \ register ->
3200 getNewRegNCG IntRep `thenUs` \ reg ->
3202 code = registerCode register reg
3203 src = registerName register reg
3204 code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3206 returnUs (Any IntRep code__2)
3208 #endif {- sparc_TARGET_ARCH -}