d0p1/ack
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Add a test (currently failing) to check that Pascal char sets can store all 256

Browse source 
possible values. Add the PowerPC ncg and mcg backend support to let the test
actually run, including modifying a bunch of PowrePC libem functions so that
they can be called from both ncg and mcg.
This commit is contained in:
David Given 2017-01-15 22:28:14 +01:00
parent 1ea46f6afe
commit e7e29d34ff
10 changed files with 218 additions and 130 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
mach/powerpc/libem/ior.s
View file

@ -3,11 +3,13 @@
.sect .text .sect .text
! Set union. ! Set union.
! Stack: ( b a -- a+b ) ! Stack: ( size b a -- a+b )
! With r3 = size of set
.define .ior .define .ior
.ior: .ior:
lwz r3, 0 (sp)
addi sp, sp, 4
mr r4, sp ! r4 = ptr to set a mr r4, sp ! r4 = ptr to set a
add r5, sp, r3 ! r5 = ptr to set b add r5, sp, r3 ! r5 = ptr to set b
rlwinm r6, r3, 30, 2, 31 rlwinm r6, r3, 30, 2, 31

22
mach/powerpc/libem/rck.s Normal file
View file

@ -0,0 +1,22 @@
#include "powerpc.h"
.sect .text
! Bounds check. Traps if the value is out of range.
! Stack: ( descriptor value -- )
.define .rck
.rck:
lwz r3, 0 (sp)
lwz r4, 4 (sp)
addi sp, sp, 8
lwz r5, 0 (r3)
cmp cr0, 0, r4, r5
bc IFTRUE, LT, .trap_erange
lwz r5, 4 (r3)
cmp cr0, 0, r4, r5
bc IFTRUE, GT, .trap_erange
bclr ALWAYS, 0, 0

7
mach/powerpc/libem/set.s
View file

@ -3,11 +3,14 @@
.sect .text .sect .text
! Create singleton set. ! Create singleton set.
! Stack: ( -- set ) ! Stack: ( size bitnumber -- set )
! With r3 = size of set, r4 = bit number
.define .set .define .set
.set: .set:
lwz r3, 0 (sp)
lwz r4, 4 (sp)
addi sp, sp, 8
rlwinm r7, r3, 30, 2, 31 rlwinm r7, r3, 30, 2, 31
neg r5, r3 neg r5, r3
add sp, sp, r5 ! allocate set add sp, sp, r5 ! allocate set

6
mach/powerpc/libem/zer.s
View file

@ -3,11 +3,13 @@
.sect .text .sect .text
! Create empty set. ! Create empty set.
! Stack: ( -- set ) ! Stack: ( size -- set )
! With r3 = size of set
.define .zer .define .zer
.zer: .zer:
lwz r3, 0(sp)
addi sp, sp, 4
rlwinm r7, r3, 30, 2, 31 rlwinm r7, r3, 30, 2, 31
addi r4, r0, 0 ! r4 = zero addi r4, r0, 0 ! r4 = zero
neg r5, r3 neg r5, r3

58
mach/powerpc/ncg/table
View file

@ -1503,18 +1503,14 @@ PATTERNS
yields {OR_RC, %2, lo(%1.val)} yields {OR_RC, %2, lo(%1.val)}
pat ior defined($1) /* OR set */ pat ior defined($1) /* OR set */
with STACK leaving
kills ALL loc $1
gen cal ".ior"
move {CONST, $1}, R3
bl {LABEL, ".ior"}
/* OR set (variable), used in lang/m2/libm2/LtoUset.e */ /* OR set (variable), used in lang/m2/libm2/LtoUset.e */
pat ior !defined($1) pat ior !defined($1)
with GPR3 STACK leaving
kills ALL cal ".ior"
gen
bl {LABEL, ".ior"}
pat xor $1==4 /* XOR word */ pat xor $1==4 /* XOR word */
with REG REG with REG REG
@ -1572,12 +1568,10 @@ PATTERNS
leaving leaving
loc 0 loc 0
pat zer defined($1) /* Create empty set */ pat zer defined($1) /* Create empty set */
with STACK leaving
kills ALL loc $1
gen cal ".zer"
move {CONST, $1}, R3
bl {LABEL, ".zer"}
pat sli $1==4 /* Shift left (second << top) */ pat sli $1==4 /* Shift left (second << top) */
with CONST_ALL GPR with CONST_ALL GPR
@ -1655,27 +1649,19 @@ PATTERNS
/* Sets */ /* Sets */
pat set defined($1) /* Create singleton set */ pat set defined($1) /* Create singleton set */
with GPR4 STACK leaving
kills ALL loc $1
gen cal ".set"
move {CONST, $1}, R3
bl {LABEL, ".set"}
/* Create set (variable), used in lang/m2/libm2/LtoUset.e */ /* Create set (variable), used in lang/m2/libm2/LtoUset.e */
pat set !defined($1) pat set !defined($1)
with GPR3 GPR4 STACK leaving
kills ALL cal ".set"
gen
bl {LABEL, ".set"}
pat inn defined($1) /* Test for set bit */ pat inn defined($1) /* Test for set bit */
with STACK leaving
kills ALL loc $1
uses REG cal ".inn"
gen
li32 %a, {CONST, $1}
stwu %a, {GPRINDIRECT, SP, 0-4}
bl {LABEL, ".inn"}
/* Boolean resolutions */ /* Boolean resolutions */
@ -2066,6 +2052,16 @@ PATTERNS
loc $1 loc $1
ass 4 ass 4
pat lae rck $2==4 /* Range check */
with GPR
uses CR0
gen
cmpli %a, {CONST, 0}, %1, {CONST, rom($1, 1)}
bc IFTRUE, LT, {LABEL, ".trap_erange"}
cmpli %a, {CONST, 0}, %1, {CONST, rom($1, 2)}
bc IFTRUE, GT, {LABEL, ".trap_erange"}
/* Floating point support */ /* Floating point support */

185
mach/proto/mcg/treebuilder.c
View file

@ -66,7 +66,7 @@ static struct ir* pop(int size)
#if 0 #if 0
/* If we try to pop something which is smaller than a word, convert it first. */ /* If we try to pop something which is smaller than a word, convert it first. */
if (size < EM_wordsize) if (size < EM_wordsize)
ir = convertu(ir, size); ir = convertu(ir, size);
#endif #endif
@ -200,7 +200,7 @@ static struct ir* address_of_external(const char* label, arith offset)
static struct ir* convert(struct ir* src, int srcsize, int destsize, int opcode) static struct ir* convert(struct ir* src, int srcsize, int destsize, int opcode)
{ {
if (srcsize == 1) if (srcsize == 1)
{ {
if ((opcode == IR_FROMSI) || (opcode == IR_FROMSL)) if ((opcode == IR_FROMSI) || (opcode == IR_FROMSL))
{ {
@ -433,7 +433,7 @@ static void insn_simple(int opcode)
); );
break; break;
} }
case op_cii: simple_convert(IR_FROMSI); break; case op_cii: simple_convert(IR_FROMSI); break;
case op_ciu: simple_convert(IR_FROMSI); break; case op_ciu: simple_convert(IR_FROMSI); break;
case op_cui: simple_convert(IR_FROMUI); break; case op_cui: simple_convert(IR_FROMUI); break;
@ -528,10 +528,12 @@ static void insn_simple(int opcode)
} }
/* FIXME: These instructions are really complex and barely used /* FIXME: These instructions are really complex and barely used
* (Modula-2 bitset support, I believe). Leave them until later. */ * (Modula-2 and Pascal set support, I believe). Leave them until
* later. */
case op_set: helper_function(".unimplemented_set"); break; case op_set: helper_function(".unimplemented_set"); break;
case op_ior: helper_function(".unimplemented_ior"); break; case op_ior: helper_function(".unimplemented_ior"); break;
case op_dch: case op_dch:
push( push(
new_ir1( new_ir1(
@ -540,7 +542,7 @@ static void insn_simple(int opcode)
) )
); );
break; break;
case op_lpb: case op_lpb:
push( push(
new_ir1( new_ir1(
@ -607,29 +609,53 @@ static void insn_bvalue(int opcode, struct basicblock* leftbb, struct basicblock
} }
} }
static void simple_alu1(int opcode, int size, int irop) static void simple_alu1(int opcode, int size, int irop, const char* fallback)
{ {
struct ir* val = pop(size); if (size > (2*EM_wordsize))
{
if (!fallback)
fatal("treebuilder: can't do opcode %d with size %d", opcode, size);
push(
new_wordir(size)
);
helper_function(fallback);
}
else
{
struct ir* val = pop(size);
push( push(
new_ir1( new_ir1(
irop, size, irop, size,
val val
) )
); );
}
} }
static void simple_alu2(int opcode, int size, int irop) static void simple_alu2(int opcode, int size, int irop, const char* fallback)
{ {
struct ir* right = pop(size); if (size > (2*EM_wordsize))
struct ir* left = pop(size); {
if (!fallback)
fatal("treebuilder: can't do opcode %d with size %d", opcode, size);
push(
new_wordir(size)
);
helper_function(fallback);
}
else
{
struct ir* right = pop(size);
struct ir* left = pop(size);
push( push(
new_ir2( new_ir2(
irop, size, irop, size,
left, right left, right
) )
); );
}
} }
static struct ir* extract_block_refs(struct basicblock* bb) static struct ir* extract_block_refs(struct basicblock* bb)
@ -708,39 +734,43 @@ static void insn_ivalue(int opcode, arith value)
{ {
switch (opcode) switch (opcode)
{ {
case op_adi: simple_alu2(opcode, value, IR_ADD); break; case op_adi: simple_alu2(opcode, value, IR_ADD, NULL); break;
case op_sbi: simple_alu2(opcode, value, IR_SUB); break; case op_sbi: simple_alu2(opcode, value, IR_SUB, NULL); break;
case op_mli: simple_alu2(opcode, value, IR_MUL); break; case op_mli: simple_alu2(opcode, value, IR_MUL, NULL); break;
case op_dvi: simple_alu2(opcode, value, IR_DIV); break; case op_dvi: simple_alu2(opcode, value, IR_DIV, NULL); break;
case op_rmi: simple_alu2(opcode, value, IR_MOD); break; case op_rmi: simple_alu2(opcode, value, IR_MOD, NULL); break;
case op_sli: simple_alu2(opcode, value, IR_ASL); break; case op_sli: simple_alu2(opcode, value, IR_ASL, NULL); break;
case op_sri: simple_alu2(opcode, value, IR_ASR); break; case op_sri: simple_alu2(opcode, value, IR_ASR, NULL); break;
case op_ngi: simple_alu1(opcode, value, IR_NEG); break; case op_ngi: simple_alu1(opcode, value, IR_NEG, NULL); break;
case op_adu: simple_alu2(opcode, value, IR_ADD); break; case op_adu: simple_alu2(opcode, value, IR_ADD, NULL); break;
case op_sbu: simple_alu2(opcode, value, IR_SUB); break; case op_sbu: simple_alu2(opcode, value, IR_SUB, NULL); break;
case op_mlu: simple_alu2(opcode, value, IR_MUL); break; case op_mlu: simple_alu2(opcode, value, IR_MUL, NULL); break;
case op_slu: simple_alu2(opcode, value, IR_LSL); break; case op_slu: simple_alu2(opcode, value, IR_LSL, NULL); break;
case op_sru: simple_alu2(opcode, value, IR_LSR); break; case op_sru: simple_alu2(opcode, value, IR_LSR, NULL); break;
case op_rmu: simple_alu2(opcode, value, IR_MODU); break; case op_rmu: simple_alu2(opcode, value, IR_MODU, NULL); break;
case op_dvu: simple_alu2(opcode, value, IR_DIVU); break; case op_dvu: simple_alu2(opcode, value, IR_DIVU, NULL); break;
case op_and: simple_alu2(opcode, value, IR_AND); break; case op_and: simple_alu2(opcode, value, IR_AND, NULL); break;
case op_ior: simple_alu2(opcode, value, IR_OR); break; case op_ior: simple_alu2(opcode, value, IR_OR, ".ior"); break;
case op_xor: simple_alu2(opcode, value, IR_EOR); break; case op_xor: simple_alu2(opcode, value, IR_EOR, NULL); break;
case op_com: simple_alu1(opcode, value, IR_NOT); break; case op_com: simple_alu1(opcode, value, IR_NOT, NULL); break;
case op_adf: simple_alu2(opcode, value, IR_ADDF); break; case op_adf: simple_alu2(opcode, value, IR_ADDF, NULL); break;
case op_sbf: simple_alu2(opcode, value, IR_SUBF); break; case op_sbf: simple_alu2(opcode, value, IR_SUBF, NULL); break;
case op_mlf: simple_alu2(opcode, value, IR_MULF); break; case op_mlf: simple_alu2(opcode, value, IR_MULF, NULL); break;
case op_dvf: simple_alu2(opcode, value, IR_DIVF); break; case op_dvf: simple_alu2(opcode, value, IR_DIVF, NULL); break;
case op_ngf: simple_alu1(opcode, value, IR_NEGF); break; case op_ngf: simple_alu1(opcode, value, IR_NEGF, NULL); break;
case op_cmu: /* fall through */ case op_cmu: /* fall through */
case op_cms: push(tristate_compare(value, IR_COMPAREUI)); break; case op_cms: push(tristate_compare(value, IR_COMPAREUI)); break;
case op_cmi: push(tristate_compare(value, IR_COMPARESI)); break; case op_cmi: push(tristate_compare(value, IR_COMPARESI)); break;
case op_cmf: push(tristate_compare(value, IR_COMPAREF)); break; case op_cmf: push(tristate_compare(value, IR_COMPAREF)); break;
case op_rck: helper_function(".rck"); break;
case op_set: push(new_wordir(value)); helper_function(".set"); break;
case op_inn: push(new_wordir(value)); helper_function(".inn"); break;
case op_lol: case op_lol:
push( push(
load( load(
@ -874,7 +904,7 @@ static void insn_ivalue(int opcode, arith value)
) )
); );
break; break;
case op_loc: case op_loc:
push( push(
new_wordir(value) new_wordir(value)
@ -1041,7 +1071,7 @@ static void insn_ivalue(int opcode, arith value)
struct ir* right = pop(EM_pointersize); struct ir* right = pop(EM_pointersize);
struct ir* left = pop(EM_pointersize); struct ir* left = pop(EM_pointersize);
struct ir* delta = struct ir* delta =
new_ir2( new_ir2(
IR_SUB, EM_pointersize, IR_SUB, EM_pointersize,
left, right left, right
@ -1053,7 +1083,7 @@ static void insn_ivalue(int opcode, arith value)
push(delta); push(delta);
break; break;
} }
case op_dup: case op_dup:
{ {
sequence_point(); sequence_point();
@ -1084,6 +1114,18 @@ static void insn_ivalue(int opcode, arith value)
break; break;
} }
case op_zer:
{
if (value <= EM_wordsize)
push(new_constir(value, 0));
else
{
push(new_wordir(value));
helper_function(".zer");
}
break;
}
case op_asp: case op_asp:
{ {
switch (value) switch (value)
@ -1108,15 +1150,12 @@ static void insn_ivalue(int opcode, arith value)
value -= s; value -= s;
} }
if (value != 0) appendir(
{ new_ir1(
appendir( IR_STACKADJUST, EM_pointersize,
new_ir1( new_wordir(value)
IR_STACKADJUST, EM_pointersize, )
new_wordir(value) );
)
);
}
break; break;
} }
break; break;
@ -1169,7 +1208,7 @@ static void insn_ivalue(int opcode, arith value)
); );
break; break;
} }
case op_lfr: case op_lfr:
{ {
push( push(
@ -1300,11 +1339,11 @@ static void insn_ivalue(int opcode, arith value)
new_labelir((value == 4) ? ".fef4" : ".fef8") new_labelir((value == 4) ? ".fef4" : ".fef8")
) )
); );
/* exit, leaving an int and then a float (or double) on the stack. */ /* exit, leaving an int and then a float (or double) on the stack. */
break; break;
} }
case op_fif: case op_fif:
{ {
/* fif is implemented by calling a helper function which then mutates /* fif is implemented by calling a helper function which then mutates
@ -1320,11 +1359,11 @@ static void insn_ivalue(int opcode, arith value)
new_labelir((value == 4) ? ".fif4" : ".fif8") new_labelir((value == 4) ? ".fif4" : ".fif8")
) )
); );
/* exit, leaving two floats (or doubles) on the stack. */ /* exit, leaving two floats (or doubles) on the stack. */
break; break;
} }
case op_lor: case op_lor:
{ {
switch (value) switch (value)
@ -1341,7 +1380,7 @@ static void insn_ivalue(int opcode, arith value)
) )
); );
break; break;
case 1: case 1:
push( push(
appendir( appendir(
@ -1492,18 +1531,6 @@ static void insn_ivalue(int opcode, arith value)
break; break;
} }
/* FIXME: These instructions are really complex and barely used
* (Modula-2 bitset support, I believe). Leave them until leter. */
case op_inn:
{
push(
new_wordir(value)
);
helper_function(".inn");
break;
}
case op_lin: case op_lin:
{ {
/* Set line number --- ignore. */ /* Set line number --- ignore. */
@ -1577,7 +1604,7 @@ static void insn_lvalue(int opcode, const char* label, arith offset)
) )
); );
break; break;
case op_ine: case op_ine:
sequence_point(); sequence_point();
appendir( appendir(
@ -1666,7 +1693,7 @@ static void insn_lvalue(int opcode, const char* label, arith offset)
/* Set filename --- ignore. */ /* Set filename --- ignore. */
break; break;
} }
default: default:
fatal("treebuilder: unknown lvalue instruction '%s'", fatal("treebuilder: unknown lvalue instruction '%s'",
em_mnem[opcode - sp_fmnem]); em_mnem[opcode - sp_fmnem]);
@ -1699,7 +1726,7 @@ static void generate_tree(struct basicblock* bb)
break; break;
case PARAM_LVALUE: case PARAM_LVALUE:
tracef('E', "label=%s offset=%d\n", tracef('E', "label=%s offset=%d\n",
em->u.lvalue.label, em->u.lvalue.offset); em->u.lvalue.label, em->u.lvalue.offset);
insn_lvalue(em->opcode, em->u.lvalue.label, em->u.lvalue.offset); insn_lvalue(em->opcode, em->u.lvalue.label, em->u.lvalue.offset);
break; break;

25
plat/linuxppc/libsys/trap.s
View file

@ -52,43 +52,48 @@ EUNIMPL = 63 ! unimplemented em-instruction called
.trap_ecase: .trap_ecase:
addi r3, r0, ECASE addi r3, r0, ECASE
b .trap b .trap
.define .trap_earray .define .trap_earray
.trap_earray: .trap_earray:
addi r3, r0, EARRAY addi r3, r0, EARRAY
b .trap b .trap
.define .trap_erange
.trap_erange:
addi r3, r0, ERANGE
b .trap
.define .trap .define .trap
.trap: .trap:
cmpi cr0, 0, r3, 15 ! traps >15 can't be ignored cmpi cr0, 0, r3, 15 ! traps >15 can't be ignored
bc IFTRUE, LT, 1f bc IFTRUE, LT, 1f
addi r4, r0, 1 addi r4, r0, 1
rlwnm r4, r4, r3, 0, 31 ! calculate trap bit rlwnm r4, r4, r3, 0, 31 ! calculate trap bit
li32 r5, .ignmask li32 r5, .ignmask
lwz r5, 0(r5) ! load ignore mask lwz r5, 0(r5) ! load ignore mask
and. r4, r4, r5 ! compare and. r4, r4, r5 ! compare
bclr IFFALSE, EQ, 0 ! return if non-zero bclr IFFALSE, EQ, 0 ! return if non-zero
1: 1:
li32 r4, .trppc li32 r4, .trppc
lwz r5, 0(r4) ! load user trap routine lwz r5, 0(r4) ! load user trap routine
or. r5, r5, r5 ! test or. r5, r5, r5 ! test
bc IFTRUE, EQ, fatal ! if no user trap routine, bail out bc IFTRUE, EQ, fatal ! if no user trap routine, bail out
addi r0, r0, 0 addi r0, r0, 0
stw r0, 0(r4) ! reset trap routine stw r0, 0(r4) ! reset trap routine
mfspr r0, lr mfspr r0, lr
stwu r0, -4(sp) ! save old lr stwu r0, -4(sp) ! save old lr
stwu r3, -4(sp) stwu r3, -4(sp)
mtspr ctr, r5 mtspr ctr, r5
bcctrl ALWAYS, 0, 0 ! call trap routine bcctrl ALWAYS, 0, 0 ! call trap routine
lwz r0, 4(sp) ! load old lr again lwz r0, 4(sp) ! load old lr again
addi sp, sp, 8 ! retract over stack usage addi sp, sp, 8 ! retract over stack usage
bclr ALWAYS, 0, 0 ! return bclr ALWAYS, 0, 0 ! return
fatal: fatal:
addi r3, r0, 1 addi r3, r0, 1
@ -96,7 +101,7 @@ fatal:
addi r5, r0, 6 addi r5, r0, 6
addi r0, r0, 4 ! write() addi r0, r0, 4 ! write()
sc 0 sc 0
addi r0, r0, 1 ! exit() addi r0, r0, 1 ! exit()
sc 0 sc 0

7
plat/qemuppc/libsys/trap.s
View file

@ -49,11 +49,15 @@ EUNIMPL = 63 ! unimplemented em-instruction called
.define .trap_ecase .define .trap_ecase
.trap_ecase: .trap_ecase:
b .trp b .trp
.define .trap_earray .define .trap_earray
.trap_earray: .trap_earray:
b .trp b .trp
.define .trap_erange
.trap_erange:
b .trap
.define .trp .define .trp
.define .trap .define .trap
.trp: .trp:
@ -66,4 +70,3 @@ EUNIMPL = 63 ! unimplemented em-instruction called
li32 r4, .trppc li32 r4, .trppc
stw r3, 0(r4) stw r3, 0(r4)
bclr ALWAYS, 0, 0 ! return bclr ALWAYS, 0, 0 ! return

28
tests/plat/charsignedness_p.p Normal file
View file

@ -0,0 +1,28 @@
#
(*$U+ -- enables underscores in identifiers *)
program markrelease;
type
charset = set of char;
var
s : charset;
i : integer;
procedure finished;
extern;
procedure fail(line: integer);
extern;
#define ASSERT(cond) \
if (not (cond)) then fail(__LINE__)
begin
s := [];
for i := 0 to 255 do
s := s + [chr(i)];
finished
end.

4
tests/plat/newdispose_p.p
View file

@ -9,13 +9,13 @@ type
var var
ptr1 : iptr; ptr1 : iptr;
ptr2 : iptr; ptr2 : iptr;
procedure finished; procedure finished;
extern; extern;
procedure fail(line: integer); procedure fail(line: integer);
extern; extern;
#define ASSERT(cond) \ #define ASSERT(cond) \
if (not (cond)) then fail(__LINE__) if (not (cond)) then fail(__LINE__)