IMPORT_Trace
import AbsCSyn ( AbstractC, MagicId(..), kindFromMagicId )
-import AbsPrel ( PrimOp(..)
+import PrelInfo ( PrimOp(..)
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
import AsmRegAlloc ( runRegAllocate, mkReg, extractMappedRegNos,
- Reg(..), RegLiveness(..), RegUsage(..),
+ Reg(..), RegLiveness(..), RegUsage(..),
FutureLive(..), MachineRegisters(..), MachineCode(..)
)
-import CLabelInfo ( CLabel, isAsmTemp )
+import CLabel ( CLabel, isAsmTemp )
import I386Code {- everything -}
import MachDesc
import Maybes ( maybeToBool, Maybe(..) )
import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
import Outputable
-import PrimKind ( PrimKind(..), isFloatingKind )
import I386Desc
import Stix
-import SplitUniq
-import Unique
+import UniqSupply
import Pretty
import Unpretty
import Util
type CodeBlock a = (OrdList a -> OrdList a)
-
\end{code}
%************************************************************************
\begin{code}
-i386CodeGen :: PprStyle -> [[StixTree]] -> SUniqSM Unpretty
-i386CodeGen sty trees =
- mapSUs genI386Code trees `thenSUs` \ dynamicCodes ->
+i386CodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
+i386CodeGen sty trees =
+ mapUs genI386Code trees `thenUs` \ dynamicCodes ->
let
staticCodes = scheduleI386Code dynamicCodes
pretty = printLabeledCodes sty staticCodes
in
- returnSUs pretty
+ returnUs pretty
\end{code}
\begin{code}
-data Register
- = Fixed Reg PrimKind (CodeBlock I386Instr)
- | Any PrimKind (Reg -> (CodeBlock I386Instr))
+data Register
+ = Fixed Reg PrimRep (CodeBlock I386Instr)
+ | Any PrimRep (Reg -> (CodeBlock I386Instr))
registerCode :: Register -> Reg -> CodeBlock I386Instr
registerCode (Fixed _ _ code) reg = code
registerName (Fixed reg _ _) _ = reg
registerName (Any _ _) reg = reg
-registerKind :: Register -> PrimKind
+registerKind :: Register -> PrimRep
registerKind (Fixed _ pk _) = pk
registerKind (Any pk _) = pk
asmParThen :: [I386Code] -> (CodeBlock I386Instr)
asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
-returnInstr :: I386Instr -> SUniqSM (CodeBlock I386Instr)
-returnInstr instr = returnSUs (\xs -> mkSeqList (asmInstr instr) xs)
+returnInstr :: I386Instr -> UniqSM (CodeBlock I386Instr)
+returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
-returnInstrs :: [I386Instr] -> SUniqSM (CodeBlock I386Instr)
-returnInstrs instrs = returnSUs (\xs -> mkSeqList (asmSeq instrs) xs)
+returnInstrs :: [I386Instr] -> UniqSM (CodeBlock I386Instr)
+returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
-returnSeq :: (CodeBlock I386Instr) -> [I386Instr] -> SUniqSM (CodeBlock I386Instr)
-returnSeq code instrs = returnSUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
+returnSeq :: (CodeBlock I386Instr) -> [I386Instr] -> UniqSM (CodeBlock I386Instr)
+returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
mkSeqInstr :: I386Instr -> (CodeBlock I386Instr)
mkSeqInstr instr code = mkSeqList (asmInstr instr) code
\begin{code}
-genI386Code :: [StixTree] -> SUniqSM (I386Code)
+genI386Code :: [StixTree] -> UniqSM (I386Code)
genI386Code trees =
- mapSUs getCode trees `thenSUs` \ blocks ->
- returnSUs (foldr (.) id blocks asmVoid)
+ mapUs getCode trees `thenUs` \ blocks ->
+ returnUs (foldr (.) id blocks asmVoid)
\end{code}
\begin{code}
-getCode
+getCode
:: StixTree -- a stix statement
- -> SUniqSM (CodeBlock I386Instr)
+ -> UniqSM (CodeBlock I386Instr)
getCode (StSegment seg) = returnInstr (SEGMENT seg)
getCode (StAssign pk dst src)
- | isFloatingKind pk = assignFltCode pk dst src
+ | isFloatingRep pk = assignFltCode pk dst src
| otherwise = assignIntCode pk dst src
getCode (StLabel lab) = returnInstr (LABEL lab)
getCode (StFunBegin lab) = returnInstr (LABEL lab)
-getCode (StFunEnd lab) = returnSUs id
+getCode (StFunEnd lab) = returnUs id
getCode (StJump arg) = genJump arg
-getCode (StFallThrough lbl) = returnSUs id
+getCode (StFallThrough lbl) = returnUs id
getCode (StCondJump lbl arg) = genCondJump lbl arg
-getCode (StData kind args) =
- mapAndUnzipSUs getData args `thenSUs` \ (codes, imms) ->
- returnSUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
- (foldr1 (.) codes xs))
+getCode (StData kind args) =
+ mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
+ returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
+ (foldr1 (.) codes xs))
where
- getData :: StixTree -> SUniqSM (CodeBlock I386Instr, Imm)
- getData (StInt i) = returnSUs (id, ImmInteger i)
-#if __GLASGOW_HASKELL__ >= 23
--- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'd' : _showRational 30 d))
- -- yurgh (WDP 94/12)
- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'd' : ppShow 80 (ppRational d)))
-#else
- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'd' : show d))
-#endif
- getData (StLitLbl s) = returnSUs (id, ImmLit (uppBeside (uppChar '_') s))
- getData (StLitLit s) = returnSUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
- getData (StString s) =
- getUniqLabelNCG `thenSUs` \ lbl ->
- returnSUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
- getData (StCLbl l) = returnSUs (id, ImmCLbl l)
-
-getCode (StCall fn VoidKind args) = genCCall fn VoidKind args
+ getData :: StixTree -> UniqSM (CodeBlock I386Instr, Imm)
+ getData (StInt i) = returnUs (id, ImmInteger i)
+ getData (StDouble d) = returnUs (id, strImmLit ('0' : 'd' : ppShow 80 (ppRational d)))
+ getData (StLitLbl s) = returnUs (id, ImmLit (uppBeside (uppChar '_') s))
+ getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
+ getData (StString s) =
+ getUniqLabelNCG `thenUs` \ lbl ->
+ returnUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
+ getData (StCLbl l) = returnUs (id, ImmCLbl l)
+
+getCode (StCall fn VoidRep args) = genCCall fn VoidRep args
getCode (StComment s) = returnInstr (COMMENT s)
\begin{code}
-getReg :: StixTree -> SUniqSM Register
+getReg :: StixTree -> UniqSM Register
getReg (StReg (StixMagicId stgreg)) =
case stgRegMap stgreg of
- Just reg -> returnSUs (Fixed reg (kindFromMagicId stgreg) id)
+ Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id)
-- cannot be Nothing
-getReg (StReg (StixTemp u pk)) = returnSUs (Fixed (UnmappedReg u pk) pk id)
+getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id)
getReg (StDouble 0.0)
= let
code dst = mkSeqInstrs [FLDZ]
in
- returnSUs (Any DoubleKind code)
+ returnUs (Any DoubleRep code)
getReg (StDouble 1.0)
= let
code dst = mkSeqInstrs [FLD1]
in
- returnSUs (Any DoubleKind code)
+ returnUs (Any DoubleRep code)
getReg (StDouble d) =
- getUniqLabelNCG `thenSUs` \ lbl ->
- --getNewRegNCG PtrKind `thenSUs` \ tmp ->
+ getUniqLabelNCG `thenUs` \ lbl ->
+ --getNewRegNCG PtrRep `thenUs` \ tmp ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
-#if __GLASGOW_HASKELL__ >= 23
--- DATA D [strImmLit ('0' : 'd' :_showRational 30 d)],
DATA D [strImmLit ('0' : 'd' :ppShow 80 (ppRational d))],
-#else
- DATA D [strImmLit ('0' : 'd' :show d)],
-#endif
SEGMENT TextSegment,
- FLD D (OpImm (ImmCLbl lbl))
- ]
+ FLD D (OpImm (ImmCLbl lbl))
+ ]
in
- returnSUs (Any DoubleKind code)
+ returnUs (Any DoubleRep code)
getReg (StString s) =
- getUniqLabelNCG `thenSUs` \ lbl ->
+ getUniqLabelNCG `thenUs` \ lbl ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
SEGMENT TextSegment,
MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)]
in
- returnSUs (Any PtrKind code)
+ returnUs (Any PtrRep code)
getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
- getUniqLabelNCG `thenSUs` \ lbl ->
+ getUniqLabelNCG `thenUs` \ lbl ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
SEGMENT TextSegment,
MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)]
in
- returnSUs (Any PtrKind code)
+ returnUs (Any PtrRep code)
where
xs = _UNPK_ (_TAIL_ s)
getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
-getReg (StCall fn kind args) =
- genCCall fn kind args `thenSUs` \ call ->
- returnSUs (Fixed reg kind call)
+getReg (StCall fn kind args) =
+ genCCall fn kind args `thenUs` \ call ->
+ returnUs (Fixed reg kind call)
where
- reg = if isFloatingKind kind then st0 else eax
+ reg = if isFloatingRep kind then st0 else eax
-getReg (StPrim primop args) =
+getReg (StPrim primop args) =
case primop of
CharGtOp -> condIntReg GT args
CharLtOp -> condIntReg LT args
CharLeOp -> condIntReg LE args
- IntAddOp -> -- this should be optimised by the generic Opts,
- -- I don't know why it is not (sometimes)!
- case args of
- [x, StInt 0] -> getReg x
- _ -> addCode L args
+ IntAddOp -> -- this should be optimised by the generic Opts,
+ -- I don't know why it is not (sometimes)!
+ case args of
+ [x, StInt 0] -> getReg x
+ _ -> addCode L args
IntSubOp -> subCode L args
IntMulOp -> trivialCode (IMUL L) args True
IntRemOp -> divCode L args False -- remainder
IntNegOp -> trivialUCode (NEGI L) args
IntAbsOp -> absIntCode args
-
+
AndOp -> trivialCode (AND L) args True
OrOp -> trivialCode (OR L) args True
NotOp -> trivialUCode (NOT L) args
ISllOp -> panic "I386Gen:isll"
ISraOp -> panic "I386Gen:isra"
ISrlOp -> panic "I386Gen:isrl"
-
+
IntGtOp -> condIntReg GT args
IntGeOp -> condIntReg GE args
IntEqOp -> condIntReg EQ args
IntNeOp -> condIntReg NE args
IntLtOp -> condIntReg LT args
IntLeOp -> condIntReg LE args
-
+
WordGtOp -> condIntReg GU args
WordGeOp -> condIntReg GEU args
WordEqOp -> condIntReg EQ args
AddrLtOp -> condIntReg LU args
AddrLeOp -> condIntReg LEU args
- FloatAddOp -> trivialFCode FloatKind FADD FADD FADDP FADDP args
- FloatSubOp -> trivialFCode FloatKind FSUB FSUBR FSUBP FSUBRP args
- FloatMulOp -> trivialFCode FloatKind FMUL FMUL FMULP FMULP args
- FloatDivOp -> trivialFCode FloatKind FDIV FDIVR FDIVP FDIVRP args
- FloatNegOp -> trivialUFCode FloatKind FCHS args
+ FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP args
+ FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP args
+ FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP args
+ FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP args
+ FloatNegOp -> trivialUFCode FloatRep FCHS args
FloatGtOp -> condFltReg GT args
FloatGeOp -> condFltReg GE args
FloatLtOp -> condFltReg LT args
FloatLeOp -> condFltReg LE args
- FloatExpOp -> promoteAndCall SLIT("exp") DoubleKind
- FloatLogOp -> promoteAndCall SLIT("log") DoubleKind
- FloatSqrtOp -> trivialUFCode FloatKind FSQRT args
-
- FloatSinOp -> promoteAndCall SLIT("sin") DoubleKind
- --trivialUFCode FloatKind FSIN args
- FloatCosOp -> promoteAndCall SLIT("cos") DoubleKind
- --trivialUFCode FloatKind FCOS args
- FloatTanOp -> promoteAndCall SLIT("tan") DoubleKind
-
- FloatAsinOp -> promoteAndCall SLIT("asin") DoubleKind
- FloatAcosOp -> promoteAndCall SLIT("acos") DoubleKind
- FloatAtanOp -> promoteAndCall SLIT("atan") DoubleKind
-
- FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleKind
- FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleKind
- FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleKind
-
- FloatPowerOp -> promoteAndCall SLIT("pow") DoubleKind
-
- DoubleAddOp -> trivialFCode DoubleKind FADD FADD FADDP FADDP args
- DoubleSubOp -> trivialFCode DoubleKind FSUB FSUBR FSUBP FSUBRP args
- DoubleMulOp -> trivialFCode DoubleKind FMUL FMUL FMULP FMULP args
- DoubleDivOp -> trivialFCode DoubleKind FDIV FDIVR FDIVP FDIVRP args
- DoubleNegOp -> trivialUFCode DoubleKind FCHS args
-
+ FloatExpOp -> promoteAndCall SLIT("exp") DoubleRep
+ FloatLogOp -> promoteAndCall SLIT("log") DoubleRep
+ FloatSqrtOp -> trivialUFCode FloatRep FSQRT args
+
+ FloatSinOp -> promoteAndCall SLIT("sin") DoubleRep
+ --trivialUFCode FloatRep FSIN args
+ FloatCosOp -> promoteAndCall SLIT("cos") DoubleRep
+ --trivialUFCode FloatRep FCOS args
+ FloatTanOp -> promoteAndCall SLIT("tan") DoubleRep
+
+ FloatAsinOp -> promoteAndCall SLIT("asin") DoubleRep
+ FloatAcosOp -> promoteAndCall SLIT("acos") DoubleRep
+ FloatAtanOp -> promoteAndCall SLIT("atan") DoubleRep
+
+ FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleRep
+ FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleRep
+ FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleRep
+
+ FloatPowerOp -> promoteAndCall SLIT("pow") DoubleRep
+
+ DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP args
+ DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP args
+ DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP args
+ DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP args
+ DoubleNegOp -> trivialUFCode DoubleRep FCHS args
+
DoubleGtOp -> condFltReg GT args
DoubleGeOp -> condFltReg GE args
DoubleEqOp -> condFltReg EQ args
DoubleLtOp -> condFltReg LT args
DoubleLeOp -> condFltReg LE args
- DoubleExpOp -> call SLIT("exp") DoubleKind
- DoubleLogOp -> call SLIT("log") DoubleKind
- DoubleSqrtOp -> trivialUFCode DoubleKind FSQRT args
-
- DoubleSinOp -> call SLIT("sin") DoubleKind
- --trivialUFCode DoubleKind FSIN args
- DoubleCosOp -> call SLIT("cos") DoubleKind
- --trivialUFCode DoubleKind FCOS args
- DoubleTanOp -> call SLIT("tan") DoubleKind
-
- DoubleAsinOp -> call SLIT("asin") DoubleKind
- DoubleAcosOp -> call SLIT("acos") DoubleKind
- DoubleAtanOp -> call SLIT("atan") DoubleKind
-
- DoubleSinhOp -> call SLIT("sinh") DoubleKind
- DoubleCoshOp -> call SLIT("cosh") DoubleKind
- DoubleTanhOp -> call SLIT("tanh") DoubleKind
-
- DoublePowerOp -> call SLIT("pow") DoubleKind
-
- OrdOp -> coerceIntCode IntKind args
+ DoubleExpOp -> call SLIT("exp") DoubleRep
+ DoubleLogOp -> call SLIT("log") DoubleRep
+ DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT args
+
+ DoubleSinOp -> call SLIT("sin") DoubleRep
+ --trivialUFCode DoubleRep FSIN args
+ DoubleCosOp -> call SLIT("cos") DoubleRep
+ --trivialUFCode DoubleRep FCOS args
+ DoubleTanOp -> call SLIT("tan") DoubleRep
+
+ DoubleAsinOp -> call SLIT("asin") DoubleRep
+ DoubleAcosOp -> call SLIT("acos") DoubleRep
+ DoubleAtanOp -> call SLIT("atan") DoubleRep
+
+ DoubleSinhOp -> call SLIT("sinh") DoubleRep
+ DoubleCoshOp -> call SLIT("cosh") DoubleRep
+ DoubleTanhOp -> call SLIT("tanh") DoubleRep
+
+ DoublePowerOp -> call SLIT("pow") DoubleRep
+
+ OrdOp -> coerceIntCode IntRep args
ChrOp -> chrCode args
Float2IntOp -> coerceFP2Int args
- Int2FloatOp -> coerceInt2FP FloatKind args
+ Int2FloatOp -> coerceInt2FP FloatRep args
Double2IntOp -> coerceFP2Int args
- Int2DoubleOp -> coerceInt2FP DoubleKind args
+ Int2DoubleOp -> coerceInt2FP DoubleRep args
Double2FloatOp -> coerceFltCode args
Float2DoubleOp -> coerceFltCode args
call fn pk = getReg (StCall fn pk args)
promoteAndCall fn pk = getReg (StCall fn pk (map promote args))
where
- promote x = StPrim Float2DoubleOp [x]
+ promote x = StPrim Float2DoubleOp [x]
getReg (StInd pk mem) =
- getAmode mem `thenSUs` \ amode ->
- let
+ getAmode mem `thenUs` \ amode ->
+ let
code = amodeCode amode
src = amodeAddr amode
size = kindToSize pk
- code__2 dst = code .
- if pk == DoubleKind || pk == FloatKind
- then mkSeqInstr (FLD {-D-} size (OpAddr src))
- else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
+ code__2 dst = code .
+ if pk == DoubleRep || pk == FloatRep
+ then mkSeqInstr (FLD {-D-} size (OpAddr src))
+ else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
getReg (StInt i)
src = ImmInt (fromInteger i)
code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
in
- returnSUs (Any IntKind code)
+ returnUs (Any IntRep code)
getReg leaf
| maybeToBool imm =
let
- code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
+ code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
in
- returnSUs (Any PtrKind code)
+ returnUs (Any PtrRep code)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
\begin{code}
-getAmode :: StixTree -> SUniqSM Amode
+getAmode :: StixTree -> UniqSM Amode
getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
getAmode (StPrim IntSubOp [x, StInt i])
=
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
- getReg x `thenSUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getReg x `thenUs` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnSUs (Amode (Addr (Just reg) Nothing off) code)
+ returnUs (Amode (Addr (Just reg) Nothing off) code)
getAmode (StPrim IntAddOp [x, StInt i])
- | maybeToBool imm
+ | maybeToBool imm
= let
- code = mkSeqInstrs []
+ code = mkSeqInstrs []
in
- returnSUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
+ returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
where
imm = maybeImm x
imm__2 = case imm of Just x -> x
getAmode (StPrim IntAddOp [x, StInt i])
=
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
- getReg x `thenSUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getReg x `thenUs` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnSUs (Amode (Addr (Just reg) Nothing off) code)
+ returnUs (Amode (Addr (Just reg) Nothing off) code)
getAmode (StPrim IntAddOp [x, y]) =
- getNewRegNCG PtrKind `thenSUs` \ tmp1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
+ getNewRegNCG PtrRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
let
code1 = registerCode register1 tmp1 asmVoid
reg1 = registerName register1 tmp1
reg2 = registerName register2 tmp2
code__2 = asmParThen [code1, code2]
in
- returnSUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
+ returnUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
getAmode leaf
| maybeToBool imm =
let code = mkSeqInstrs []
in
- returnSUs (Amode (ImmAddr imm__2 0) code)
+ returnUs (Amode (ImmAddr imm__2 0) code)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
getAmode other =
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
- getReg other `thenSUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
+ getReg other `thenUs` \ register ->
let
code = registerCode register tmp
reg = registerName register tmp
off = Nothing
in
- returnSUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code)
+ returnUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code)
\end{code}
\begin{code}
getOp
- :: StixTree
- -> SUniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size
+ :: StixTree
+ -> UniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size
getOp (StInt i)
- = returnSUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
+ = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
getOp (StInd pk mem)
- = getAmode mem `thenSUs` \ amode ->
+ = getAmode mem `thenUs` \ amode ->
let
code = amodeCode amode --asmVoid
addr = amodeAddr amode
sz = kindToSize pk
- in returnSUs (code, OpAddr addr, sz)
+ in returnUs (code, OpAddr addr, sz)
getOp op
- = getReg op `thenSUs` \ register ->
+ = getReg op `thenUs` \ register ->
getNewRegNCG (registerKind register)
- `thenSUs` \ tmp ->
- let
+ `thenUs` \ tmp ->
+ let
code = registerCode register tmp
reg = registerName register tmp
pk = registerKind register
sz = kindToSize pk
in
- returnSUs (code, OpReg reg, sz)
+ returnUs (code, OpReg reg, sz)
getOpRI
- :: StixTree
- -> SUniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size
+ :: StixTree
+ -> UniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size
getOpRI op
| maybeToBool imm
- = returnSUs (asmParThen [], OpImm imm_op, L)
+ = returnUs (asmParThen [], OpImm imm_op, L)
where
imm = maybeImm op
imm_op = case imm of Just x -> x
getOpRI op
- = getReg op `thenSUs` \ register ->
+ = getReg op `thenUs` \ register ->
getNewRegNCG (registerKind register)
- `thenSUs` \ tmp ->
- let
+ `thenUs` \ tmp ->
+ let
code = registerCode register tmp
reg = registerName register tmp
pk = registerKind register
sz = kindToSize pk
in
- returnSUs (code, OpReg reg, sz)
+ returnUs (code, OpReg reg, sz)
\end{code}
\begin{code}
-getCondition :: StixTree -> SUniqSM Condition
+getCondition :: StixTree -> UniqSM Condition
-getCondition (StPrim primop args) =
+getCondition (StPrim primop args) =
case primop of
CharGtOp -> condIntCode GT args
IntNeOp -> condIntCode NE args
IntLtOp -> condIntCode LT args
IntLeOp -> condIntCode LE args
-
+
WordGtOp -> condIntCode GU args
WordGeOp -> condIntCode GEU args
WordEqOp -> condIntCode EQ args
\begin{code}
-condIntCode, condFltCode :: Cond -> [StixTree] -> SUniqSM Condition
-condIntCode cond [StInd _ x, y]
+condIntCode, condFltCode :: Cond -> [StixTree] -> UniqSM Condition
+condIntCode cond [StInd _ x, y]
| maybeToBool imm
- = getAmode x `thenSUs` \ amode ->
+ = getAmode x `thenUs` \ amode ->
let
code1 = amodeCode amode asmVoid
y__2 = amodeAddr amode
- code__2 = asmParThen [code1] .
+ code__2 = asmParThen [code1] .
mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
in
- returnSUs (Condition False cond code__2)
+ returnUs (Condition False cond code__2)
where
imm = maybeImm y
imm__2 = case imm of Just x -> x
-condIntCode cond [x, StInt 0]
- = getReg x `thenSUs` \ register1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+condIntCode cond [x, StInt 0]
+ = getReg x `thenUs` \ register1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code__2 = asmParThen [code1] .
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code__2 = asmParThen [code1] .
mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
in
- returnSUs (Condition False cond code__2)
+ returnUs (Condition False cond code__2)
-condIntCode cond [x, y]
+condIntCode cond [x, y]
| maybeToBool imm
- = getReg x `thenSUs` \ register1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ = getReg x `thenUs` \ register1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code__2 = asmParThen [code1] .
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code__2 = asmParThen [code1] .
mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
in
- returnSUs (Condition False cond code__2)
+ returnUs (Condition False cond code__2)
where
imm = maybeImm y
imm__2 = case imm of Just x -> x
-condIntCode cond [StInd _ x, y]
- = getAmode x `thenSUs` \ amode ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+condIntCode cond [StInd _ x, y]
+ = getAmode x `thenUs` \ amode ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
code1 = amodeCode amode asmVoid
src1 = amodeAddr amode
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
in
- returnSUs (Condition False cond code__2)
+ returnUs (Condition False cond code__2)
-condIntCode cond [y, StInd _ x]
- = getAmode x `thenSUs` \ amode ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+condIntCode cond [y, StInd _ x]
+ = getAmode x `thenUs` \ amode ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
code1 = amodeCode amode asmVoid
src1 = amodeAddr amode
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
in
- returnSUs (Condition False cond code__2)
+ returnUs (Condition False cond code__2)
condIntCode cond [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
- code1 = registerCode register1 tmp1 asmVoid
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 asmVoid
- src2 = registerName register2 tmp2
- code__2 = asmParThen [code1, code2] .
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
in
- returnSUs (Condition False cond code__2)
+ returnUs (Condition False cond code__2)
condFltCode cond [x, StDouble 0.0] =
- getReg x `thenSUs` \ register1 ->
+ getReg x `thenUs` \ register1 ->
getNewRegNCG (registerKind register1)
- `thenSUs` \ tmp1 ->
+ `thenUs` \ tmp1 ->
let
pk1 = registerKind register1
code1 = registerCode register1 tmp1
code__2 = asmParThen [code1 asmVoid] .
mkSeqInstrs [FTST, FSTP D (OpReg st0), -- or FLDZ, FUCOMPP ?
- FNSTSW,
- --AND HB (OpImm (ImmInt 68)) (OpReg eax),
- --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
- SAHF
- ]
+ FNSTSW,
+ --AND HB (OpImm (ImmInt 68)) (OpReg eax),
+ --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
+ SAHF
+ ]
in
- returnSUs (Condition True (fixFPCond cond) code__2)
+ returnUs (Condition True (fixFPCond cond) code__2)
condFltCode cond [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
getNewRegNCG (registerKind register1)
- `thenSUs` \ tmp1 ->
+ `thenUs` \ tmp1 ->
getNewRegNCG (registerKind register2)
- `thenSUs` \ tmp2 ->
+ `thenUs` \ tmp2 ->
let
pk1 = registerKind register1
code1 = registerCode register1 tmp1
code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
mkSeqInstrs [FUCOMPP,
- FNSTSW,
- --AND HB (OpImm (ImmInt 68)) (OpReg eax),
- --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
- SAHF
- ]
+ FNSTSW,
+ --AND HB (OpImm (ImmInt 68)) (OpReg eax),
+ --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
+ SAHF
+ ]
in
- returnSUs (Condition True (fixFPCond cond) code__2)
+ returnUs (Condition True (fixFPCond cond) code__2)
\end{code}
\begin{code}
-condIntReg :: Cond -> [StixTree] -> SUniqSM Register
+condIntReg :: Cond -> [StixTree] -> UniqSM Register
condIntReg cond args =
- condIntCode cond args `thenSUs` \ condition ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
- --getReg dst `thenSUs` \ register ->
- let
+ condIntCode cond args `thenUs` \ condition ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ --getReg dst `thenUs` \ register ->
+ let
--code2 = registerCode register tmp asmVoid
--dst__2 = registerName register tmp
- code = condCode condition
- cond = condName condition
+ code = condCode condition
+ cond = condName condition
-- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
- code__2 dst = code . mkSeqInstrs [
+ code__2 dst = code . mkSeqInstrs [
SETCC cond (OpReg tmp),
AND L (OpImm (ImmInt 1)) (OpReg tmp),
- MOV L (OpReg tmp) (OpReg dst)]
+ MOV L (OpReg tmp) (OpReg dst)]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-condFltReg :: Cond -> [StixTree] -> SUniqSM Register
+condFltReg :: Cond -> [StixTree] -> UniqSM Register
condFltReg cond args =
- getUniqLabelNCG `thenSUs` \ lbl1 ->
- getUniqLabelNCG `thenSUs` \ lbl2 ->
- condFltCode cond args `thenSUs` \ condition ->
+ getUniqLabelNCG `thenUs` \ lbl1 ->
+ getUniqLabelNCG `thenUs` \ lbl2 ->
+ condFltCode cond args `thenUs` \ condition ->
let
code = condCode condition
cond = condName condition
code__2 dst = code . mkSeqInstrs [
- JXX cond lbl1,
+ JXX cond lbl1,
MOV L (OpImm (ImmInt 0)) (OpReg dst),
JXX ALWAYS lbl2,
LABEL lbl1,
MOV L (OpImm (ImmInt 1)) (OpReg dst),
LABEL lbl2]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
some of the register transfers will go away, because we can use the destination
register to complete the code generation for the right hand side. This only
fails when the right hand side is forced into a fixed register (e.g. the result
-of a call).
+of a call).
\begin{code}
-assignIntCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock I386Instr)
-assignIntCode pk (StInd _ dst) src
- = getAmode dst `thenSUs` \ amode ->
- getOpRI src `thenSUs` \ (codesrc, opsrc, sz) ->
- let
+assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock I386Instr)
+assignIntCode pk (StInd _ dst) src
+ = getAmode dst `thenUs` \ amode ->
+ getOpRI src `thenUs` \ (codesrc, opsrc, sz) ->
+ let
code1 = amodeCode amode asmVoid
dst__2 = amodeAddr amode
- code__2 = asmParThen [code1, codesrc asmVoid] .
- mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
+ code__2 = asmParThen [code1, codesrc asmVoid] .
+ mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
in
- returnSUs code__2
+ returnUs code__2
assignIntCode pk dst (StInd _ src) =
- getNewRegNCG IntKind `thenSUs` \ tmp ->
- getAmode src `thenSUs` \ amode ->
- getReg dst `thenSUs` \ register ->
- let
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode src `thenUs` \ amode ->
+ getReg dst `thenUs` \ register ->
+ let
code1 = amodeCode amode asmVoid
src__2 = amodeAddr amode
code2 = registerCode register tmp asmVoid
dst__2 = registerName register tmp
sz = kindToSize pk
- code__2 = asmParThen [code1, code2] .
- mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
+ code__2 = asmParThen [code1, code2] .
+ mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
in
- returnSUs code__2
+ returnUs code__2
assignIntCode pk dst src =
- getReg dst `thenSUs` \ register1 ->
- getReg src `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
- let
+ getReg dst `thenUs` \ register1 ->
+ getReg src `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
dst__2 = registerName register1 tmp
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
code__2 = if isFixed register2 && dst__2 /= src__2
then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
- else
- code
+ else
+ code
in
- returnSUs code__2
-
-assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock I386Instr)
-assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
- = getNewRegNCG IntKind `thenSUs` \ tmp ->
- getAmode src `thenSUs` \ amodesrc ->
- getAmode dst `thenSUs` \ amodedst ->
- --getReg src `thenSUs` \ register ->
- let
+ returnUs code__2
+
+assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock I386Instr)
+assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
+ = getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode src `thenUs` \ amodesrc ->
+ getAmode dst `thenUs` \ amodedst ->
+ --getReg src `thenUs` \ register ->
+ let
codesrc1 = amodeCode amodesrc asmVoid
addrsrc1 = amodeAddr amodesrc
codedst1 = amodeCode amodedst asmVoid
addrsrc2 = case (offset addrsrc1 4) of Just x -> x
addrdst2 = case (offset addrdst1 4) of Just x -> x
- code__2 = asmParThen [codesrc1, codedst1] .
+ code__2 = asmParThen [codesrc1, codedst1] .
mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
- MOV L (OpReg tmp) (OpAddr addrdst1)]
- ++
- if pk == DoubleKind
- then [MOV L (OpAddr addrsrc2) (OpReg tmp),
- MOV L (OpReg tmp) (OpAddr addrdst2)]
- else [])
+ MOV L (OpReg tmp) (OpAddr addrdst1)]
+ ++
+ if pk == DoubleRep
+ then [MOV L (OpAddr addrsrc2) (OpReg tmp),
+ MOV L (OpReg tmp) (OpAddr addrdst2)]
+ else [])
in
- returnSUs code__2
+ returnUs code__2
assignFltCode pk (StInd _ dst) src =
- --getNewRegNCG pk `thenSUs` \ tmp ->
- getAmode dst `thenSUs` \ amode ->
- getReg src `thenSUs` \ register ->
- let
+ --getNewRegNCG pk `thenUs` \ tmp ->
+ getAmode dst `thenUs` \ amode ->
+ getReg src `thenUs` \ register ->
+ let
sz = kindToSize pk
dst__2 = amodeAddr amode
pk__2 = registerKind register
sz__2 = kindToSize pk__2
- code__2 = asmParThen [code1, code2] .
+ code__2 = asmParThen [code1, code2] .
mkSeqInstr (FSTP sz (OpAddr dst__2))
in
- returnSUs code__2
+ returnUs code__2
assignFltCode pk dst src =
- getReg dst `thenSUs` \ register1 ->
- getReg src `thenSUs` \ register2 ->
+ getReg dst `thenUs` \ register1 ->
+ getReg src `thenUs` \ register2 ->
--getNewRegNCG (registerKind register2)
- -- `thenSUs` \ tmp ->
- let
+ -- `thenUs` \ tmp ->
+ let
sz = kindToSize pk
dst__2 = registerName register1 st0 --tmp
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
- code__2 = code
+ code__2 = code
in
- returnSUs code__2
+ returnUs code__2
-\end{code}
+\end{code}
Generating an unconditional branch. We accept two types of targets:
an immediate CLabel or a tree that gets evaluated into a register.
\begin{code}
-genJump
+genJump
:: StixTree -- the branch target
- -> SUniqSM (CodeBlock I386Instr)
+ -> UniqSM (CodeBlock I386Instr)
{-
-genJump (StCLbl lbl)
+genJump (StCLbl lbl)
| isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
| otherwise = returnInstrs [JMP (OpImm target)]
where
-}
genJump (StInd pk mem) =
- getAmode mem `thenSUs` \ amode ->
+ getAmode mem `thenUs` \ amode ->
let
code = amodeCode amode
target = amodeAddr amode
in
returnSeq code [JMP (OpAddr target)]
-genJump tree
+genJump tree
| maybeToBool imm
= returnInstr (JMP (OpImm target))
where
genJump tree =
- getReg tree `thenSUs` \ register ->
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
+ getReg tree `thenUs` \ register ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
let
code = registerCode register tmp
target = registerName register tmp
\begin{code}
-genCondJump
+genCondJump
:: CLabel -- the branch target
-> StixTree -- the condition on which to branch
- -> SUniqSM (CodeBlock I386Instr)
+ -> UniqSM (CodeBlock I386Instr)
-genCondJump lbl bool =
- getCondition bool `thenSUs` \ condition ->
+genCondJump lbl bool =
+ getCondition bool `thenUs` \ condition ->
let
code = condCode condition
cond = condName condition
- target = ImmCLbl lbl
+ target = ImmCLbl lbl
in
- returnSeq code [JXX cond lbl]
+ returnSeq code [JXX cond lbl]
\end{code}
genCCall
:: FAST_STRING -- function to call
- -> PrimKind -- type of the result
+ -> PrimRep -- type of the result
-> [StixTree] -- arguments (of mixed type)
- -> SUniqSM (CodeBlock I386Instr)
+ -> UniqSM (CodeBlock I386Instr)
-genCCall fn kind [StInt i]
+genCCall fn kind [StInt i]
| fn == SLIT ("PerformGC_wrapper")
- = getUniqLabelNCG `thenSUs` \ lbl ->
+ = getUniqLabelNCG `thenUs` \ lbl ->
let
- call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
- MOV L (OpImm (ImmCLbl lbl))
- -- this is hardwired
- (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
- JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
- LABEL lbl]
+ call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
+ MOV L (OpImm (ImmCLbl lbl))
+ -- this is hardwired
+ (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
+ JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
+ LABEL lbl]
in
returnInstrs call
genCCall fn kind args =
- mapSUs getCallArg args `thenSUs` \ argCode ->
+ mapUs getCallArg args `thenUs` \ argCode ->
let
- nargs = length args
- code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
- ]
- ]
- code2 = asmParThen (map ($ asmVoid) (reverse argCode))
- call = [CALL (ImmLit fn__2) -- ,
- -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
- -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
- ]
+ nargs = length args
+ code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
+ MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
+ ]
+ ]
+ code2 = asmParThen (map ($ asmVoid) (reverse argCode))
+ call = [CALL (ImmLit fn__2) -- ,
+ -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
+ -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
+ ]
in
returnSeq (code1 . code2) call
where
'.' -> uppPStr fn
_ -> uppBeside (uppChar '_') (uppPStr fn)
- getCallArg
- :: StixTree -- Current argument
- -> SUniqSM (CodeBlock I386Instr) -- code
- getCallArg arg =
- getOp arg `thenSUs` \ (code, op, sz) ->
- returnSUs (code . mkSeqInstr (PUSH sz op))
+ getCallArg
+ :: StixTree -- Current argument
+ -> UniqSM (CodeBlock I386Instr) -- code
+ getCallArg arg =
+ getOp arg `thenUs` \ (code, op, sz) ->
+ returnUs (code . mkSeqInstr (PUSH sz op))
\end{code}
Trivial (dyadic) instructions. Only look for constants on the right hand
\begin{code}
-trivialCode
- :: (Operand -> Operand -> I386Instr)
+trivialCode
+ :: (Operand -> Operand -> I386Instr)
-> [StixTree]
-> Bool -- is the instr commutative?
- -> SUniqSM Register
+ -> UniqSM Register
trivialCode instr [x, y] _
| maybeToBool imm
- = getReg x `thenSUs` \ register1 ->
- --getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ = getReg x `thenUs` \ register1 ->
+ --getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
fixedname = registerName register1 eax
- code__2 dst = let code1 = registerCode register1 dst
+ code__2 dst = let code1 = registerCode register1 dst
src1 = registerName register1 dst
- in code1 .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpImm imm__2) (OpReg dst)]
- else
- mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
+ in code1 .
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpImm imm__2) (OpReg dst)]
+ else
+ mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
where
imm = maybeImm y
imm__2 = case imm of Just x -> x
trivialCode instr [x, y] _
| maybeToBool imm
- = getReg y `thenSUs` \ register1 ->
- --getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ = getReg y `thenUs` \ register1 ->
+ --getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
fixedname = registerName register1 eax
code__2 dst = let code1 = registerCode register1 dst
- src1 = registerName register1 dst
- in code1 .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpImm imm__2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
+ src1 = registerName register1 dst
+ in code1 .
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpImm imm__2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
where
imm = maybeImm x
imm__2 = case imm of Just x -> x
trivialCode instr [x, StInd pk mem] _
- = getReg x `thenSUs` \ register ->
- --getNewRegNCG IntKind `thenSUs` \ tmp ->
- getAmode mem `thenSUs` \ amode ->
+ = getReg x `thenUs` \ register ->
+ --getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode mem `thenUs` \ amode ->
let
fixedname = registerName register eax
code2 = amodeCode amode asmVoid
src2 = amodeAddr amode
code__2 dst = let code1 = registerCode register dst asmVoid
- src1 = registerName register dst
- in asmParThen [code1, code2] .
- if isFixed register && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpAddr src2) (OpReg src1))
+ src1 = registerName register dst
+ in asmParThen [code1, code2] .
+ if isFixed register && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpAddr src2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpAddr src2) (OpReg src1))
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
trivialCode instr [StInd pk mem, y] _
- = getReg y `thenSUs` \ register ->
- --getNewRegNCG IntKind `thenSUs` \ tmp ->
- getAmode mem `thenSUs` \ amode ->
+ = getReg y `thenUs` \ register ->
+ --getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode mem `thenUs` \ amode ->
let
fixedname = registerName register eax
code2 = amodeCode amode asmVoid
src2 = amodeAddr amode
- code__2 dst = let
+ code__2 dst = let
code1 = registerCode register dst asmVoid
src1 = registerName register dst
- in asmParThen [code1, code2] .
- if isFixed register && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpAddr src2) (OpReg src1))
+ in asmParThen [code1, code2] .
+ if isFixed register && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpAddr src2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpAddr src2) (OpReg src1))
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
-trivialCode instr [x, y] is_comm_op
- = getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
- --getNewRegNCG IntKind `thenSUs` \ tmp1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+trivialCode instr [x, y] is_comm_op
+ = getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
+ --getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
fixedname = registerName register1 eax
code2 = registerCode register2 tmp2 asmVoid
code__2 dst = let
code1 = registerCode register1 dst asmVoid
src1 = registerName register1 dst
- in asmParThen [code1, code2] .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpReg src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpReg src2) (OpReg src1))
+ in asmParThen [code1, code2] .
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpReg src2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpReg src2) (OpReg src1))
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-addCode
+addCode
:: Size
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
addCode sz [x, StInt y]
=
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
let
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
- code__2 dst = code .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
+ code__2 dst = code .
+ mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
addCode sz [x, StInd _ mem]
- = getReg x `thenSUs` \ register1 ->
+ = getReg x `thenUs` \ register1 ->
--getNewRegNCG (registerKind register1)
- -- `thenSUs` \ tmp1 ->
- getAmode mem `thenSUs` \ amode ->
- let
+ -- `thenUs` \ tmp1 ->
+ getAmode mem `thenUs` \ amode ->
+ let
code2 = amodeCode amode
src2 = amodeAddr amode
code__2 dst = let code1 = registerCode register1 dst
src1 = registerName register1 dst
in asmParThen [code2 asmVoid,code1 asmVoid] .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- ADD sz (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ ADD sz (OpAddr src2) (OpReg dst)]
+ else
+ mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
addCode sz [StInd _ mem, y]
- = getReg y `thenSUs` \ register2 ->
+ = getReg y `thenUs` \ register2 ->
--getNewRegNCG (registerKind register2)
- -- `thenSUs` \ tmp2 ->
- getAmode mem `thenSUs` \ amode ->
- let
+ -- `thenUs` \ tmp2 ->
+ getAmode mem `thenUs` \ amode ->
+ let
code1 = amodeCode amode
src1 = amodeAddr amode
fixedname = registerName register2 eax
code__2 dst = let code2 = registerCode register2 dst
- src2 = registerName register2 dst
- in asmParThen [code1 asmVoid,code2 asmVoid] .
- if isFixed register2 && src2 /= dst
- then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
- ADD sz (OpAddr src1) (OpReg dst)]
- else
- mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
+ src2 = registerName register2 dst
+ in asmParThen [code1 asmVoid,code2 asmVoid] .
+ if isFixed register2 && src2 /= dst
+ then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
+ ADD sz (OpAddr src1) (OpReg dst)]
+ else
+ mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
addCode sz [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
code1 = registerCode register1 tmp1 asmVoid
src1 = registerName register1 tmp1
code2 = registerCode register2 tmp2 asmVoid
src2 = registerName register2 tmp2
code__2 dst = asmParThen [code1, code2] .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
+ mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-subCode
+subCode
:: Size
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
subCode sz [x, StInt y]
- = getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
+ = getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
let
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (-(fromInteger y))
- code__2 dst = code .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
+ code__2 dst = code .
+ mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
subCode sz args = trivialCode (SUB sz) args False
-divCode
+divCode
:: Size
-> [StixTree]
-> Bool -- True => division, False => remainder operation
- -> SUniqSM Register
+ -> UniqSM Register
--- x must go into eax, edx must be a sign-extension of eax,
+-- x must go into eax, edx must be a sign-extension of eax,
-- and y should go in some other register (or memory),
-- so that we get edx:eax / reg -> eax (remainder in edx)
-- Currently we chose to put y in memory (if it is not there already)
divCode sz [x, StInd pk mem] is_division
- = getReg x `thenSUs` \ register1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
- getAmode mem `thenSUs` \ amode ->
- let
+ = getReg x `thenUs` \ register1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getAmode mem `thenUs` \ amode ->
+ let
code1 = registerCode register1 tmp1 asmVoid
src1 = registerName register1 tmp1
code2 = amodeCode amode asmVoid
src2 = amodeAddr amode
code__2 = asmParThen [code1, code2] .
- mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr src2)]
+ mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr src2)]
in
- returnSUs (Fixed (if is_division then eax else edx) IntKind code__2)
+ returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
divCode sz [x, StInt i] is_division
- = getReg x `thenSUs` \ register1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ = getReg x `thenUs` \ register1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
code1 = registerCode register1 tmp1 asmVoid
src1 = registerName register1 tmp1
src2 = ImmInt (fromInteger i)
code__2 = asmParThen [code1] .
- mkSeqInstrs [-- we put src2 in (ebx)
- MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ mkSeqInstrs [-- we put src2 in (ebx)
+ MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
in
- returnSUs (Fixed (if is_division then eax else edx) IntKind code__2)
+ returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
divCode sz [x, y] is_division
- = getReg x `thenSUs` \ register1 ->
- getNewRegNCG IntKind `thenSUs` \ tmp1 ->
- getReg y `thenSUs` \ register2 ->
- getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ = getReg x `thenUs` \ register1 ->
+ getNewRegNCG IntRep `thenUs` \ tmp1 ->
+ getReg y `thenUs` \ register2 ->
+ getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
code1 = registerCode register1 tmp1 asmVoid
src1 = registerName register1 tmp1
code2 = registerCode register2 tmp2 asmVoid
src2 = registerName register2 tmp2
code__2 = asmParThen [code1, code2] .
- if src2 == ecx || src2 == esi
- then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpReg src2)]
- else mkSeqInstrs [ -- we put src2 in (ebx)
- MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ if src2 == ecx || src2 == esi
+ then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpReg src2)]
+ else mkSeqInstrs [ -- we put src2 in (ebx)
+ MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
in
- returnSUs (Fixed (if is_division then eax else edx) IntKind code__2)
+ returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
-trivialFCode
- :: PrimKind
- -> (Size -> Operand -> I386Instr)
+trivialFCode
+ :: PrimRep
+ -> (Size -> Operand -> I386Instr)
-> (Size -> Operand -> I386Instr) -- reversed instr
-> I386Instr -- pop
-> I386Instr -- reversed instr, pop
- -> [StixTree]
- -> SUniqSM Register
+ -> [StixTree]
+ -> UniqSM Register
trivialFCode pk _ instrr _ _ [StInd pk' mem, y]
- = getReg y `thenSUs` \ register2 ->
+ = getReg y `thenUs` \ register2 ->
--getNewRegNCG (registerKind register2)
- -- `thenSUs` \ tmp2 ->
- getAmode mem `thenSUs` \ amode ->
- let
+ -- `thenUs` \ tmp2 ->
+ getAmode mem `thenUs` \ amode ->
+ let
code1 = amodeCode amode
src1 = amodeAddr amode
- code__2 dst = let
+ code__2 dst = let
code2 = registerCode register2 dst
- src2 = registerName register2 dst
- in asmParThen [code1 asmVoid,code2 asmVoid] .
+ src2 = registerName register2 dst
+ in asmParThen [code1 asmVoid,code2 asmVoid] .
mkSeqInstrs [instrr (kindToSize pk) (OpAddr src1)]
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
trivialFCode pk instr _ _ _ [x, StInd pk' mem]
- = getReg x `thenSUs` \ register1 ->
+ = getReg x `thenUs` \ register1 ->
--getNewRegNCG (registerKind register1)
- -- `thenSUs` \ tmp1 ->
- getAmode mem `thenSUs` \ amode ->
- let
+ -- `thenUs` \ tmp1 ->
+ getAmode mem `thenUs` \ amode ->
+ let
code2 = amodeCode amode
src2 = amodeAddr amode
- code__2 dst = let
+ code__2 dst = let
code1 = registerCode register1 dst
src1 = registerName register1 dst
- in asmParThen [code2 asmVoid,code1 asmVoid] .
+ in asmParThen [code2 asmVoid,code1 asmVoid] .
mkSeqInstrs [instr (kindToSize pk) (OpAddr src2)]
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
trivialFCode pk _ _ _ instrpr [x, y] =
- getReg x `thenSUs` \ register1 ->
- getReg y `thenSUs` \ register2 ->
+ getReg x `thenUs` \ register1 ->
+ getReg y `thenUs` \ register2 ->
--getNewRegNCG (registerKind register1)
- -- `thenSUs` \ tmp1 ->
+ -- `thenUs` \ tmp1 ->
--getNewRegNCG (registerKind register2)
- -- `thenSUs` \ tmp2 ->
- getNewRegNCG DoubleKind `thenSUs` \ tmp ->
+ -- `thenUs` \ tmp2 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
let
pk1 = registerKind register1
code1 = registerCode register1 st0 --tmp1
pk2 = registerKind register2
- code__2 dst = let
+ code__2 dst = let
code2 = registerCode register2 dst
src2 = registerName register2 dst
in asmParThen [code1 asmVoid, code2 asmVoid] .
- mkSeqInstr instrpr
+ mkSeqInstr instrpr
in
- returnSUs (Any pk1 code__2)
+ returnUs (Any pk1 code__2)
\end{code}
\begin{code}
-trivialUCode
- :: (Operand -> I386Instr)
+trivialUCode
+ :: (Operand -> I386Instr)
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
trivialUCode instr [x] =
- getReg x `thenSUs` \ register ->
--- getNewRegNCG IntKind `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+-- getNewRegNCG IntRep `thenUs` \ tmp ->
let
-- fixedname = registerName register eax
code__2 dst = let
code = registerCode register dst
- src = registerName register dst
- in code . if isFixed register && dst /= src
- then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
- instr (OpReg dst)]
- else mkSeqInstr (instr (OpReg src))
+ src = registerName register dst
+ in code . if isFixed register && dst /= src
+ then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+ instr (OpReg dst)]
+ else mkSeqInstr (instr (OpReg src))
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-trivialUFCode
- :: PrimKind
+trivialUFCode
+ :: PrimRep
-> I386Instr
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
trivialUFCode pk instr [StInd pk' mem] =
- getAmode mem `thenSUs` \ amode ->
- let
+ getAmode mem `thenUs` \ amode ->
+ let
code = amodeCode amode
src = amodeAddr amode
code__2 dst = code . mkSeqInstrs [FLD (kindToSize pk) (OpAddr src),
- instr]
+ instr]
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
trivialUFCode pk instr [x] =
- getReg x `thenSUs` \ register ->
- --getNewRegNCG pk `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ --getNewRegNCG pk `thenUs` \ tmp ->
let
code__2 dst = let
code = registerCode register dst
src = registerName register dst
- in code . mkSeqInstrs [instr]
+ in code . mkSeqInstrs [instr]
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
\end{code}
Absolute value on integers, mostly for gmp size check macros. Again,
\begin{code}
-absIntCode :: [StixTree] -> SUniqSM Register
+absIntCode :: [StixTree] -> UniqSM Register
absIntCode [x] =
- getReg x `thenSUs` \ register ->
- --getNewRegNCG IntKind `thenSUs` \ reg ->
- getUniqLabelNCG `thenSUs` \ lbl ->
+ getReg x `thenUs` \ register ->
+ --getNewRegNCG IntRep `thenUs` \ reg ->
+ getUniqLabelNCG `thenUs` \ lbl ->
let
code__2 dst = let code = registerCode register dst
src = registerName register dst
- in code . if isFixed register && dst /= src
- then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
- TEST L (OpReg dst) (OpReg dst),
- JXX GE lbl,
- NEGI L (OpReg dst),
- LABEL lbl]
- else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
- JXX GE lbl,
- NEGI L (OpReg src),
- LABEL lbl]
+ in code . if isFixed register && dst /= src
+ then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+ TEST L (OpReg dst) (OpReg dst),
+ JXX GE lbl,
+ NEGI L (OpReg dst),
+ LABEL lbl]
+ else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
+ JXX GE lbl,
+ NEGI L (OpReg src),
+ LABEL lbl]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
-
+
Simple integer coercions that don't require any code to be generated.
Here we just change the type on the register passed on up
\begin{code}
-coerceIntCode :: PrimKind -> [StixTree] -> SUniqSM Register
+coerceIntCode :: PrimRep -> [StixTree] -> UniqSM Register
coerceIntCode pk [x] =
- getReg x `thenSUs` \ register ->
+ getReg x `thenUs` \ register ->
case register of
- Fixed reg _ code -> returnSUs (Fixed reg pk code)
- Any _ code -> returnSUs (Any pk code)
+ Fixed reg _ code -> returnUs (Fixed reg pk code)
+ Any _ code -> returnUs (Any pk code)
-coerceFltCode :: [StixTree] -> SUniqSM Register
+coerceFltCode :: [StixTree] -> UniqSM Register
coerceFltCode [x] =
- getReg x `thenSUs` \ register ->
+ getReg x `thenUs` \ register ->
case register of
- Fixed reg _ code -> returnSUs (Fixed reg DoubleKind code)
- Any _ code -> returnSUs (Any DoubleKind code)
+ Fixed reg _ code -> returnUs (Fixed reg DoubleRep code)
+ Any _ code -> returnUs (Any DoubleRep code)
\end{code}
the original object is in memory.
\begin{code}
-chrCode :: [StixTree] -> SUniqSM Register
+chrCode :: [StixTree] -> UniqSM Register
{-
chrCode [StInd pk mem] =
- getAmode mem `thenSUs` \ amode ->
- let
+ getAmode mem `thenUs` \ amode ->
+ let
code = amodeCode amode
src = amodeAddr amode
code__2 dst = code . mkSeqInstr (MOVZX L (OpAddr src) (OpReg dst))
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
-}
chrCode [x] =
- getReg x `thenSUs` \ register ->
- --getNewRegNCG IntKind `thenSUs` \ reg ->
+ getReg x `thenUs` \ register ->
+ --getNewRegNCG IntRep `thenUs` \ reg ->
let
fixedname = registerName register eax
code__2 dst = let
code = registerCode register dst
src = registerName register dst
- in code .
- if isFixed register && src /= dst
- then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
- AND L (OpImm (ImmInt 255)) (OpReg dst)]
- else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
+ in code .
+ if isFixed register && src /= dst
+ then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+ AND L (OpImm (ImmInt 255)) (OpReg dst)]
+ else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
point register sets.
\begin{code}
-coerceInt2FP :: PrimKind -> [StixTree] -> SUniqSM Register
-coerceInt2FP pk [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ reg ->
+coerceInt2FP :: PrimRep -> [StixTree] -> UniqSM Register
+coerceInt2FP pk [x] =
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ reg ->
let
code = registerCode register reg
src = registerName register reg
code__2 dst = code . mkSeqInstrs [
- -- to fix: should spill instead of using R1
+ -- to fix: should spill instead of using R1
MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
FILD (kindToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
-coerceFP2Int :: [StixTree] -> SUniqSM Register
+coerceFP2Int :: [StixTree] -> UniqSM Register
coerceFP2Int [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG DoubleKind `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
pk = registerKind register
- code__2 dst = let
- in code . mkSeqInstrs [
+ code__2 dst = let
+ in code . mkSeqInstrs [
FRNDINT,
FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)),
MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
Some random little helpers.
\begin{code}
maybeImm :: StixTree -> Maybe Imm
-maybeImm (StInt i)
+maybeImm (StInt i)
| i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
| otherwise = Just (ImmInteger i)
maybeImm (StLitLbl s) = Just (ImmLit (uppBeside (uppChar '_') s))
mangleIndexTree :: StixTree -> StixTree
-mangleIndexTree (StIndex pk base (StInt i)) =
+mangleIndexTree (StIndex pk base (StInt i)) =
StPrim IntAddOp [base, off]
where
off = StInt (i * size pk)
- size :: PrimKind -> Integer
+ size :: PrimRep -> Integer
size pk = case kindToSize pk of
{B -> 1; S -> 2; L -> 4; F -> 4; D -> 8 }
-mangleIndexTree (StIndex pk base off) =
+mangleIndexTree (StIndex pk base off) =
case pk of
- CharKind -> StPrim IntAddOp [base, off]
+ CharRep -> StPrim IntAddOp [base, off]
_ -> StPrim IntAddOp [base, off__2]
where
off__2 = StPrim SllOp [off, StInt (shift pk)]
- shift :: PrimKind -> Integer
- shift DoubleKind = 3
+ shift :: PrimRep -> Integer
+ shift DoubleRep = 3
shift _ = 2
cvtLitLit :: String -> String
-cvtLitLit "stdin" = "_IO_stdin_"
-cvtLitLit "stdout" = "_IO_stdout_"
+cvtLitLit "stdin" = "_IO_stdin_"
+cvtLitLit "stdout" = "_IO_stdout_"
cvtLitLit "stderr" = "_IO_stderr_"
-cvtLitLit s
+cvtLitLit s
| isHex s = s
| otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
- where
+ where
isHex ('0':'x':xs) = all isHexDigit xs
isHex _ = False
-- Now, where have I seen this before?
\begin{code}
-stackArgLoc = 23 :: Int -- where to stack call arguments
+stackArgLoc = 23 :: Int -- where to stack call arguments
\end{code}
\begin{code}
-getNewRegNCG :: PrimKind -> SUniqSM Reg
-getNewRegNCG pk =
- getSUnique `thenSUs` \ u ->
- returnSUs (mkReg u pk)
+getNewRegNCG :: PrimRep -> UniqSM Reg
+getNewRegNCG pk =
+ getUnique `thenUs` \ u ->
+ returnUs (mkReg u pk)
fixFPCond :: Cond -> Cond
-- on the 486 the flags set by FP compare are the unsigned ones!
projects / ghc-hetmet.git / blobdiff