From: sewardj Date: Tue, 29 Feb 2000 11:36:46 +0000 (+0000) Subject: [project @ 2000-02-29 11:36:46 by sewardj] X-Git-Tag: Approximately_9120_patches~5084 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=8c670eaabfcd0d8db42d0db31342b9293919aaa2;p=ghc-hetmet.git [project @ 2000-02-29 11:36:46 by sewardj] Update sparc-specific parts of NCG to use new infrastructure, so they will at least compile under Solaris. Won't work (yet) tho. --- diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 12d4dbe..2433bb1 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -29,11 +29,14 @@ import CallConv ( cCallConv ) import Stix ( getNatLabelNCG, StixTree(..), StixReg(..), CodeSegment(..), pprStixTrees, ppStixReg, - NatM, thenNat, returnNat, mapNat, mapAndUnzipNat, + NatM, thenNat, returnNat, mapNat, + mapAndUnzipNat, mapAccumLNat, getDeltaNat, setDeltaNat ) import Outputable +infixr 3 `bind` + \end{code} @InstrBlock@s are the insn sequences generated by the insn selectors. @@ -45,7 +48,6 @@ order. type InstrBlock = OrdList Instr -infixr 3 `bind` x `bind` f = f x \end{code} @@ -870,7 +872,7 @@ getRegister leaf getRegister (StDouble d) = getNatLabelNCG `thenNat` \ lbl -> getNewRegNCG PtrRep `thenNat` \ tmp -> - let code dst = mkSeqInstrs [ + let code dst = toOL [ SEGMENT DataSegment, LABEL lbl, DATA DF [ImmDouble d], @@ -1028,7 +1030,7 @@ getRegister (StInd pk mem) code = amodeCode amode src = amodeAddr amode size = primRepToSize pk - code__2 dst = code . mkSeqInstr (LD size src dst) + code__2 dst = code `snocOL` LD size src dst in returnNat (Any pk code__2) @@ -1036,14 +1038,14 @@ getRegister (StInt i) | fits13Bits i = let src = ImmInt (fromInteger i) - code dst = mkSeqInstr (OR False g0 (RIImm src) dst) + code dst = unitOL (OR False g0 (RIImm src) dst) in returnNat (Any IntRep code) getRegister leaf | maybeToBool imm = let - code dst = mkSeqInstrs [ + code dst = toOL [ SETHI (HI imm__2) dst, OR False dst (RIImm (LO imm__2)) dst] in @@ -1225,11 +1227,11 @@ getAmode (StPrim IntAddOp [x, y]) getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> let - code1 = registerCode register1 tmp1 [] + code1 = registerCode register1 tmp1 reg1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 [] + code2 = registerCode register2 tmp2 reg2 = registerName register2 tmp2 - code__2 = asmSeqThen [code1, code2] + code__2 = code1 `appOL` code2 in returnNat (Amode (AddrRegReg reg1 reg2) code__2) @@ -1237,7 +1239,7 @@ getAmode leaf | maybeToBool imm = getNewRegNCG PtrRep `thenNat` \ tmp -> let - code = mkSeqInstr (SETHI (HI imm__2) tmp) + code = unitOL (SETHI (HI imm__2) tmp) in returnNat (Amode (AddrRegImm tmp (LO imm__2)) code) where @@ -1519,7 +1521,7 @@ condIntCode cond x (StInt y) 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 `snocOL` SUB False True src1 (RIImm src2) g0 in returnNat (CondCode False cond code__2) @@ -1529,12 +1531,12 @@ condIntCode cond x y getNewRegNCG IntRep `thenNat` \ tmp1 -> getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 [] + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 [] + code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 = asmSeqThen [code1, code2] . - mkSeqInstr (SUB False True src1 (RIReg src2) g0) + code__2 = code1 `appOL` code2 `snocOL` + SUB False True src1 (RIReg src2) g0 in returnNat (CondCode False cond code__2) @@ -1548,7 +1550,7 @@ condFltCode cond x y `thenNat` \ tmp2 -> getNewRegNCG DoubleRep `thenNat` \ tmp -> let - promote x = asmInstr (FxTOy F DF x tmp) + promote x = FxTOy F DF x tmp pk1 = registerRep register1 code1 = registerCode register1 tmp1 @@ -1560,14 +1562,14 @@ condFltCode cond x y code__2 = if pk1 == pk2 then - asmSeqThen [code1 [], code2 []] . - mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2) + code1 `appOL` code2 `snocOL` + FCMP True (primRepToSize pk1) src1 src2 else if pk1 == FloatRep then - asmSeqThen [code1 (promote src1), code2 []] . - mkSeqInstr (FCMP True DF tmp src2) + code1 `snocOL` promote src1 `appOL` code2 `snocOL` + FCMP True DF tmp src2 else - asmSeqThen [code1 [], code2 (promote src2)] . - mkSeqInstr (FCMP True DF src1 tmp) + code1 `appOL` code2 `snocOL` promote src2 `snocOL` + FCMP True DF src1 tmp in returnNat (CondCode True cond code__2) @@ -1724,12 +1726,12 @@ assignIntCode pk (StInd _ dst) src getAmode dst `thenNat` \ amode -> getRegister src `thenNat` \ register -> let - code1 = amodeCode amode [] + code1 = amodeCode amode dst__2 = amodeAddr amode - code2 = registerCode register tmp [] + code2 = registerCode register tmp src__2 = registerName register tmp sz = primRepToSize pk - code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) + code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2 in returnNat code__2 @@ -1741,7 +1743,7 @@ assignIntCode pk dst src code = registerCode register2 dst__2 src__2 = registerName register2 dst__2 code__2 = if isFixed register2 - then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2) + then code `snocOL` OR False g0 (RIReg src__2) dst__2 else code in returnNat code__2 @@ -1846,18 +1848,17 @@ assignFltCode pk (StInd _ dst) src sz = primRepToSize pk dst__2 = amodeAddr amode - code1 = amodeCode amode [] - code2 = registerCode register tmp1 [] + code1 = amodeCode amode + code2 = registerCode register tmp1 src__2 = registerName register tmp1 pk__2 = registerRep register sz__2 = primRepToSize pk__2 - code__2 = asmSeqThen [code1, code2] ++ - if pk == pk__2 then - mkSeqInstr (ST sz src__2 dst__2) - else - mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2] + code__2 = code1 `appOL` code2 `appOL` + if pk == pk__2 + then unitOL (ST sz src__2 dst__2) + else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2] in returnNat code__2 @@ -1882,9 +1883,9 @@ assignFltCode pk dst src code__2 = if pk /= pk__2 then - code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2) + code `snocOL` FxTOy sz__2 sz src__2 dst__2 else if isFixed register2 then - code . mkSeqInstr (FMOV sz src__2 dst__2) + code `snocOL` FMOV sz src__2 dst__2 else code in @@ -1964,8 +1965,8 @@ genJump tree #if sparc_TARGET_ARCH genJump (StCLbl lbl) - | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP] - | otherwise = returnInstrs [CALL target 0 True, NOP] + | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP]) + | otherwise = returnNat (toOL [CALL target 0 True, NOP]) where target = ImmCLbl lbl @@ -1976,7 +1977,7 @@ genJump tree code = registerCode register tmp target = registerName register tmp in - returnSeq code [JMP (AddrRegReg target g0), NOP] + returnNat (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -2177,11 +2178,13 @@ genCondJump lbl bool cond = condName condition target = ImmCLbl lbl in - returnSeq code ( - if condFloat condition then - [NOP, BF cond False target, NOP] - else - [BI cond False target, NOP] + returnNat ( + code `appOL` + toOL ( + if condFloat condition + then [NOP, BF cond False target, NOP] + else [BI cond False target, NOP] + ) ) #endif {- sparc_TARGET_ARCH -} @@ -2369,9 +2372,9 @@ genCCall fn cconv kind args let nRegs = length allArgRegs - length unused call = CALL fn__2 nRegs False - code = asmSeqThen (map ($ []) argCode) + code = concatOL argCode in - returnSeq code [call, NOP] + returnNat (code `snocOL` call `snocOL` NOP) where -- function names that begin with '.' are assumed to be special -- internally generated names like '.mul,' which don't get an @@ -2410,25 +2413,36 @@ genCCall fn cconv kind args src = registerName register reg pk = registerRep register in - returnNat (case pk of + returnNat ( + case pk of DoubleRep -> case dsts of - [] -> (([], offset + 1), code . mkSeqInstrs [ + [] -> ( ([], offset + 1), + code `snocOL` -- conveniently put the second part in the right stack -- location, and load the first part into %o5 - 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, - LD W (spRel (-1)) dst__2]) - FloatRep -> ((dsts, offset), code . mkSeqInstrs [ - ST F src (spRel (-2)), - LD W (spRel (-2)) dst]) - _ -> ((dsts, offset), if isFixed register then - code . mkSeqInstr (OR False g0 (RIReg src) dst) - else code)) - + ST DF src (spRel (offset - 1)) `snocOL` + LD W (spRel (offset - 1)) dst + ) + (dst__2:dsts__2) + -> ( (dsts__2, offset), + code `snocOL` + ST DF src (spRel (-2)) `snocOL` + LD W (spRel (-2)) dst `snocOL` + LD W (spRel (-1)) dst__2 + ) + FloatRep + -> ( (dsts, offset), + code `snocOL` + ST F src (spRel (-2)) `snocOL` + LD W (spRel (-2)) dst + ) + _ -> ( (dsts, offset), + if isFixed register + then code `snocOL` OR False g0 (RIReg src) dst + else code + ) + ) -- Once we have run out of argument registers, we move to the -- stack... @@ -2443,7 +2457,8 @@ genCCall fn cconv kind args sz = primRepToSize pk words = if pk == DoubleRep then 2 else 1 in - returnNat (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset))) + returnNat ( ([], offset + words), + code `snocOL` ST sz src (spRel offset) ) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -2517,7 +2532,7 @@ condIntReg EQQ x (StInt 0) let code = registerCode register tmp src = registerName register tmp - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ SUB False True g0 (RIReg src) g0, SUB True False g0 (RIImm (ImmInt (-1))) dst] in @@ -2529,11 +2544,11 @@ condIntReg EQQ x y getNewRegNCG IntRep `thenNat` \ tmp1 -> getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 [] + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 [] + code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 dst = asmSeqThen [code1, code2] . mkSeqInstrs [ + code__2 dst = code1 `appOL` code2 `appOL` toOL [ XOR False src1 (RIReg src2) dst, SUB False True g0 (RIReg dst) g0, SUB True False g0 (RIImm (ImmInt (-1))) dst] @@ -2546,7 +2561,7 @@ condIntReg NE x (StInt 0) let code = registerCode register tmp src = registerName register tmp - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ SUB False True g0 (RIReg src) g0, ADD True False g0 (RIImm (ImmInt 0)) dst] in @@ -2558,11 +2573,11 @@ condIntReg NE x y getNewRegNCG IntRep `thenNat` \ tmp1 -> getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 [] + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 [] + code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 dst = asmSeqThen [code1, code2] . mkSeqInstrs [ + code__2 dst = code1 `appOL` code2 `appOL` toOL [ XOR False src1 (RIReg src2) dst, SUB False True g0 (RIReg dst) g0, ADD True False g0 (RIImm (ImmInt 0)) dst] @@ -2576,7 +2591,7 @@ condIntReg cond x y let code = condCode condition cond = condName condition - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ BI cond False (ImmCLbl lbl1), NOP, OR False g0 (RIImm (ImmInt 0)) dst, BI ALWAYS False (ImmCLbl lbl2), NOP, @@ -2593,7 +2608,7 @@ condFltReg cond x y let code = condCode condition cond = condName condition - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ NOP, BF cond False (ImmCLbl lbl1), NOP, OR False g0 (RIImm (ImmInt 0)) dst, @@ -2917,7 +2932,7 @@ trivialCode instr x (StInt y) code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (fromInteger y) - code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst) + code__2 dst = code `snocOL` instr src1 (RIImm src2) dst in returnNat (Any IntRep code__2) @@ -2927,12 +2942,12 @@ trivialCode instr x y getNewRegNCG IntRep `thenNat` \ tmp1 -> getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 [] + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 [] + code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 dst = asmSeqThen [code1, code2] . - mkSeqInstr (instr src1 (RIReg src2) dst) + code__2 dst = code1 `appOL` code2 `snocOL` + instr src1 (RIReg src2) dst in returnNat (Any IntRep code__2) @@ -2946,7 +2961,7 @@ trivialFCode pk instr x y `thenNat` \ tmp2 -> getNewRegNCG DoubleRep `thenNat` \ tmp -> let - promote x = asmInstr (FxTOy F DF x tmp) + promote x = FxTOy F DF x tmp pk1 = registerRep register1 code1 = registerCode register1 tmp1 @@ -2958,14 +2973,14 @@ trivialFCode pk instr x y code__2 dst = if pk1 == pk2 then - asmSeqThen [code1 [], code2 []] . - mkSeqInstr (instr (primRepToSize pk) src1 src2 dst) + code1 `appOL` code2 `snocOL` + instr (primRepToSize pk) src1 src2 dst else if pk1 == FloatRep then - asmSeqThen [code1 (promote src1), code2 []] . - mkSeqInstr (instr DF tmp src2 dst) + code1 `snocOL` promote src1 `appOL` code2 `snocOL` + instr DF tmp src2 dst else - asmSeqThen [code1 [], code2 (promote src2)] . - mkSeqInstr (instr DF src1 tmp dst) + code1 `appOL` code2 `snocOL` promote src2 `snocOL` + instr DF src1 tmp dst in returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2) @@ -2976,7 +2991,7 @@ trivialUCode instr x let code = registerCode register tmp src = registerName register tmp - code__2 dst = code . mkSeqInstr (instr (RIReg src) dst) + code__2 dst = code `snocOL` instr (RIReg src) dst in returnNat (Any IntRep code__2) @@ -2987,7 +3002,7 @@ trivialUFCode pk instr x let code = registerCode register tmp src = registerName register tmp - code__2 dst = code . mkSeqInstr (instr src dst) + code__2 dst = code `snocOL` instr src dst in returnNat (Any pk code__2) @@ -3105,7 +3120,7 @@ coerceInt2FP pk x code = registerCode register reg src = registerName register reg - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ ST W src (spRel (-2)), LD W (spRel (-2)) dst, FxTOy W (primRepToSize pk) dst dst] @@ -3122,7 +3137,7 @@ coerceFP2Int x src = registerName register reg pk = registerRep register - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ FxTOy (primRepToSize pk) W src tmp, ST W tmp (spRel (-2)), LD W (spRel (-2)) dst] @@ -3186,11 +3201,11 @@ chrCode (StInd pk mem) src_off = addrOffset src 3 src__2 = case src_off of Just x -> x code__2 dst = if maybeToBool src_off then - code . mkSeqInstr (LD BU src__2 dst) + code `snocOL` LD BU src__2 dst else - code . mkSeqInstrs [ - LD (primRepToSize pk) src dst, - AND False dst (RIImm (ImmInt 255)) dst] + code `snocOL` + LD (primRepToSize pk) src dst `snocOL` + AND False dst (RIImm (ImmInt 255)) dst in returnNat (Any pk code__2) @@ -3200,7 +3215,7 @@ chrCode x let code = registerCode register reg src = registerName register reg - code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst) + code__2 dst = code `snocOL` AND False src (RIImm (ImmInt 255)) dst in returnNat (Any IntRep code__2) diff --git a/ghc/compiler/nativeGen/MachMisc.hi-boot b/ghc/compiler/nativeGen/MachMisc.hi-boot index 242c93a..1c7bef4 100644 --- a/ghc/compiler/nativeGen/MachMisc.hi-boot +++ b/ghc/compiler/nativeGen/MachMisc.hi-boot @@ -5,4 +5,4 @@ _declarations_ 1 fixedHdrSize _:_ PrelBase.Int ;; 2 fmtAsmLbl _:_ PrelBase.String -> PrelBase.String ;; 1 underscorePrefix _:_ PrelBase.Bool ;; -1 data Instr; \ No newline at end of file +1 data Instr ;; \ No newline at end of file diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index ddbc1fd..c1eb869 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -33,7 +33,7 @@ module MachMisc ( #if i386_TARGET_ARCH #endif #if sparc_TARGET_ARCH - , RI(..), riZero + RI(..), riZero #endif ) where diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 2b5b41e..c521ad9 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -14,7 +14,7 @@ module Stix ( fixedHS, arrWordsHS, arrPtrsHS, NatM, initNat, thenNat, returnNat, - mapNat, mapAndUnzipNat, + mapNat, mapAndUnzipNat, mapAccumLNat, getUniqueNat, getDeltaNat, setDeltaNat, NatM_State, mkNatM_State, uniqOfNatM_State, deltaOfNatM_State, @@ -362,6 +362,18 @@ mapAndUnzipNat f (x:xs) mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) -> returnNat (r1:rs1, r2:rs2) +mapAccumLNat :: (acc -> x -> NatM (acc, y)) + -> acc + -> [x] + -> NatM (acc, [y]) + +mapAccumLNat f b [] + = returnNat (b, []) +mapAccumLNat f b (x:xs) + = f b x `thenNat` \ (b__2, x__2) -> + mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) -> + returnNat (b__3, x__2:xs__2) + getUniqueNat :: NatM Unique getUniqueNat (NatM_State us delta)