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 SparcCode {- everything -}
import MachDesc
import Maybes ( maybeToBool, Maybe(..) )
import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
import Outputable
-import PrimKind ( PrimKind(..), isFloatingKind )
import SparcDesc
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}
-sparcCodeGen :: PprStyle -> [[StixTree]] -> SUniqSM Unpretty
-sparcCodeGen sty trees =
- mapSUs genSparcCode trees `thenSUs` \ dynamicCodes ->
+sparcCodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
+sparcCodeGen sty trees =
+ mapUs genSparcCode trees `thenUs` \ dynamicCodes ->
let
staticCodes = scheduleSparcCode dynamicCodes
pretty = printLabeledCodes sty staticCodes
in
- returnSUs pretty
+ returnUs pretty
\end{code}
\begin{code}
-data Register
- = Fixed Reg PrimKind (CodeBlock SparcInstr)
- | Any PrimKind (Reg -> (CodeBlock SparcInstr))
+data Register
+ = Fixed Reg PrimRep (CodeBlock SparcInstr)
+ | Any PrimRep (Reg -> (CodeBlock SparcInstr))
registerCode :: Register -> Reg -> CodeBlock SparcInstr
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 :: [SparcCode] -> (CodeBlock SparcInstr)
asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
-returnInstr :: SparcInstr -> SUniqSM (CodeBlock SparcInstr)
-returnInstr instr = returnSUs (\xs -> mkSeqList (asmInstr instr) xs)
+returnInstr :: SparcInstr -> UniqSM (CodeBlock SparcInstr)
+returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
-returnInstrs :: [SparcInstr] -> SUniqSM (CodeBlock SparcInstr)
-returnInstrs instrs = returnSUs (\xs -> mkSeqList (asmSeq instrs) xs)
+returnInstrs :: [SparcInstr] -> UniqSM (CodeBlock SparcInstr)
+returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
-returnSeq :: (CodeBlock SparcInstr) -> [SparcInstr] -> SUniqSM (CodeBlock SparcInstr)
-returnSeq code instrs = returnSUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
+returnSeq :: (CodeBlock SparcInstr) -> [SparcInstr] -> UniqSM (CodeBlock SparcInstr)
+returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
mkSeqInstr :: SparcInstr -> (CodeBlock SparcInstr)
mkSeqInstr instr code = mkSeqList (asmInstr instr) code
\begin{code}
-genSparcCode :: [StixTree] -> SUniqSM (SparcCode)
+genSparcCode :: [StixTree] -> UniqSM (SparcCode)
genSparcCode 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 SparcInstr)
+ -> UniqSM (CodeBlock SparcInstr)
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 SparcInstr, Imm)
- getData (StInt i) = returnSUs (id, ImmInteger i)
-#if __GLASGOW_HASKELL__ >= 23
--- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'r' : _showRational 30 d))
- -- yurgh (WDP 94/12)
- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'r' : ppShow 80 (ppRational d)))
-#else
- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'r' : show d))
-#endif
- getData (StLitLbl s) = returnSUs (id, ImmLab 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 SparcInstr, Imm)
+ getData (StInt i) = returnUs (id, ImmInteger i)
+ getData (StDouble d) = returnUs (id, strImmLit ('0' : 'r' : ppShow 80 (ppRational d)))
+ getData (StLitLbl s) = returnUs (id, ImmLab 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)
-- cannae 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 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 DF [strImmLit ('0' : 'r' : (_showRational 30 d))],
DATA DF [strImmLit ('0' : 'r' : ppShow 80 (ppRational d))],
-#else
- DATA DF [strImmLit ('0' : 'r' : (show d))],
-#endif
SEGMENT TextSegment,
SETHI (HI (ImmCLbl lbl)) tmp,
LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
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,
SETHI (HI (ImmCLbl lbl)) dst,
OR False dst (RIImm (LO (ImmCLbl lbl))) 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,
SETHI (HI (ImmCLbl lbl)) dst,
OR False dst (RIImm (LO (ImmCLbl lbl))) 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 f0 else o0
+ reg = if isFloatingRep kind then f0 else o0
-getReg (StPrim primop args) =
+getReg (StPrim primop args) =
case primop of
CharGtOp -> condIntReg GT args
IntAddOp -> trivialCode (ADD False False) args
IntSubOp -> trivialCode (SUB False False) args
- IntMulOp -> call SLIT(".umul") IntKind
- IntQuotOp -> call SLIT(".div") IntKind
- IntRemOp -> call SLIT(".rem") IntKind
+ IntMulOp -> call SLIT(".umul") IntRep
+ IntQuotOp -> call SLIT(".div") IntRep
+ IntRemOp -> call SLIT(".rem") IntRep
IntNegOp -> trivialUCode (SUB False False g0) args
IntAbsOp -> absIntCode args
-
+
AndOp -> trivialCode (AND False) args
OrOp -> trivialCode (OR False) args
NotOp -> trivialUCode (XNOR False g0) args
ISllOp -> panic "SparcGen:isll"
ISraOp -> panic "SparcGen:isra"
ISrlOp -> panic "SparcGen: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 args
- FloatSubOp -> trivialFCode FloatKind FSUB args
- FloatMulOp -> trivialFCode FloatKind FMUL args
- FloatDivOp -> trivialFCode FloatKind FDIV args
- FloatNegOp -> trivialUFCode FloatKind (FNEG F) args
+ FloatAddOp -> trivialFCode FloatRep FADD args
+ FloatSubOp -> trivialFCode FloatRep FSUB args
+ FloatMulOp -> trivialFCode FloatRep FMUL args
+ FloatDivOp -> trivialFCode FloatRep FDIV args
+ FloatNegOp -> trivialUFCode FloatRep (FNEG F) 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 -> promoteAndCall SLIT("sqrt") DoubleKind
-
- FloatSinOp -> promoteAndCall SLIT("sin") DoubleKind
- FloatCosOp -> promoteAndCall SLIT("cos") DoubleKind
- 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 args
- DoubleSubOp -> trivialFCode DoubleKind FSUB args
- DoubleMulOp -> trivialFCode DoubleKind FMUL args
- DoubleDivOp -> trivialFCode DoubleKind FDIV args
- DoubleNegOp -> trivialUFCode DoubleKind (FNEG DF) args
-
+ FloatExpOp -> promoteAndCall SLIT("exp") DoubleRep
+ FloatLogOp -> promoteAndCall SLIT("log") DoubleRep
+ FloatSqrtOp -> promoteAndCall SLIT("sqrt") DoubleRep
+
+ FloatSinOp -> promoteAndCall SLIT("sin") DoubleRep
+ FloatCosOp -> promoteAndCall SLIT("cos") DoubleRep
+ 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 args
+ DoubleSubOp -> trivialFCode DoubleRep FSUB args
+ DoubleMulOp -> trivialFCode DoubleRep FMUL args
+ DoubleDivOp -> trivialFCode DoubleRep FDIV args
+ DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) 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 -> call SLIT("sqrt") DoubleKind
-
- DoubleSinOp -> call SLIT("sin") DoubleKind
- DoubleCosOp -> call SLIT("cos") DoubleKind
- 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 -> call SLIT("sqrt") DoubleRep
+
+ DoubleSinOp -> call SLIT("sin") DoubleRep
+ DoubleCosOp -> call SLIT("cos") DoubleRep
+ 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
-
- Double2FloatOp -> trivialUFCode FloatKind (FxTOy DF F) args
- Float2DoubleOp -> trivialUFCode DoubleKind (FxTOy F DF) args
+ Int2DoubleOp -> coerceInt2FP DoubleRep args
+
+ Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) args
+ Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) args
where
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 . mkSeqInstr (LD size src dst)
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
getReg (StInt i)
- | is13Bits i =
+ | is13Bits i =
let
src = ImmInt (fromInteger i)
code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
in
- returnSUs (Any IntKind code)
+ returnUs (Any IntRep code)
getReg leaf
| maybeToBool imm =
let
code dst = mkSeqInstrs [
- SETHI (HI imm__2) dst,
+ SETHI (HI imm__2) dst,
OR False dst (RIImm (LO imm__2)) 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])
| is13Bits (-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 (AddrRegImm reg off) code)
+ returnUs (Amode (AddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, StInt i])
| is13Bits 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 (AddrRegImm reg off) code)
+ returnUs (Amode (AddrRegImm reg 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 (AddrRegReg reg1 reg2) code__2)
+ returnUs (Amode (AddrRegReg reg1 reg2) code__2)
getAmode leaf
| maybeToBool imm =
- getNewRegNCG PtrKind `thenSUs` \ tmp ->
+ getNewRegNCG PtrRep `thenUs` \ tmp ->
let
code = mkSeqInstr (SETHI (HI imm__2) tmp)
in
- returnSUs (Amode (AddrRegImm tmp (LO imm__2)) code)
+ returnUs (Amode (AddrRegImm tmp (LO imm__2)) 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 = ImmInt 0
in
- returnSUs (Amode (AddrRegImm reg off) code)
+ returnUs (Amode (AddrRegImm reg off) code)
\end{code}
\begin{code}
-getCallArg
+getCallArg
:: ([Reg],Int) -- Argument registers and stack offset (accumulator)
-> StixTree -- Current argument
- -> SUniqSM (([Reg],Int), CodeBlock SparcInstr) -- Updated accumulator and code
+ -> UniqSM (([Reg],Int), CodeBlock SparcInstr) -- Updated accumulator and code
-- We have to use up all of our argument registers first.
-getCallArg (dst:dsts, offset) arg =
- getReg arg `thenSUs` \ register ->
+getCallArg (dst:dsts, offset) arg =
+ getReg arg `thenUs` \ register ->
getNewRegNCG (registerKind register)
- `thenSUs` \ tmp ->
+ `thenUs` \ tmp ->
let
- reg = if isFloatingKind pk then tmp else dst
+ reg = if isFloatingRep pk then tmp else dst
code = registerCode register reg
src = registerName register reg
pk = registerKind register
in
- returnSUs (case pk of
- DoubleKind ->
+ returnUs (case pk of
+ DoubleRep ->
case dsts of
[] -> (([], offset + 1), code . mkSeqInstrs [
-- conveniently put the second part in the right stack
ST DF src (spRel (offset - 1)),
LD W (spRel (offset - 1)) dst])
(dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
- ST DF src (spRel (-2)),
- LD W (spRel (-2)) dst,
+ ST DF src (spRel (-2)),
+ LD W (spRel (-2)) dst,
LD W (spRel (-1)) dst__2])
- FloatKind -> ((dsts, offset), code . mkSeqInstrs [
+ FloatRep -> ((dsts, offset), code . mkSeqInstrs [
ST F src (spRel (-2)),
LD W (spRel (-2)) dst])
- _ -> ((dsts, offset), if isFixed register then
+ _ -> ((dsts, offset), if isFixed register then
code . mkSeqInstr (OR False g0 (RIReg src) dst)
else code))
-- Once we have run out of argument registers, we move to the stack
-getCallArg ([], offset) arg =
- getReg arg `thenSUs` \ register ->
+getCallArg ([], offset) arg =
+ getReg arg `thenUs` \ register ->
getNewRegNCG (registerKind register)
- `thenSUs` \ tmp ->
- let
+ `thenUs` \ tmp ->
+ let
code = registerCode register tmp
src = registerName register tmp
pk = registerKind register
sz = kindToSize pk
- words = if pk == DoubleKind then 2 else 1
+ words = if pk == DoubleRep then 2 else 1
in
- returnSUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
+ returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
\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, condFltCode :: Cond -> [StixTree] -> UniqSM Condition
condIntCode cond [x, StInt y]
| is13Bits 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
+ code = registerCode register tmp
+ src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
- code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
+ code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
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 (SUB False True src1 (RIReg src2) g0)
in
- returnSUs (Condition False cond code__2)
+ returnUs (Condition False 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 ->
- getNewRegNCG DoubleKind `thenSUs` \ tmp ->
+ `thenUs` \ tmp2 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
let
promote x = asmInstr (FxTOy F DF x tmp)
code2 = registerCode register2 tmp2
src2 = registerName register2 tmp2
- code__2 =
+ code__2 =
if pk1 == pk2 then
asmParThen [code1 asmVoid, code2 asmVoid] .
mkSeqInstr (FCMP True (kindToSize pk1) src1 src2)
- else if pk1 == FloatKind then
+ else if pk1 == FloatRep then
asmParThen [code1 (promote src1), code2 asmVoid] .
mkSeqInstr (FCMP True DF tmp src2)
else
- asmParThen [code1 asmVoid, code2 (promote src2)] .
+ asmParThen [code1 asmVoid, code2 (promote src2)] .
mkSeqInstr (FCMP True DF src1 tmp)
in
- returnSUs (Condition True cond code__2)
+ returnUs (Condition True cond code__2)
\end{code}
\begin{code}
-condIntReg :: Cond -> [StixTree] -> SUniqSM Register
+condIntReg :: Cond -> [StixTree] -> UniqSM Register
condIntReg EQ [x, StInt 0] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstrs [
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code . mkSeqInstrs [
SUB False True g0 (RIReg src) g0,
SUB True False g0 (RIImm (ImmInt (-1))) dst]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
condIntReg EQ [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
SUB False True g0 (RIReg dst) g0,
SUB True False g0 (RIImm (ImmInt (-1))) dst]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
condIntReg NE [x, StInt 0] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG IntKind `thenSUs` \ tmp ->
- let
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let
code = registerCode register tmp
src = registerName register tmp
code__2 dst = code . mkSeqInstrs [
SUB False True g0 (RIReg src) g0,
ADD True False g0 (RIImm (ImmInt 0)) dst]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
condIntReg NE [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] . mkSeqInstrs [
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
XOR False src1 (RIReg src2) dst,
SUB False True g0 (RIReg dst) g0,
ADD True False g0 (RIImm (ImmInt 0)) dst]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
condIntReg cond args =
- getUniqLabelNCG `thenSUs` \ lbl1 ->
- getUniqLabelNCG `thenSUs` \ lbl2 ->
- condIntCode cond args `thenSUs` \ condition ->
+ getUniqLabelNCG `thenUs` \ lbl1 ->
+ getUniqLabelNCG `thenUs` \ lbl2 ->
+ condIntCode cond args `thenUs` \ condition ->
let
- code = condCode condition
- cond = condName condition
- code__2 dst = code . mkSeqInstrs [
+ code = condCode condition
+ cond = condName condition
+ code__2 dst = code . mkSeqInstrs [
BI cond False (ImmCLbl lbl1), NOP,
OR False g0 (RIImm (ImmInt 0)) dst,
BI ALWAYS False (ImmCLbl lbl2), NOP,
OR False g0 (RIImm (ImmInt 1)) dst,
LABEL lbl2]
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
OR False g0 (RIImm (ImmInt 1)) 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 SparcInstr)
+assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock SparcInstr)
assignIntCode pk (StInd _ dst) src =
- getNewRegNCG IntKind `thenSUs` \ tmp ->
- getAmode dst `thenSUs` \ amode ->
- getReg src `thenSUs` \ register ->
- let
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ getAmode dst `thenUs` \ amode ->
+ getReg src `thenUs` \ register ->
+ let
code1 = amodeCode amode asmVoid
dst__2 = amodeAddr amode
code2 = registerCode register tmp asmVoid
sz = kindToSize pk
code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
in
- returnSUs code__2
+ returnUs code__2
assignIntCode pk dst src =
- getReg dst `thenSUs` \ register1 ->
- getReg src `thenSUs` \ register2 ->
- let
+ getReg dst `thenUs` \ register1 ->
+ getReg src `thenUs` \ register2 ->
+ let
dst__2 = registerName register1 g0
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
- code__2 = if isFixed register2 then
+ code__2 = if isFixed register2 then
code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
else code
in
- returnSUs code__2
+ returnUs code__2
-assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock SparcInstr)
+assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock SparcInstr)
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] .
- if pk == pk__2 then
+ code__2 = asmParThen [code1, code2] .
+ if pk == pk__2 then
mkSeqInstr (ST sz src__2 dst__2)
else
mkSeqInstrs [FxTOy sz__2 sz src__2 tmp, ST sz tmp 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 g0 -- must be Fixed
else if isFixed register2 then code . mkSeqInstr (FMOV sz src__2 dst__2)
else 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 SparcInstr)
+ -> UniqSM (CodeBlock SparcInstr)
-genJump (StCLbl lbl)
+genJump (StCLbl lbl)
| isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
| otherwise = returnInstrs [CALL target 0 True, NOP]
where
target = ImmCLbl lbl
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 SparcInstr)
+ -> UniqSM (CodeBlock SparcInstr)
-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
if condFloat condition then
returnSeq code [NOP, BF cond False target, NOP]
genCCall
:: FAST_STRING -- function to call
- -> PrimKind -- type of the result
+ -> PrimRep -- type of the result
-> [StixTree] -- arguments (of mixed type)
- -> SUniqSM (CodeBlock SparcInstr)
+ -> UniqSM (CodeBlock SparcInstr)
genCCall fn kind args =
- mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
- `thenSUs` \ ((unused,_), argCode) ->
+ mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
+ `thenUs` \ ((unused,_), argCode) ->
let
nRegs = length argRegs - length unused
call = CALL fn__2 nRegs False
'.' -> ImmLit (uppPStr fn)
_ -> ImmLab (uppPStr fn)
- mapAccumLNCG f b [] = returnSUs (b, [])
- mapAccumLNCG f b (x:xs) =
- f b x `thenSUs` \ (b__2, x__2) ->
- mapAccumLNCG f b__2 xs `thenSUs` \ (b__3, xs__2) ->
- returnSUs (b__3, x__2:xs__2)
+ mapAccumLNCG f b [] = returnUs (b, [])
+ mapAccumLNCG f b (x:xs) =
+ f b x `thenUs` \ (b__2, x__2) ->
+ mapAccumLNCG f b__2 xs `thenUs` \ (b__3, xs__2) ->
+ returnUs (b__3, x__2:xs__2)
\end{code}
\begin{code}
-trivialCode
- :: (Reg -> RI -> Reg -> SparcInstr)
+trivialCode
+ :: (Reg -> RI -> Reg -> SparcInstr)
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
trivialCode instr [x, StInt y]
| is13Bits 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 (instr src1 (RIImm src2) dst)
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
trivialCode instr [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
code__2 dst = asmParThen [code1, code2] .
mkSeqInstr (instr src1 (RIReg src2) dst)
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-trivialFCode
- :: PrimKind
- -> (Size -> Reg -> Reg -> Reg -> SparcInstr)
- -> [StixTree]
- -> SUniqSM Register
+trivialFCode
+ :: PrimRep
+ -> (Size -> Reg -> Reg -> Reg -> SparcInstr)
+ -> [StixTree]
+ -> UniqSM Register
trivialFCode pk instr [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
promote x = asmInstr (FxTOy F DF x tmp)
if pk1 == pk2 then
asmParThen [code1 asmVoid, code2 asmVoid] .
mkSeqInstr (instr (kindToSize pk) src1 src2 dst)
- else if pk1 == FloatKind then
+ else if pk1 == FloatRep then
asmParThen [code1 (promote src1), code2 asmVoid] .
mkSeqInstr (instr DF tmp src2 dst)
else
asmParThen [code1 asmVoid, code2 (promote src2)] .
mkSeqInstr (instr DF src1 tmp dst)
in
- returnSUs (Any (if pk1 == pk2 then pk1 else DoubleKind) code__2)
+ returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
\end{code}
\begin{code}
-trivialUCode
- :: (RI -> Reg -> SparcInstr)
+trivialUCode
+ :: (RI -> Reg -> SparcInstr)
-> [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
code = registerCode register tmp
src = registerName register tmp
code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
-trivialUFCode
- :: PrimKind
- -> (Reg -> Reg -> SparcInstr)
+trivialUFCode
+ :: PrimRep
+ -> (Reg -> Reg -> SparcInstr)
-> [StixTree]
- -> SUniqSM Register
+ -> UniqSM Register
trivialUFCode pk instr [x] =
- getReg x `thenSUs` \ register ->
- getNewRegNCG pk `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG pk `thenUs` \ tmp ->
let
code = registerCode register tmp
src = registerName register tmp
code__2 dst = code . mkSeqInstr (instr src dst)
in
- returnSUs (Any pk code__2)
+ returnUs (Any pk code__2)
\end{code}
\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 = registerCode register reg
src = registerName register reg
code__2 dst = code . mkSeqInstrs [
- SUB False True g0 (RIReg src) dst,
- BI GE False (ImmCLbl lbl), NOP,
- OR False g0 (RIReg src) dst,
- LABEL lbl]
+ SUB False True g0 (RIReg src) dst,
+ BI GE False (ImmCLbl lbl), NOP,
+ OR False g0 (RIReg src) dst,
+ 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)
\end{code}
\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
srcOff = offset src 3
code . mkSeqInstr (LD UB src__2 dst)
else
code . mkSeqInstrs [
- LD (kindToSize pk) src dst,
+ LD (kindToSize pk) src dst,
AND False dst (RIImm (ImmInt 255)) 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
code = registerCode register reg
src = registerName register reg
code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
\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
LD W (spRel (-2)) dst,
FxTOy W (kindToSize pk) dst 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 IntKind `thenSUs` \ reg ->
- getNewRegNCG FloatKind `thenSUs` \ tmp ->
+ getReg x `thenUs` \ register ->
+ getNewRegNCG IntRep `thenUs` \ reg ->
+ getNewRegNCG FloatRep `thenUs` \ tmp ->
let
code = registerCode register reg
src = registerName register reg
ST W tmp (spRel (-2)),
LD W (spRel (-2)) dst]
in
- returnSUs (Any IntKind code__2)
+ returnUs (Any IntRep code__2)
\end{code}
\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 (ImmLab 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
{SB -> 1; UB -> 1; HW -> 2; UHW -> 2; W -> 4; D -> 8; F -> 4; DF -> 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" = "__iob+0x0" -- This one is probably okay...
cvtLitLit "stdout" = "__iob+0x14" -- but these next two are dodgy at best
cvtLitLit "stderr" = "__iob+0x28"
-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}
-spRel
+spRel
:: Int -- desired stack offset in words, positive or negative
-> Addr
spRel n = AddrRegImm sp (ImmInt (n * 4))
\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)
\end{code}
projects / ghc-hetmet.git / blobdiff