Commit 8252a068 authored by sewardj's avatar sewardj
Browse files

[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.
parent ffb4740c
......@@ -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 )
......
......@@ -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,<n>),
-- 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
......
......@@ -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 :-)
......
......@@ -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
......
......@@ -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
......
......@@ -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"
......
......@@ -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}
......@@ -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)]
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment