2 % (c) The AQUA Project, Glasgow University, 1993-1995
6 #include "HsVersions.h"
7 #include "../includes/i386-unknown-linuxaout.h"
12 -- and, for self-sufficiency
13 PprStyle, StixTree, CSeq
18 import AbsCSyn ( AbstractC, MagicId(..), kindFromMagicId )
19 import PrelInfo ( PrimOp(..)
20 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
21 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
23 import AsmRegAlloc ( runRegAllocate, mkReg, extractMappedRegNos,
24 Reg(..), RegLiveness(..), RegUsage(..),
25 FutureLive(..), MachineRegisters(..), MachineCode(..)
27 import CLabel ( CLabel, isAsmTemp )
28 import I386Code {- everything -}
30 import Maybes ( maybeToBool, Maybe(..) )
31 import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
40 type CodeBlock a = (OrdList a -> OrdList a)
43 %************************************************************************
45 \subsection[I386CodeGen]{Generating I386 Code}
47 %************************************************************************
49 This is the top-level code-generation function for the I386.
53 i386CodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
54 i386CodeGen sty trees =
55 mapUs genI386Code trees `thenUs` \ dynamicCodes ->
57 staticCodes = scheduleI386Code dynamicCodes
58 pretty = printLabeledCodes sty staticCodes
64 This bit does the code scheduling. The scheduler must also deal with
65 register allocation of temporaries. Much parallelism can be exposed via
66 the OrdList, but more might occur, so further analysis might be needed.
70 scheduleI386Code :: [I386Code] -> [I386Instr]
71 scheduleI386Code = concat . map (runRegAllocate freeI386Regs reservedRegs)
73 freeI386Regs :: I386Regs
74 freeI386Regs = mkMRegs (extractMappedRegNos freeRegs)
79 Registers passed up the tree. If the stix code forces the register
80 to live in a pre-decided machine register, it comes out as @Fixed@;
81 otherwise, it comes out as @Any@, and the parent can decide which
82 register to put it in.
87 = Fixed Reg PrimRep (CodeBlock I386Instr)
88 | Any PrimRep (Reg -> (CodeBlock I386Instr))
90 registerCode :: Register -> Reg -> CodeBlock I386Instr
91 registerCode (Fixed _ _ code) reg = code
92 registerCode (Any _ code) reg = code reg
94 registerName :: Register -> Reg -> Reg
95 registerName (Fixed reg _ _) _ = reg
96 registerName (Any _ _) reg = reg
98 registerKind :: Register -> PrimRep
99 registerKind (Fixed _ pk _) = pk
100 registerKind (Any pk _) = pk
102 isFixed :: Register -> Bool
103 isFixed (Fixed _ _ _) = True
104 isFixed (Any _ _) = False
108 Memory addressing modes passed up the tree.
112 data Amode = Amode Addr (CodeBlock I386Instr)
114 amodeAddr (Amode addr _) = addr
115 amodeCode (Amode _ code) = code
119 Condition codes passed up the tree.
123 data Condition = Condition Bool Cond (CodeBlock I386Instr)
125 condName (Condition _ cond _) = cond
126 condFloat (Condition float _ _) = float
127 condCode (Condition _ _ code) = code
131 General things for putting together code sequences.
135 asmVoid :: OrdList I386Instr
136 asmVoid = mkEmptyList
138 asmInstr :: I386Instr -> I386Code
139 asmInstr i = mkUnitList i
141 asmSeq :: [I386Instr] -> I386Code
142 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
144 asmParThen :: [I386Code] -> (CodeBlock I386Instr)
145 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
147 returnInstr :: I386Instr -> UniqSM (CodeBlock I386Instr)
148 returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
150 returnInstrs :: [I386Instr] -> UniqSM (CodeBlock I386Instr)
151 returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
153 returnSeq :: (CodeBlock I386Instr) -> [I386Instr] -> UniqSM (CodeBlock I386Instr)
154 returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
156 mkSeqInstr :: I386Instr -> (CodeBlock I386Instr)
157 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
159 mkSeqInstrs :: [I386Instr] -> (CodeBlock I386Instr)
160 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
164 Top level i386 code generator for a chunk of stix code.
168 genI386Code :: [StixTree] -> UniqSM (I386Code)
171 mapUs getCode trees `thenUs` \ blocks ->
172 returnUs (foldr (.) id blocks asmVoid)
176 Code extractor for an entire stix tree---stix statement level.
181 :: StixTree -- a stix statement
182 -> UniqSM (CodeBlock I386Instr)
184 getCode (StSegment seg) = returnInstr (SEGMENT seg)
186 getCode (StAssign pk dst src)
187 | isFloatingRep pk = assignFltCode pk dst src
188 | otherwise = assignIntCode pk dst src
190 getCode (StLabel lab) = returnInstr (LABEL lab)
192 getCode (StFunBegin lab) = returnInstr (LABEL lab)
194 getCode (StFunEnd lab) = returnUs id
196 getCode (StJump arg) = genJump arg
198 getCode (StFallThrough lbl) = returnUs id
200 getCode (StCondJump lbl arg) = genCondJump lbl arg
202 getCode (StData kind args) =
203 mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
204 returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
205 (foldr1 (.) codes xs))
207 getData :: StixTree -> UniqSM (CodeBlock I386Instr, Imm)
208 getData (StInt i) = returnUs (id, ImmInteger i)
209 getData (StDouble d) = returnUs (id, strImmLit ('0' : 'd' : ppShow 80 (ppRational d)))
210 getData (StLitLbl s) = returnUs (id, ImmLit (uppBeside (uppChar '_') s))
211 getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
212 getData (StString s) =
213 getUniqLabelNCG `thenUs` \ lbl ->
214 returnUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
215 getData (StCLbl l) = returnUs (id, ImmCLbl l)
217 getCode (StCall fn VoidRep args) = genCCall fn VoidRep args
219 getCode (StComment s) = returnInstr (COMMENT s)
223 Generate code to get a subtree into a register.
227 getReg :: StixTree -> UniqSM Register
229 getReg (StReg (StixMagicId stgreg)) =
230 case stgRegMap stgreg of
231 Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id)
234 getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id)
236 getReg (StDouble 0.0)
238 code dst = mkSeqInstrs [FLDZ]
240 returnUs (Any DoubleRep code)
242 getReg (StDouble 1.0)
244 code dst = mkSeqInstrs [FLD1]
246 returnUs (Any DoubleRep code)
248 getReg (StDouble d) =
249 getUniqLabelNCG `thenUs` \ lbl ->
250 --getNewRegNCG PtrRep `thenUs` \ tmp ->
251 let code dst = mkSeqInstrs [
254 DATA D [strImmLit ('0' : 'd' :ppShow 80 (ppRational d))],
256 FLD D (OpImm (ImmCLbl lbl))
259 returnUs (Any DoubleRep code)
261 getReg (StString s) =
262 getUniqLabelNCG `thenUs` \ lbl ->
263 let code dst = mkSeqInstrs [
266 ASCII True (_UNPK_ s),
268 MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)]
270 returnUs (Any PtrRep code)
272 getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
273 getUniqLabelNCG `thenUs` \ lbl ->
274 let code dst = mkSeqInstrs [
277 ASCII False (init xs),
279 MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)]
281 returnUs (Any PtrRep code)
283 xs = _UNPK_ (_TAIL_ s)
286 getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
288 getReg (StCall fn kind args) =
289 genCCall fn kind args `thenUs` \ call ->
290 returnUs (Fixed reg kind call)
292 reg = if isFloatingRep kind then st0 else eax
294 getReg (StPrim primop args) =
297 CharGtOp -> condIntReg GT args
298 CharGeOp -> condIntReg GE args
299 CharEqOp -> condIntReg EQ args
300 CharNeOp -> condIntReg NE args
301 CharLtOp -> condIntReg LT args
302 CharLeOp -> condIntReg LE args
304 IntAddOp -> -- this should be optimised by the generic Opts,
305 -- I don't know why it is not (sometimes)!
307 [x, StInt 0] -> getReg x
310 IntSubOp -> subCode L args
311 IntMulOp -> trivialCode (IMUL L) args True
312 IntQuotOp -> divCode L args True -- division
313 IntRemOp -> divCode L args False -- remainder
314 IntNegOp -> trivialUCode (NEGI L) args
315 IntAbsOp -> absIntCode args
317 AndOp -> trivialCode (AND L) args True
318 OrOp -> trivialCode (OR L) args True
319 NotOp -> trivialUCode (NOT L) args
320 SllOp -> trivialCode (SHL L) args False
321 SraOp -> trivialCode (SAR L) args False
322 SrlOp -> trivialCode (SHR L) args False
323 ISllOp -> panic "I386Gen:isll"
324 ISraOp -> panic "I386Gen:isra"
325 ISrlOp -> panic "I386Gen:isrl"
327 IntGtOp -> condIntReg GT args
328 IntGeOp -> condIntReg GE args
329 IntEqOp -> condIntReg EQ args
330 IntNeOp -> condIntReg NE args
331 IntLtOp -> condIntReg LT args
332 IntLeOp -> condIntReg LE args
334 WordGtOp -> condIntReg GU args
335 WordGeOp -> condIntReg GEU args
336 WordEqOp -> condIntReg EQ args
337 WordNeOp -> condIntReg NE args
338 WordLtOp -> condIntReg LU args
339 WordLeOp -> condIntReg LEU args
341 AddrGtOp -> condIntReg GU args
342 AddrGeOp -> condIntReg GEU args
343 AddrEqOp -> condIntReg EQ args
344 AddrNeOp -> condIntReg NE args
345 AddrLtOp -> condIntReg LU args
346 AddrLeOp -> condIntReg LEU args
348 FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP args
349 FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP args
350 FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP args
351 FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP args
352 FloatNegOp -> trivialUFCode FloatRep FCHS args
354 FloatGtOp -> condFltReg GT args
355 FloatGeOp -> condFltReg GE args
356 FloatEqOp -> condFltReg EQ args
357 FloatNeOp -> condFltReg NE args
358 FloatLtOp -> condFltReg LT args
359 FloatLeOp -> condFltReg LE args
361 FloatExpOp -> promoteAndCall SLIT("exp") DoubleRep
362 FloatLogOp -> promoteAndCall SLIT("log") DoubleRep
363 FloatSqrtOp -> trivialUFCode FloatRep FSQRT args
365 FloatSinOp -> promoteAndCall SLIT("sin") DoubleRep
366 --trivialUFCode FloatRep FSIN args
367 FloatCosOp -> promoteAndCall SLIT("cos") DoubleRep
368 --trivialUFCode FloatRep FCOS args
369 FloatTanOp -> promoteAndCall SLIT("tan") DoubleRep
371 FloatAsinOp -> promoteAndCall SLIT("asin") DoubleRep
372 FloatAcosOp -> promoteAndCall SLIT("acos") DoubleRep
373 FloatAtanOp -> promoteAndCall SLIT("atan") DoubleRep
375 FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleRep
376 FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleRep
377 FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleRep
379 FloatPowerOp -> promoteAndCall SLIT("pow") DoubleRep
381 DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP args
382 DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP args
383 DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP args
384 DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP args
385 DoubleNegOp -> trivialUFCode DoubleRep FCHS args
387 DoubleGtOp -> condFltReg GT args
388 DoubleGeOp -> condFltReg GE args
389 DoubleEqOp -> condFltReg EQ args
390 DoubleNeOp -> condFltReg NE args
391 DoubleLtOp -> condFltReg LT args
392 DoubleLeOp -> condFltReg LE args
394 DoubleExpOp -> call SLIT("exp") DoubleRep
395 DoubleLogOp -> call SLIT("log") DoubleRep
396 DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT args
398 DoubleSinOp -> call SLIT("sin") DoubleRep
399 --trivialUFCode DoubleRep FSIN args
400 DoubleCosOp -> call SLIT("cos") DoubleRep
401 --trivialUFCode DoubleRep FCOS args
402 DoubleTanOp -> call SLIT("tan") DoubleRep
404 DoubleAsinOp -> call SLIT("asin") DoubleRep
405 DoubleAcosOp -> call SLIT("acos") DoubleRep
406 DoubleAtanOp -> call SLIT("atan") DoubleRep
408 DoubleSinhOp -> call SLIT("sinh") DoubleRep
409 DoubleCoshOp -> call SLIT("cosh") DoubleRep
410 DoubleTanhOp -> call SLIT("tanh") DoubleRep
412 DoublePowerOp -> call SLIT("pow") DoubleRep
414 OrdOp -> coerceIntCode IntRep args
415 ChrOp -> chrCode args
417 Float2IntOp -> coerceFP2Int args
418 Int2FloatOp -> coerceInt2FP FloatRep args
419 Double2IntOp -> coerceFP2Int args
420 Int2DoubleOp -> coerceInt2FP DoubleRep args
422 Double2FloatOp -> coerceFltCode args
423 Float2DoubleOp -> coerceFltCode args
426 call fn pk = getReg (StCall fn pk args)
427 promoteAndCall fn pk = getReg (StCall fn pk (map promote args))
429 promote x = StPrim Float2DoubleOp [x]
431 getReg (StInd pk mem) =
432 getAmode mem `thenUs` \ amode ->
434 code = amodeCode amode
435 src = amodeAddr amode
438 if pk == DoubleRep || pk == FloatRep
439 then mkSeqInstr (FLD {-D-} size (OpAddr src))
440 else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
442 returnUs (Any pk code__2)
447 src = ImmInt (fromInteger i)
448 code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
450 returnUs (Any IntRep code)
455 code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
457 returnUs (Any PtrRep code)
460 imm__2 = case imm of Just x -> x
464 Now, given a tree (the argument to an StInd) that references memory,
465 produce a suitable addressing mode.
469 getAmode :: StixTree -> UniqSM Amode
471 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
473 getAmode (StPrim IntSubOp [x, StInt i])
475 getNewRegNCG PtrRep `thenUs` \ tmp ->
476 getReg x `thenUs` \ register ->
478 code = registerCode register tmp
479 reg = registerName register tmp
480 off = ImmInt (-(fromInteger i))
482 returnUs (Amode (Addr (Just reg) Nothing off) code)
484 getAmode (StPrim IntAddOp [x, StInt i])
487 code = mkSeqInstrs []
489 returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
492 imm__2 = case imm of Just x -> x
494 getAmode (StPrim IntAddOp [x, StInt i])
496 getNewRegNCG PtrRep `thenUs` \ tmp ->
497 getReg x `thenUs` \ register ->
499 code = registerCode register tmp
500 reg = registerName register tmp
501 off = ImmInt (fromInteger i)
503 returnUs (Amode (Addr (Just reg) Nothing off) code)
505 getAmode (StPrim IntAddOp [x, y]) =
506 getNewRegNCG PtrRep `thenUs` \ tmp1 ->
507 getNewRegNCG IntRep `thenUs` \ tmp2 ->
508 getReg x `thenUs` \ register1 ->
509 getReg y `thenUs` \ register2 ->
511 code1 = registerCode register1 tmp1 asmVoid
512 reg1 = registerName register1 tmp1
513 code2 = registerCode register2 tmp2 asmVoid
514 reg2 = registerName register2 tmp2
515 code__2 = asmParThen [code1, code2]
517 returnUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
521 let code = mkSeqInstrs []
523 returnUs (Amode (ImmAddr imm__2 0) code)
526 imm__2 = case imm of Just x -> x
529 getNewRegNCG PtrRep `thenUs` \ tmp ->
530 getReg other `thenUs` \ register ->
532 code = registerCode register tmp
533 reg = registerName register tmp
536 returnUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code)
543 -> UniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size
545 = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
548 = getAmode mem `thenUs` \ amode ->
550 code = amodeCode amode --asmVoid
551 addr = amodeAddr amode
553 in returnUs (code, OpAddr addr, sz)
556 = getReg op `thenUs` \ register ->
557 getNewRegNCG (registerKind register)
560 code = registerCode register tmp
561 reg = registerName register tmp
562 pk = registerKind register
565 returnUs (code, OpReg reg, sz)
569 -> UniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size
572 = returnUs (asmParThen [], OpImm imm_op, L)
575 imm_op = case imm of Just x -> x
578 = getReg op `thenUs` \ register ->
579 getNewRegNCG (registerKind register)
582 code = registerCode register tmp
583 reg = registerName register tmp
584 pk = registerKind register
587 returnUs (code, OpReg reg, sz)
591 Set up a condition code for a conditional branch.
595 getCondition :: StixTree -> UniqSM Condition
597 getCondition (StPrim primop args) =
600 CharGtOp -> condIntCode GT args
601 CharGeOp -> condIntCode GE args
602 CharEqOp -> condIntCode EQ args
603 CharNeOp -> condIntCode NE args
604 CharLtOp -> condIntCode LT args
605 CharLeOp -> condIntCode LE args
607 IntGtOp -> condIntCode GT args
608 IntGeOp -> condIntCode GE args
609 IntEqOp -> condIntCode EQ args
610 IntNeOp -> condIntCode NE args
611 IntLtOp -> condIntCode LT args
612 IntLeOp -> condIntCode LE args
614 WordGtOp -> condIntCode GU args
615 WordGeOp -> condIntCode GEU args
616 WordEqOp -> condIntCode EQ args
617 WordNeOp -> condIntCode NE args
618 WordLtOp -> condIntCode LU args
619 WordLeOp -> condIntCode LEU args
621 AddrGtOp -> condIntCode GU args
622 AddrGeOp -> condIntCode GEU args
623 AddrEqOp -> condIntCode EQ args
624 AddrNeOp -> condIntCode NE args
625 AddrLtOp -> condIntCode LU args
626 AddrLeOp -> condIntCode LEU args
628 FloatGtOp -> condFltCode GT args
629 FloatGeOp -> condFltCode GE args
630 FloatEqOp -> condFltCode EQ args
631 FloatNeOp -> condFltCode NE args
632 FloatLtOp -> condFltCode LT args
633 FloatLeOp -> condFltCode LE args
635 DoubleGtOp -> condFltCode GT args
636 DoubleGeOp -> condFltCode GE args
637 DoubleEqOp -> condFltCode EQ args
638 DoubleNeOp -> condFltCode NE args
639 DoubleLtOp -> condFltCode LT args
640 DoubleLeOp -> condFltCode LE args
644 Turn a boolean expression into a condition, to be passed
649 condIntCode, condFltCode :: Cond -> [StixTree] -> UniqSM Condition
650 condIntCode cond [StInd _ x, y]
652 = getAmode x `thenUs` \ amode ->
654 code1 = amodeCode amode asmVoid
655 y__2 = amodeAddr amode
656 code__2 = asmParThen [code1] .
657 mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
659 returnUs (Condition False cond code__2)
662 imm__2 = case imm of Just x -> x
664 condIntCode cond [x, StInt 0]
665 = getReg x `thenUs` \ register1 ->
666 getNewRegNCG IntRep `thenUs` \ tmp1 ->
668 code1 = registerCode register1 tmp1 asmVoid
669 src1 = registerName register1 tmp1
670 code__2 = asmParThen [code1] .
671 mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
673 returnUs (Condition False cond code__2)
675 condIntCode cond [x, y]
677 = getReg x `thenUs` \ register1 ->
678 getNewRegNCG IntRep `thenUs` \ tmp1 ->
680 code1 = registerCode register1 tmp1 asmVoid
681 src1 = registerName register1 tmp1
682 code__2 = asmParThen [code1] .
683 mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
685 returnUs (Condition False cond code__2)
688 imm__2 = case imm of Just x -> x
690 condIntCode cond [StInd _ x, y]
691 = getAmode x `thenUs` \ amode ->
692 getReg y `thenUs` \ register2 ->
693 getNewRegNCG IntRep `thenUs` \ tmp2 ->
695 code1 = amodeCode amode asmVoid
696 src1 = amodeAddr amode
697 code2 = registerCode register2 tmp2 asmVoid
698 src2 = registerName register2 tmp2
699 code__2 = asmParThen [code1, code2] .
700 mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
702 returnUs (Condition False cond code__2)
704 condIntCode cond [y, StInd _ x]
705 = getAmode x `thenUs` \ amode ->
706 getReg y `thenUs` \ register2 ->
707 getNewRegNCG IntRep `thenUs` \ tmp2 ->
709 code1 = amodeCode amode asmVoid
710 src1 = amodeAddr amode
711 code2 = registerCode register2 tmp2 asmVoid
712 src2 = registerName register2 tmp2
713 code__2 = asmParThen [code1, code2] .
714 mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
716 returnUs (Condition False cond code__2)
718 condIntCode cond [x, y] =
719 getReg x `thenUs` \ register1 ->
720 getReg y `thenUs` \ register2 ->
721 getNewRegNCG IntRep `thenUs` \ tmp1 ->
722 getNewRegNCG IntRep `thenUs` \ tmp2 ->
724 code1 = registerCode register1 tmp1 asmVoid
725 src1 = registerName register1 tmp1
726 code2 = registerCode register2 tmp2 asmVoid
727 src2 = registerName register2 tmp2
728 code__2 = asmParThen [code1, code2] .
729 mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
731 returnUs (Condition False cond code__2)
733 condFltCode cond [x, StDouble 0.0] =
734 getReg x `thenUs` \ register1 ->
735 getNewRegNCG (registerKind register1)
738 pk1 = registerKind register1
739 code1 = registerCode register1 tmp1
740 src1 = registerName register1 tmp1
742 code__2 = asmParThen [code1 asmVoid] .
743 mkSeqInstrs [FTST, FSTP D (OpReg st0), -- or FLDZ, FUCOMPP ?
745 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
746 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
750 returnUs (Condition True (fixFPCond cond) code__2)
752 condFltCode cond [x, y] =
753 getReg x `thenUs` \ register1 ->
754 getReg y `thenUs` \ register2 ->
755 getNewRegNCG (registerKind register1)
757 getNewRegNCG (registerKind register2)
760 pk1 = registerKind register1
761 code1 = registerCode register1 tmp1
762 src1 = registerName register1 tmp1
764 code2 = registerCode register2 tmp2
765 src2 = registerName register2 tmp2
767 code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
768 mkSeqInstrs [FUCOMPP,
770 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
771 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
775 returnUs (Condition True (fixFPCond cond) code__2)
779 Turn those condition codes into integers now (when they appear on
780 the right hand side of an assignment).
784 condIntReg :: Cond -> [StixTree] -> UniqSM Register
785 condIntReg cond args =
786 condIntCode cond args `thenUs` \ condition ->
787 getNewRegNCG IntRep `thenUs` \ tmp ->
788 --getReg dst `thenUs` \ register ->
790 --code2 = registerCode register tmp asmVoid
791 --dst__2 = registerName register tmp
792 code = condCode condition
793 cond = condName condition
794 -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
795 code__2 dst = code . mkSeqInstrs [
796 SETCC cond (OpReg tmp),
797 AND L (OpImm (ImmInt 1)) (OpReg tmp),
798 MOV L (OpReg tmp) (OpReg dst)]
800 returnUs (Any IntRep code__2)
802 condFltReg :: Cond -> [StixTree] -> UniqSM Register
804 condFltReg cond args =
805 getUniqLabelNCG `thenUs` \ lbl1 ->
806 getUniqLabelNCG `thenUs` \ lbl2 ->
807 condFltCode cond args `thenUs` \ condition ->
809 code = condCode condition
810 cond = condName condition
811 code__2 dst = code . mkSeqInstrs [
813 MOV L (OpImm (ImmInt 0)) (OpReg dst),
816 MOV L (OpImm (ImmInt 1)) (OpReg dst),
819 returnUs (Any IntRep code__2)
823 Assignments are really at the heart of the whole code generation business.
824 Almost all top-level nodes of any real importance are assignments, which
825 correspond to loads, stores, or register transfers. If we're really lucky,
826 some of the register transfers will go away, because we can use the destination
827 register to complete the code generation for the right hand side. This only
828 fails when the right hand side is forced into a fixed register (e.g. the result
833 assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock I386Instr)
834 assignIntCode pk (StInd _ dst) src
835 = getAmode dst `thenUs` \ amode ->
836 getOpRI src `thenUs` \ (codesrc, opsrc, sz) ->
838 code1 = amodeCode amode asmVoid
839 dst__2 = amodeAddr amode
840 code__2 = asmParThen [code1, codesrc asmVoid] .
841 mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
845 assignIntCode pk dst (StInd _ src) =
846 getNewRegNCG IntRep `thenUs` \ tmp ->
847 getAmode src `thenUs` \ amode ->
848 getReg dst `thenUs` \ register ->
850 code1 = amodeCode amode asmVoid
851 src__2 = amodeAddr amode
852 code2 = registerCode register tmp asmVoid
853 dst__2 = registerName register tmp
855 code__2 = asmParThen [code1, code2] .
856 mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
860 assignIntCode pk dst src =
861 getReg dst `thenUs` \ register1 ->
862 getReg src `thenUs` \ register2 ->
863 getNewRegNCG IntRep `thenUs` \ tmp ->
865 dst__2 = registerName register1 tmp
866 code = registerCode register2 dst__2
867 src__2 = registerName register2 dst__2
868 code__2 = if isFixed register2 && dst__2 /= src__2
869 then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
875 assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock I386Instr)
876 assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
877 = getNewRegNCG IntRep `thenUs` \ tmp ->
878 getAmode src `thenUs` \ amodesrc ->
879 getAmode dst `thenUs` \ amodedst ->
880 --getReg src `thenUs` \ register ->
882 codesrc1 = amodeCode amodesrc asmVoid
883 addrsrc1 = amodeAddr amodesrc
884 codedst1 = amodeCode amodedst asmVoid
885 addrdst1 = amodeAddr amodedst
886 addrsrc2 = case (offset addrsrc1 4) of Just x -> x
887 addrdst2 = case (offset addrdst1 4) of Just x -> x
889 code__2 = asmParThen [codesrc1, codedst1] .
890 mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
891 MOV L (OpReg tmp) (OpAddr addrdst1)]
894 then [MOV L (OpAddr addrsrc2) (OpReg tmp),
895 MOV L (OpReg tmp) (OpAddr addrdst2)]
900 assignFltCode pk (StInd _ dst) src =
901 --getNewRegNCG pk `thenUs` \ tmp ->
902 getAmode dst `thenUs` \ amode ->
903 getReg src `thenUs` \ register ->
906 dst__2 = amodeAddr amode
908 code1 = amodeCode amode asmVoid
909 code2 = registerCode register {-tmp-}st0 asmVoid
911 --src__2 = registerName register tmp
912 pk__2 = registerKind register
913 sz__2 = kindToSize pk__2
915 code__2 = asmParThen [code1, code2] .
916 mkSeqInstr (FSTP sz (OpAddr dst__2))
920 assignFltCode pk dst src =
921 getReg dst `thenUs` \ register1 ->
922 getReg src `thenUs` \ register2 ->
923 --getNewRegNCG (registerKind register2)
927 dst__2 = registerName register1 st0 --tmp
929 code = registerCode register2 dst__2
930 src__2 = registerName register2 dst__2
938 Generating an unconditional branch. We accept two types of targets:
939 an immediate CLabel or a tree that gets evaluated into a register.
940 Any CLabels which are AsmTemporaries are assumed to be in the local
941 block of code, close enough for a branch instruction. Other CLabels
942 are assumed to be far away, so we use call.
944 Do not fill the delay slots here; you will confuse the register allocator.
949 :: StixTree -- the branch target
950 -> UniqSM (CodeBlock I386Instr)
954 | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
955 | otherwise = returnInstrs [JMP (OpImm target)]
960 genJump (StInd pk mem) =
961 getAmode mem `thenUs` \ amode ->
963 code = amodeCode amode
964 target = amodeAddr amode
966 returnSeq code [JMP (OpAddr target)]
970 = returnInstr (JMP (OpImm target))
973 target = case imm of Just x -> x
977 getReg tree `thenUs` \ register ->
978 getNewRegNCG PtrRep `thenUs` \ tmp ->
980 code = registerCode register tmp
981 target = registerName register tmp
983 returnSeq code [JMP (OpReg target)]
987 Conditional jumps are always to local labels, so we can use
988 branch instructions. First, we have to ensure that the condition
989 codes are set according to the supplied comparison operation.
994 :: CLabel -- the branch target
995 -> StixTree -- the condition on which to branch
996 -> UniqSM (CodeBlock I386Instr)
998 genCondJump lbl bool =
999 getCondition bool `thenUs` \ condition ->
1001 code = condCode condition
1002 cond = condName condition
1003 target = ImmCLbl lbl
1005 returnSeq code [JXX cond lbl]
1012 :: FAST_STRING -- function to call
1013 -> PrimRep -- type of the result
1014 -> [StixTree] -- arguments (of mixed type)
1015 -> UniqSM (CodeBlock I386Instr)
1017 genCCall fn kind [StInt i]
1018 | fn == SLIT ("PerformGC_wrapper")
1019 = getUniqLabelNCG `thenUs` \ lbl ->
1021 call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
1022 MOV L (OpImm (ImmCLbl lbl))
1023 -- this is hardwired
1024 (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
1025 JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
1030 genCCall fn kind args =
1031 mapUs getCallArg args `thenUs` \ argCode ->
1034 code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
1035 MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
1038 code2 = asmParThen (map ($ asmVoid) (reverse argCode))
1039 call = [CALL (ImmLit fn__2) -- ,
1040 -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
1041 -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
1044 returnSeq (code1 . code2) call
1046 -- function names that begin with '.' are assumed to be special internally
1047 -- generated names like '.mul,' which don't get an underscore prefix
1048 fn__2 = case (_HEAD_ fn) of
1050 _ -> uppBeside (uppChar '_') (uppPStr fn)
1053 :: StixTree -- Current argument
1054 -> UniqSM (CodeBlock I386Instr) -- code
1056 getOp arg `thenUs` \ (code, op, sz) ->
1057 returnUs (code . mkSeqInstr (PUSH sz op))
1060 Trivial (dyadic) instructions. Only look for constants on the right hand
1061 side, because that's where the generic optimizer will have put them.
1066 :: (Operand -> Operand -> I386Instr)
1068 -> Bool -- is the instr commutative?
1071 trivialCode instr [x, y] _
1073 = getReg x `thenUs` \ register1 ->
1074 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
1076 fixedname = registerName register1 eax
1077 code__2 dst = let code1 = registerCode register1 dst
1078 src1 = registerName register1 dst
1080 if isFixed register1 && src1 /= dst
1081 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
1082 instr (OpImm imm__2) (OpReg dst)]
1084 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
1086 returnUs (Any IntRep code__2)
1089 imm__2 = case imm of Just x -> x
1091 trivialCode instr [x, y] _
1093 = getReg y `thenUs` \ register1 ->
1094 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
1096 fixedname = registerName register1 eax
1097 code__2 dst = let code1 = registerCode register1 dst
1098 src1 = registerName register1 dst
1100 if isFixed register1 && src1 /= dst
1101 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
1102 instr (OpImm imm__2) (OpReg dst)]
1104 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
1106 returnUs (Any IntRep code__2)
1109 imm__2 = case imm of Just x -> x
1111 trivialCode instr [x, StInd pk mem] _
1112 = getReg x `thenUs` \ register ->
1113 --getNewRegNCG IntRep `thenUs` \ tmp ->
1114 getAmode mem `thenUs` \ amode ->
1116 fixedname = registerName register eax
1117 code2 = amodeCode amode asmVoid
1118 src2 = amodeAddr amode
1119 code__2 dst = let code1 = registerCode register dst asmVoid
1120 src1 = registerName register dst
1121 in asmParThen [code1, code2] .
1122 if isFixed register && src1 /= dst
1123 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
1124 instr (OpAddr src2) (OpReg dst)]
1126 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
1128 returnUs (Any pk code__2)
1130 trivialCode instr [StInd pk mem, y] _
1131 = getReg y `thenUs` \ register ->
1132 --getNewRegNCG IntRep `thenUs` \ tmp ->
1133 getAmode mem `thenUs` \ amode ->
1135 fixedname = registerName register eax
1136 code2 = amodeCode amode asmVoid
1137 src2 = amodeAddr amode
1139 code1 = registerCode register dst asmVoid
1140 src1 = registerName register dst
1141 in asmParThen [code1, code2] .
1142 if isFixed register && src1 /= dst
1143 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
1144 instr (OpAddr src2) (OpReg dst)]
1146 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
1148 returnUs (Any pk code__2)
1150 trivialCode instr [x, y] is_comm_op
1151 = getReg x `thenUs` \ register1 ->
1152 getReg y `thenUs` \ register2 ->
1153 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
1154 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1156 fixedname = registerName register1 eax
1157 code2 = registerCode register2 tmp2 asmVoid
1158 src2 = registerName register2 tmp2
1160 code1 = registerCode register1 dst asmVoid
1161 src1 = registerName register1 dst
1162 in asmParThen [code1, code2] .
1163 if isFixed register1 && src1 /= dst
1164 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
1165 instr (OpReg src2) (OpReg dst)]
1167 mkSeqInstr (instr (OpReg src2) (OpReg src1))
1169 returnUs (Any IntRep code__2)
1175 addCode sz [x, StInt y]
1177 getReg x `thenUs` \ register ->
1178 getNewRegNCG IntRep `thenUs` \ tmp ->
1180 code = registerCode register tmp
1181 src1 = registerName register tmp
1182 src2 = ImmInt (fromInteger y)
1183 code__2 dst = code .
1184 mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
1186 returnUs (Any IntRep code__2)
1188 addCode sz [x, StInd _ mem]
1189 = getReg x `thenUs` \ register1 ->
1190 --getNewRegNCG (registerKind register1)
1191 -- `thenUs` \ tmp1 ->
1192 getAmode mem `thenUs` \ amode ->
1194 code2 = amodeCode amode
1195 src2 = amodeAddr amode
1197 fixedname = registerName register1 eax
1198 code__2 dst = let code1 = registerCode register1 dst
1199 src1 = registerName register1 dst
1200 in asmParThen [code2 asmVoid,code1 asmVoid] .
1201 if isFixed register1 && src1 /= dst
1202 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
1203 ADD sz (OpAddr src2) (OpReg dst)]
1205 mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
1207 returnUs (Any IntRep code__2)
1209 addCode sz [StInd _ mem, y]
1210 = getReg y `thenUs` \ register2 ->
1211 --getNewRegNCG (registerKind register2)
1212 -- `thenUs` \ tmp2 ->
1213 getAmode mem `thenUs` \ amode ->
1215 code1 = amodeCode amode
1216 src1 = amodeAddr amode
1218 fixedname = registerName register2 eax
1219 code__2 dst = let code2 = registerCode register2 dst
1220 src2 = registerName register2 dst
1221 in asmParThen [code1 asmVoid,code2 asmVoid] .
1222 if isFixed register2 && src2 /= dst
1223 then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
1224 ADD sz (OpAddr src1) (OpReg dst)]
1226 mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
1228 returnUs (Any IntRep code__2)
1231 getReg x `thenUs` \ register1 ->
1232 getReg y `thenUs` \ register2 ->
1233 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1234 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1236 code1 = registerCode register1 tmp1 asmVoid
1237 src1 = registerName register1 tmp1
1238 code2 = registerCode register2 tmp2 asmVoid
1239 src2 = registerName register2 tmp2
1240 code__2 dst = asmParThen [code1, code2] .
1241 mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
1243 returnUs (Any IntRep code__2)
1249 subCode sz [x, StInt y]
1250 = getReg x `thenUs` \ register ->
1251 getNewRegNCG IntRep `thenUs` \ tmp ->
1253 code = registerCode register tmp
1254 src1 = registerName register tmp
1255 src2 = ImmInt (-(fromInteger y))
1256 code__2 dst = code .
1257 mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
1259 returnUs (Any IntRep code__2)
1261 subCode sz args = trivialCode (SUB sz) args False
1266 -> Bool -- True => division, False => remainder operation
1269 -- x must go into eax, edx must be a sign-extension of eax,
1270 -- and y should go in some other register (or memory),
1271 -- so that we get edx:eax / reg -> eax (remainder in edx)
1272 -- Currently we chose to put y in memory (if it is not there already)
1273 divCode sz [x, StInd pk mem] is_division
1274 = getReg x `thenUs` \ register1 ->
1275 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1276 getAmode mem `thenUs` \ amode ->
1278 code1 = registerCode register1 tmp1 asmVoid
1279 src1 = registerName register1 tmp1
1280 code2 = amodeCode amode asmVoid
1281 src2 = amodeAddr amode
1282 code__2 = asmParThen [code1, code2] .
1283 mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
1285 IDIV sz (OpAddr src2)]
1287 returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
1289 divCode sz [x, StInt i] is_division
1290 = getReg x `thenUs` \ register1 ->
1291 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1293 code1 = registerCode register1 tmp1 asmVoid
1294 src1 = registerName register1 tmp1
1295 src2 = ImmInt (fromInteger i)
1296 code__2 = asmParThen [code1] .
1297 mkSeqInstrs [-- we put src2 in (ebx)
1298 MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
1299 MOV L (OpReg src1) (OpReg eax),
1301 IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
1303 returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
1305 divCode sz [x, y] is_division
1306 = getReg x `thenUs` \ register1 ->
1307 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1308 getReg y `thenUs` \ register2 ->
1309 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1311 code1 = registerCode register1 tmp1 asmVoid
1312 src1 = registerName register1 tmp1
1313 code2 = registerCode register2 tmp2 asmVoid
1314 src2 = registerName register2 tmp2
1315 code__2 = asmParThen [code1, code2] .
1316 if src2 == ecx || src2 == esi
1317 then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
1319 IDIV sz (OpReg src2)]
1320 else mkSeqInstrs [ -- we put src2 in (ebx)
1321 MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
1322 MOV L (OpReg src1) (OpReg eax),
1324 IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
1326 returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
1330 -> (Size -> Operand -> I386Instr)
1331 -> (Size -> Operand -> I386Instr) -- reversed instr
1333 -> I386Instr -- reversed instr, pop
1336 trivialFCode pk _ instrr _ _ [StInd pk' mem, y]
1337 = getReg y `thenUs` \ register2 ->
1338 --getNewRegNCG (registerKind register2)
1339 -- `thenUs` \ tmp2 ->
1340 getAmode mem `thenUs` \ amode ->
1342 code1 = amodeCode amode
1343 src1 = amodeAddr amode
1346 code2 = registerCode register2 dst
1347 src2 = registerName register2 dst
1348 in asmParThen [code1 asmVoid,code2 asmVoid] .
1349 mkSeqInstrs [instrr (kindToSize pk) (OpAddr src1)]
1351 returnUs (Any pk code__2)
1353 trivialFCode pk instr _ _ _ [x, StInd pk' mem]
1354 = getReg x `thenUs` \ register1 ->
1355 --getNewRegNCG (registerKind register1)
1356 -- `thenUs` \ tmp1 ->
1357 getAmode mem `thenUs` \ amode ->
1359 code2 = amodeCode amode
1360 src2 = amodeAddr amode
1363 code1 = registerCode register1 dst
1364 src1 = registerName register1 dst
1365 in asmParThen [code2 asmVoid,code1 asmVoid] .
1366 mkSeqInstrs [instr (kindToSize pk) (OpAddr src2)]
1368 returnUs (Any pk code__2)
1370 trivialFCode pk _ _ _ instrpr [x, y] =
1371 getReg x `thenUs` \ register1 ->
1372 getReg y `thenUs` \ register2 ->
1373 --getNewRegNCG (registerKind register1)
1374 -- `thenUs` \ tmp1 ->
1375 --getNewRegNCG (registerKind register2)
1376 -- `thenUs` \ tmp2 ->
1377 getNewRegNCG DoubleRep `thenUs` \ tmp ->
1379 pk1 = registerKind register1
1380 code1 = registerCode register1 st0 --tmp1
1381 src1 = registerName register1 st0 --tmp1
1383 pk2 = registerKind register2
1386 code2 = registerCode register2 dst
1387 src2 = registerName register2 dst
1388 in asmParThen [code1 asmVoid, code2 asmVoid] .
1391 returnUs (Any pk1 code__2)
1395 Trivial unary instructions. Note that we don't have to worry about
1396 matching an StInt as the argument, because genericOpt will already
1397 have handled the constant-folding.
1402 :: (Operand -> I386Instr)
1406 trivialUCode instr [x] =
1407 getReg x `thenUs` \ register ->
1408 -- getNewRegNCG IntRep `thenUs` \ tmp ->
1410 -- fixedname = registerName register eax
1412 code = registerCode register dst
1413 src = registerName register dst
1414 in code . if isFixed register && dst /= src
1415 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
1417 else mkSeqInstr (instr (OpReg src))
1419 returnUs (Any IntRep code__2)
1427 trivialUFCode pk instr [StInd pk' mem] =
1428 getAmode mem `thenUs` \ amode ->
1430 code = amodeCode amode
1431 src = amodeAddr amode
1432 code__2 dst = code . mkSeqInstrs [FLD (kindToSize pk) (OpAddr src),
1435 returnUs (Any pk code__2)
1437 trivialUFCode pk instr [x] =
1438 getReg x `thenUs` \ register ->
1439 --getNewRegNCG pk `thenUs` \ tmp ->
1442 code = registerCode register dst
1443 src = registerName register dst
1444 in code . mkSeqInstrs [instr]
1446 returnUs (Any pk code__2)
1449 Absolute value on integers, mostly for gmp size check macros. Again,
1450 the argument cannot be an StInt, because genericOpt already folded
1455 absIntCode :: [StixTree] -> UniqSM Register
1457 getReg x `thenUs` \ register ->
1458 --getNewRegNCG IntRep `thenUs` \ reg ->
1459 getUniqLabelNCG `thenUs` \ lbl ->
1461 code__2 dst = let code = registerCode register dst
1462 src = registerName register dst
1463 in code . if isFixed register && dst /= src
1464 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
1465 TEST L (OpReg dst) (OpReg dst),
1469 else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
1474 returnUs (Any IntRep code__2)
1478 Simple integer coercions that don't require any code to be generated.
1479 Here we just change the type on the register passed on up
1483 coerceIntCode :: PrimRep -> [StixTree] -> UniqSM Register
1484 coerceIntCode pk [x] =
1485 getReg x `thenUs` \ register ->
1487 Fixed reg _ code -> returnUs (Fixed reg pk code)
1488 Any _ code -> returnUs (Any pk code)
1490 coerceFltCode :: [StixTree] -> UniqSM Register
1492 getReg x `thenUs` \ register ->
1494 Fixed reg _ code -> returnUs (Fixed reg DoubleRep code)
1495 Any _ code -> returnUs (Any DoubleRep code)
1499 Integer to character conversion. We try to do this in one step if
1500 the original object is in memory.
1503 chrCode :: [StixTree] -> UniqSM Register
1505 chrCode [StInd pk mem] =
1506 getAmode mem `thenUs` \ amode ->
1508 code = amodeCode amode
1509 src = amodeAddr amode
1510 code__2 dst = code . mkSeqInstr (MOVZX L (OpAddr src) (OpReg dst))
1512 returnUs (Any pk code__2)
1515 getReg x `thenUs` \ register ->
1516 --getNewRegNCG IntRep `thenUs` \ reg ->
1518 fixedname = registerName register eax
1520 code = registerCode register dst
1521 src = registerName register dst
1523 if isFixed register && src /= dst
1524 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
1525 AND L (OpImm (ImmInt 255)) (OpReg dst)]
1526 else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
1528 returnUs (Any IntRep code__2)
1532 More complicated integer/float conversions. Here we have to store
1533 temporaries in memory to move between the integer and the floating
1534 point register sets.
1537 coerceInt2FP :: PrimRep -> [StixTree] -> UniqSM Register
1538 coerceInt2FP pk [x] =
1539 getReg x `thenUs` \ register ->
1540 getNewRegNCG IntRep `thenUs` \ reg ->
1542 code = registerCode register reg
1543 src = registerName register reg
1545 code__2 dst = code . mkSeqInstrs [
1546 -- to fix: should spill instead of using R1
1547 MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
1548 FILD (kindToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
1550 returnUs (Any pk code__2)
1552 coerceFP2Int :: [StixTree] -> UniqSM Register
1554 getReg x `thenUs` \ register ->
1555 getNewRegNCG DoubleRep `thenUs` \ tmp ->
1557 code = registerCode register tmp
1558 src = registerName register tmp
1559 pk = registerKind register
1562 in code . mkSeqInstrs [
1564 FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)),
1565 MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
1567 returnUs (Any IntRep code__2)
1570 Some random little helpers.
1574 maybeImm :: StixTree -> Maybe Imm
1576 | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
1577 | otherwise = Just (ImmInteger i)
1578 maybeImm (StLitLbl s) = Just (ImmLit (uppBeside (uppChar '_') s))
1579 maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
1580 maybeImm (StCLbl l) = Just (ImmCLbl l)
1581 maybeImm _ = Nothing
1583 mangleIndexTree :: StixTree -> StixTree
1585 mangleIndexTree (StIndex pk base (StInt i)) =
1586 StPrim IntAddOp [base, off]
1588 off = StInt (i * size pk)
1589 size :: PrimRep -> Integer
1590 size pk = case kindToSize pk of
1591 {B -> 1; S -> 2; L -> 4; F -> 4; D -> 8 }
1593 mangleIndexTree (StIndex pk base off) =
1595 CharRep -> StPrim IntAddOp [base, off]
1596 _ -> StPrim IntAddOp [base, off__2]
1598 off__2 = StPrim SllOp [off, StInt (shift pk)]
1599 shift :: PrimRep -> Integer
1603 cvtLitLit :: String -> String
1604 cvtLitLit "stdin" = "_IO_stdin_"
1605 cvtLitLit "stdout" = "_IO_stdout_"
1606 cvtLitLit "stderr" = "_IO_stderr_"
1609 | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
1611 isHex ('0':'x':xs) = all isHexDigit xs
1613 -- Now, where have I seen this before?
1614 isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
1621 stackArgLoc = 23 :: Int -- where to stack call arguments
1627 getNewRegNCG :: PrimRep -> UniqSM Reg
1629 getUnique `thenUs` \ u ->
1630 returnUs (mkReg u pk)
1632 fixFPCond :: Cond -> Cond
1633 -- on the 486 the flags set by FP compare are the unsigned ones!