From: sewardj Date: Fri, 28 Jan 2000 09:40:06 +0000 (+0000) Subject: [project @ 2000-01-28 09:40:05 by sewardj] X-Git-Tag: Approximately_9120_patches~5181 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=8252a068d95fa49040f6c55ed170f9155416e8ac;p=ghc-hetmet.git [project @ 2000-01-28 09:40:05 by sewardj] Commit all changes prior to addressing the x86 spilling situation in the register allocator. -- Fix nonsensical x86 addressing mode hacks in mangleIndexTree and getAmode. -- Make char-sized loads work properly, using MOVZBL. -- In assignIntCode, use primRep on the assign node to determine the size of data transfer, not the size of the source. -- Redo Integer primitives to be in line with current representation of Integers. --- diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index 7da3a0b..aa5d4e4 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -22,8 +22,9 @@ import AsmRegAlloc ( runRegAllocate ) import OrdList ( OrdList ) import PrimOp ( commutableOp, PrimOp(..) ) import RegAllocInfo ( mkMRegsState, MRegsState ) -import Stix ( StixTree(..), StixReg(..), pprStixTrees ) -import PrimRep ( isFloatingRep ) +import Stix ( StixTree(..), StixReg(..), + pprStixTrees, CodeSegment(..) ) +import PrimRep ( isFloatingRep, PrimRep(..) ) import UniqSupply ( returnUs, thenUs, mapUs, initUs, initUs_, UniqSM, UniqSupply ) import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM ) diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index e3f3dcc..a4bd777 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -27,12 +27,14 @@ import PrimRep ( isFloatingRep, PrimRep(..) ) import PrimOp ( PrimOp(..) ) import CallConv ( cCallConv ) import Stix ( getUniqLabelNCG, StixTree(..), - StixReg(..), CodeSegment(..), pprStixTrees + StixReg(..), CodeSegment(..), + pprStixTrees, ppStixReg ) import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs, mapAccumLUs, UniqSM ) import Outputable +import PprMach ( pprSize ) \end{code} Code extractor for an entire stix tree---stix statement level. @@ -44,30 +46,7 @@ stmt2Instrs stmt = case stmt of StComment s -> returnInstr (COMMENT s) StSegment seg -> returnInstr (SEGMENT seg) -#if 1 - -- StFunBegin, normal non-debugging code for all architectures StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab)) -#else - -- StFunBegin, special tracing code for x86-Linux only - -- requires you to supply - -- void native_trace ( char* str ) - StFunBegin lab -> getUniqLabelNCG `thenUs` \ str_lbl -> - returnUs (mkSeqInstrs [ - LABEL lab, - COMMENT SLIT("begin trace sequence"), - SEGMENT DataSegment, - LABEL str_lbl, - ASCII True (showSDoc (pprCLabel_asm lab)), - SEGMENT TextSegment, - PUSHA, - PUSH L (OpImm (ImmCLbl str_lbl)), - CALL (ImmLit (text "native_trace")), - ADD L (OpImm (ImmInt 4)) (OpReg esp), - POPA, - COMMENT SLIT("end trace sequence") - ]) -#endif - StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id) StLabel lab -> returnInstr (LABEL lab) @@ -152,29 +131,17 @@ mangleIndexTree (StIndex pk base (StInt i)) where off = StInt (i * sizeOf pk) -#ifndef i386_TARGET_ARCH mangleIndexTree (StIndex pk base off) - = StPrim IntAddOp [base, - case pk of - CharRep -> off - _ -> let - s = shift pk - in - ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk))) - StPrim SllOp [off, StInt s] - ] + = StPrim IntAddOp [ + base, + let s = shift pk + in ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk))) + if s == 0 then off else StPrim SllOp [off, StInt s] + ] where shift DoubleRep = 3::Integer + shift CharRep = 0::Integer shift _ = IF_ARCH_alpha(3,2) -#else --- Hmm..this is an attempt at fixing Adress amodes (i.e., *[disp](base,index,), --- that do include the size of the primitive kind we're addressing. When StIndex --- is expanded to actual code, the index (in units) is by the above code approp. --- shifted to get the no. of bytes. Since Address amodes do contain size info --- explicitly, we disable the shifting for x86s. -mangleIndexTree (StIndex pk base off) = StPrim IntAddOp [base, off] -#endif - \end{code} \begin{code} @@ -517,6 +484,9 @@ getRegister (StDouble d) in returnUs (Any DoubleRep code) +getRegister (StScratchWord i) + = let code dst = mkSeqInstr (LEA L (OpAddr (spRel (-1000+i))) (OpReg dst)) + in returnUs (Any PtrRep code) getRegister (StPrim primop [x]) -- unary PrimOps = case primop of @@ -580,6 +550,10 @@ getRegister (StPrim primop [x]) -- unary PrimOps DoubleCoshOp -> (False, SLIT("cosh")) DoubleTanhOp -> (False, SLIT("tanh")) + other + -> pprPanic "getRegister(x86,unary primop)" + (pprStixTrees [StPrim primop [x]]) + getRegister (StPrim primop [x, y]) -- dyadic PrimOps = case primop of CharGtOp -> condIntReg GTT x y @@ -624,15 +598,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps DoubleLtOp -> condFltReg LTT x y DoubleLeOp -> condFltReg LE x y - IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)... - -- this should be optimised by the generic Opts, - -- I don't know why it is not (sometimes)! - case args of - [x, StInt 0] -> getRegister x - _ -> add_code L x y - -} - add_code L x y - + IntAddOp -> add_code L x y IntSubOp -> sub_code L x y IntQuotOp -> quot_code L x y True{-division-} IntRemOp -> quot_code L x y False{-remainder-} @@ -669,6 +635,9 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps where promote x = StPrim Float2DoubleOp [x] DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y]) + other + -> pprPanic "getRegister(x86,dyadic primop)" + (pprStixTrees [StPrim primop [x, y]]) where -------------------- @@ -743,7 +712,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps src2 = ImmInt (fromInteger y) code__2 dst = code . - mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) + mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst)) in returnUs (Any IntRep code__2) @@ -891,7 +860,6 @@ getRegister leaf returnUs (Any PtrRep code) | otherwise = pprPanic "getRegister(x86)" (pprStixTrees [leaf]) - where imm = maybeImm leaf imm__2 = case imm of Just x -> x @@ -1182,7 +1150,8 @@ getAmode (StPrim IntAddOp [x, StInt i]) in returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code) -getAmode (StPrim IntAddOp [x, y]) +getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]]) + | shift == 0 || shift == 1 || shift == 2 || shift == 3 = getNewRegNCG PtrRep `thenUs` \ tmp1 -> getNewRegNCG IntRep `thenUs` \ tmp2 -> getRegister x `thenUs` \ register1 -> @@ -1193,8 +1162,10 @@ getAmode (StPrim IntAddOp [x, y]) code2 = registerCode register2 tmp2 asmVoid reg2 = registerName register2 tmp2 code__2 = asmParThen [code1, code2] + base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8 in - returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2) + returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0)) + code__2) getAmode leaf | maybeToBool imm @@ -1609,24 +1580,24 @@ assignIntCode pk dst src -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -assignIntCode pk (StInd _ dst) src +assignIntCode pk dd@(StInd _ dst) src = getAmode dst `thenUs` \ amode -> - get_op_RI src `thenUs` \ (codesrc, opsrc, sz) -> + get_op_RI src `thenUs` \ (codesrc, opsrc) -> let code1 = amodeCode amode asmVoid dst__2 = amodeAddr amode code__2 = asmParThen [code1, codesrc asmVoid] . - mkSeqInstr (MOV sz opsrc (OpAddr dst__2)) + mkSeqInstr (MOV (primRepToSize pk) opsrc (OpAddr dst__2)) in returnUs code__2 where get_op_RI :: StixTree - -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size + -> UniqSM (InstrBlock,Operand) -- code, operator get_op_RI op | maybeToBool imm - = returnUs (asmParThen [], OpImm imm_op, L) + = returnUs (asmParThen [], OpImm imm_op) where imm = maybeImm op imm_op = case imm of Just x -> x @@ -1638,12 +1609,10 @@ assignIntCode pk (StInd _ dst) src let code = registerCode register tmp reg = registerName register tmp - pk = registerRep register - sz = primRepToSize pk in - returnUs (code, OpReg reg, sz) + returnUs (code, OpReg reg) -assignIntCode pk dst (StInd _ src) +assignIntCode pk dst (StInd pks src) = getNewRegNCG IntRep `thenUs` \ tmp -> getAmode src `thenUs` \ amode -> getRegister dst `thenUs` \ register -> @@ -1652,9 +1621,11 @@ assignIntCode pk dst (StInd _ src) src__2 = amodeAddr amode code2 = registerCode register tmp asmVoid dst__2 = registerName register tmp - sz = primRepToSize pk + szs = primRepToSize pks code__2 = asmParThen [code1, code2] . - mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2)) + case szs of + L -> mkSeqInstr (MOV L (OpAddr src__2) (OpReg dst__2)) + B -> mkSeqInstr (MOVZxL B (OpAddr src__2) (OpReg dst__2)) in returnUs code__2 @@ -3056,7 +3027,6 @@ chrCode x chrCode x = getRegister x `thenUs` \ register -> - --getNewRegNCG IntRep `thenUs` \ reg -> let code__2 dst = let code = registerCode register dst diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index 867495b..d31af20 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -320,7 +320,7 @@ primRepToSize CodePtrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( primRepToSize DataPtrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) primRepToSize RetRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) primRepToSize CostCentreRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) -primRepToSize CharRep = IF_ARCH_alpha( BU, IF_ARCH_i386( L, IF_ARCH_sparc( BU,))) +primRepToSize CharRep = IF_ARCH_alpha( BU, IF_ARCH_i386( B, IF_ARCH_sparc( BU,))) primRepToSize IntRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) primRepToSize WordRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) primRepToSize AddrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,))) @@ -478,8 +478,8 @@ current translation. -- Moves. | MOV Size Operand Operand - | MOVZX Size Operand Operand -- size is the size of operand 2 - | MOVSX Size Operand Operand -- size is the size of operand 2 + | MOVZxL Size Operand Operand -- size is the size of operand 1 + | MOVSxL Size Operand Operand -- size is the size of operand 1 -- Load effective address (also a very useful three-operand add instruction :-) diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 7f72f4d..e35e22c 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -10,7 +10,7 @@ We start with the @pprXXX@s with some cross-platform commonality \begin{code} #include "nativeGen/NCG.h" -module PprMach ( pprInstr ) where +module PprMach ( pprInstr, pprSize ) where #include "HsVersions.h" @@ -398,11 +398,10 @@ pprInstr (COMMENT s) ,))) pprInstr (SEGMENT TextSegment) - = ptext - IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-} - ,IF_ARCH_sparc(SLIT("\t.text\n\t.align 4") {-word boundary-} - ,IF_ARCH_i386(SLIT(".text\n\t.align 4,0x90") {-needs per-OS variation!-} - ,))) + = IF_ARCH_alpha(ptext SLIT("\t.text\n\t.align 3") {-word boundary-} + ,IF_ARCH_sparc(ptext SLIT("\t.text\n\t.align 4") {-word boundary-} + ,IF_ARCH_i386((text ".text\n\t.align 4,0x90") {-needs per-OS variation!-} + ,))) pprInstr (SEGMENT DataSegment) = ptext @@ -946,8 +945,8 @@ pprInstr v@(MOV size s@(OpReg src) d@(OpReg dst)) -- hack #endif pprInstr (MOV size src dst) = pprSizeOpOp SLIT("mov") size src dst -pprInstr (MOVZX size src dst) = pprSizeOpOpCoerce SLIT("movzx") L size src dst -pprInstr (MOVSX size src dst) = pprSizeOpOpCoerce SLIT("movxs") L size src dst +pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce SLIT("movz") sizes L src dst +pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce SLIT("movs") sizes L src dst -- here we do some patching, since the physical registers are only set late -- in the code generation. @@ -1084,6 +1083,7 @@ gtab = char '\t' gsp = char ' ' gregno (FixedReg i) = I# i gregno (MappedReg i) = I# i +gregno other = pprPanic "gregno" (text (show other)) pprG :: Instr -> SDoc -> SDoc pprG fake actual @@ -1255,7 +1255,7 @@ pprOpOp name size op1 op2 pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> SDoc pprSizeOpOpCoerce name size1 size2 op1 op2 - = hcat [ char '\t', ptext name, space, + = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space, pprOperand size1 op1, comma, pprOperand size2 op2 diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs index ac015fe..eab566c 100644 --- a/ghc/compiler/nativeGen/RegAllocInfo.lhs +++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs @@ -355,8 +355,8 @@ regUsage instr = case instr of regUsage instr = case instr of MOV sz src dst -> usage2 src dst - MOVZX sz src dst -> usage2 src dst - MOVSX sz src dst -> usage2 src dst + MOVZxL sz src dst -> usage2 src dst + MOVSxL sz src dst -> usage2 src dst LEA sz src dst -> usage2 src dst ADD sz src dst -> usage2 src dst SUB sz src dst -> usage2 src dst @@ -409,7 +409,7 @@ regUsage instr = case instr of LABEL _ -> noUsage ASCII _ _ -> noUsage DATA _ _ -> noUsage - _ -> error ("regUsage: " ++ showSDoc (pprInstr instr)) --noUsage + _ -> error ("regUsage(x86): " ++ showSDoc (pprInstr instr)) where usage2 :: Operand -> Operand -> RegUsage usage2 op (OpReg reg) = usage (opToReg op) [reg] @@ -640,8 +640,8 @@ patchRegs instr env = case instr of patchRegs instr env = case instr of MOV sz src dst -> patch2 (MOV sz) src dst - MOVZX sz src dst -> patch2 (MOVZX sz) src dst - MOVSX sz src dst -> patch2 (MOVSX sz) src dst + MOVZxL sz src dst -> patch2 (MOVZxL sz) src dst + MOVSxL sz src dst -> patch2 (MOVSxL sz) src dst LEA sz src dst -> patch2 (LEA sz) src dst ADD sz src dst -> patch2 (ADD sz) src dst SUB sz src dst -> patch2 (SUB sz) src dst diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index e5dd49d..3b297a8 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -5,7 +5,7 @@ \begin{code} module Stix ( CodeSegment(..), StixReg(..), StixTree(..), StixTreeList, - sStLitLbl, pprStixTrees, + sStLitLbl, pprStixTrees, ppStixReg, stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim, stgTagReg, stgR9, stgR10, @@ -100,6 +100,14 @@ data StixTree | StCall FAST_STRING CallConv PrimRep [StixTree] + -- A volatile memory scratch array, which is allocated + -- relative to the stack pointer. It is an array of + -- ptr/word/int sized things. Do not expect to be preserved + -- beyond basic blocks or over a ccall. Current max size + -- is 6, used in StixInteger. + + | StScratchWord Int + -- Assembly-language comments | StComment FAST_STRING @@ -146,8 +154,9 @@ ppStixTree t StCall nm cc k args -> paren (text "Call" <+> ptext nm <+> pprCallConv cc <+> pprPrimRep k <+> hsep (map ppStixTree args)) - where - pprPrimRep = text . showPrimRep + StScratchWord i -> text "ScratchWord" <> paren (int i) + +pprPrimRep = text . showPrimRep \end{code} Stix registers can have two forms. They {\em may} or {\em may not} @@ -167,10 +176,10 @@ ppStixReg (StixTemp u pr) ppMId BaseReg = text "BaseReg" -ppMId (VanillaReg kind n) = hcat [text "IntReg(", int (I# n), char ')'] +ppMId (VanillaReg kind n) = hcat [pprPrimRep kind, text "IntReg(", int (I# n), char ')'] ppMId (FloatReg n) = hcat [text "FltReg(", int (I# n), char ')'] ppMId (DoubleReg n) = hcat [text "DblReg(", int (I# n), char ')'] -ppMId (LongReg kind n) = hcat [text "LongReg(", int (I# n), char ')'] +ppMId (LongReg kind n) = hcat [pprPrimRep kind, text "LongReg(", int (I# n), char ')'] ppMId Sp = text "Sp" ppMId Su = text "Su" ppMId SpLim = text "SpLim" diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index 044548c..fbd96cf 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -5,9 +5,10 @@ \begin{code} module StixInteger ( gmpCompare, + gmpCompareInt, gmpInteger2Int, gmpInteger2Word, - gmpNegate + gmpNegate ) where #include "HsVersions.h" @@ -23,7 +24,7 @@ import OrdList ( OrdList ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) import SMRep ( arrWordsHdrSize ) -import Stix ( sStLitLbl, StixTree(..), StixTreeList ) +import Stix ( sStLitLbl, StixTree(..), StixTreeList, arrWordsHS ) import UniqSupply ( returnUs, thenUs, UniqSM ) \end{code} @@ -33,23 +34,30 @@ enclosing routine has already guaranteed that this space will be available. (See ``primOpHeapRequired.'') \begin{code} +stgArrWords__words :: StixTree -> StixTree +stgArrWords__BYTE_ARR_CTS :: StixTree -> StixTree + +stgArrWords__BYTE_ARR_CTS arr + = StIndex WordRep arr arrWordsHS +stgArrWords__words arr + = case arrWordsHS of + StInt i -> StInd WordRep (StIndex PtrRep arr (StInt (i-1))) + gmpCompare :: CAddrMode -- result (boolean) - -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) - -- alloc hp + 2 arguments (3 parts each) + -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode) + -- alloc hp + 2 arguments (2 parts each) -> UniqSM StixTreeList -gmpCompare res args@(caa1,csa1,cda1, caa2,csa2,cda2) +gmpCompare res args@(csa1,cda1, csa2,cda2) = let result = amodeToStix res - scratch1 = scratch_space - scratch2 = StIndex IntRep scratch_space (StInt (toInteger mpIntSize)) - aa1 = amodeToStix caa1 sa1 = amodeToStix csa1 - da1 = amodeToStix cda1 - aa2 = amodeToStix caa2 sa2 = amodeToStix csa2 - da2 = amodeToStix cda2 + aa1 = stgArrWords__words (amodeToStix cda1) + aa2 = stgArrWords__words (amodeToStix cda2) + da1 = stgArrWords__BYTE_ARR_CTS (amodeToStix cda1) + da2 = stgArrWords__BYTE_ARR_CTS (amodeToStix cda2) (a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1) (a4,a5,a6) = toStruct scratch2 (aa2,sa2,da2) @@ -57,58 +65,77 @@ gmpCompare res args@(caa1,csa1,cda1, caa2,csa2,cda2) r1 = StAssign IntRep result mpz_cmp in returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs) + + +gmpCompareInt + :: CAddrMode -- result (boolean) + -> (CAddrMode,CAddrMode,CAddrMode) + -> UniqSM StixTreeList -- alloc hp + 1 arg (??) + +gmpCompareInt res args@(csa1,cda1, cai) + = let + result = amodeToStix res + sa1 = amodeToStix csa1 + aa1 = stgArrWords__words (amodeToStix cda1) + da1 = stgArrWords__BYTE_ARR_CTS (amodeToStix cda1) + ai = amodeToStix cai + (a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1) + mpz_cmp_si = StCall SLIT("mpz_cmp_si") cCallConv IntRep [scratch1, ai] + r1 = StAssign IntRep result mpz_cmp_si + in + returnUs (\xs -> a1 : a2 : a3 : r1 : xs) \end{code} \begin{code} gmpInteger2Int :: CAddrMode -- result - -> (CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts) + -> (CAddrMode,CAddrMode) -- alloc hp + argument (2 parts) -> UniqSM StixTreeList -gmpInteger2Int res args@(caa,csa,cda) +gmpInteger2Int res args@(csa,cda) = let result = amodeToStix res - aa = amodeToStix caa sa = amodeToStix csa - da = amodeToStix cda + aa = stgArrWords__words (amodeToStix cda) + da = stgArrWords__BYTE_ARR_CTS (amodeToStix cda) - (a1,a2,a3) = toStruct scratch_space (aa,sa,da) - mpz_get_si = StCall SLIT("mpz_get_si") cCallConv IntRep [scratch_space] + (a1,a2,a3) = toStruct scratch1 (aa,sa,da) + mpz_get_si = StCall SLIT("mpz_get_si") cCallConv IntRep [scratch1] r1 = StAssign IntRep result mpz_get_si in returnUs (\xs -> a1 : a2 : a3 : r1 : xs) gmpInteger2Word :: CAddrMode -- result - -> (CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts) + -> (CAddrMode,CAddrMode) -- alloc hp + argument (2 parts) -> UniqSM StixTreeList -gmpInteger2Word res args@(caa,csa,cda) +gmpInteger2Word res args@(csa,cda) = let result = amodeToStix res - aa = amodeToStix caa sa = amodeToStix csa - da = amodeToStix cda + aa = stgArrWords__words (amodeToStix cda) + da = stgArrWords__BYTE_ARR_CTS (amodeToStix cda) - (a1,a2,a3) = toStruct scratch_space (aa,sa,da) - mpz_get_ui = StCall SLIT("mpz_get_ui") cCallConv IntRep [scratch_space] + (a1,a2,a3) = toStruct scratch1 (aa,sa,da) + mpz_get_ui = StCall SLIT("mpz_get_ui") cCallConv IntRep [scratch1] r1 = StAssign WordRep result mpz_get_ui in returnUs (\xs -> a1 : a2 : a3 : r1 : xs) gmpNegate - :: (CAddrMode,CAddrMode,CAddrMode) -- result - -> (CAddrMode,CAddrMode,CAddrMode) -- argument (3 parts) + :: (CAddrMode,CAddrMode) -- result + -> (CAddrMode,CAddrMode) -- argument (2 parts) -> UniqSM StixTreeList -gmpNegate (rca, rcs, rcd) args@(ca, cs, cd) +gmpNegate (rcs, rcd) args@(cs, cd) = let - a = amodeToStix ca s = amodeToStix cs - d = amodeToStix cd - ra = amodeToStix rca + a = stgArrWords__words (amodeToStix cd) + d = stgArrWords__BYTE_ARR_CTS (amodeToStix cd) rs = amodeToStix rcs - rd = amodeToStix rcd + ra = stgArrWords__words (amodeToStix rcd) + rd = stgArrWords__BYTE_ARR_CTS (amodeToStix rcd) a1 = StAssign IntRep ra a a2 = StAssign IntRep rs (StPrim IntNegOp [s]) a3 = StAssign PtrRep rd d @@ -138,11 +165,11 @@ toStruct str (alloc,size,arr) = let f1 = StAssign IntRep (mpAlloc str) alloc f2 = StAssign IntRep (mpSize str) size - f3 = StAssign PtrRep (mpData str) - (StIndex PtrRep arr (StInt (toInteger arrWordsHdrSize))) + f3 = StAssign PtrRep (mpData str) arr in (f1, f2, f3) -scratch_space = sStLitLbl SLIT("stg_scratch_space") +scratch1 = StScratchWord 0 +scratch2 = StScratchWord mpIntSize \end{code} diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 8cb3594..2d86439 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -53,19 +53,20 @@ and modify our heap check accordingly. \begin{code} -- NB: ordering of clauses somewhere driven by -- the desire to getting sane patt-matching behavior -primCode res@[ar,sr,dr] IntegerNegOp arg@[aa,sa,da] - = gmpNegate (ar,sr,dr) (aa,sa,da) -\end{code} +primCode res@[sr,dr] IntegerNegOp arg@[sa,da] + = gmpNegate (sr,dr) (sa,da) -\begin{code} -primCode [res] IntegerCmpOp args@[aa1,sa1,da1, aa2,sa2,da2] - = gmpCompare res (aa1,sa1,da1, aa2,sa2,da2) +primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2] + = gmpCompare res (sa1,da1, sa2,da2) + +primCode [res] IntegerCmpIntOp args@[sa1,da1,ai] + = gmpCompareInt res (sa1,da1,ai) -primCode [res] Integer2IntOp arg@[aa,sa,da] - = gmpInteger2Int res (aa,sa,da) +primCode [res] Integer2IntOp arg@[sa,da] + = gmpInteger2Int res (sa,da) -primCode [res] Integer2WordOp arg@[aa,sa,da] - = gmpInteger2Word res (aa,sa,da) +primCode [res] Integer2WordOp arg@[sa,da] + = gmpInteger2Word res (sa,da) primCode [res] Int2AddrOp [arg] = simpleCoercion AddrRep res arg @@ -350,7 +351,7 @@ amodeToStix (CCharLike (CLit (MachChar c))) off = charLikeSize * ord c amodeToStix (CCharLike x) - = StIndex PtrRep charLike off + = StIndex CharRep charLike off where off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]