budd@boring.UUCP (12/09/85)
<
A while back somebody mentioned the APL compiler developed at Arizona in
this net group. Since I was the original author of that compiler (a student of
mine, Joe Treat, later made some important contributions), I thought I
might give an example of the type of output it produces.
I am at the moment preparing a talk I will present in Heidelberg in
January summarizing all the research I have done in the last five years
connected with the project, and thus have been reviewing in my mind all the
different aspects of the project. If people are interested I can prepare a
short summary for the net, as well.
The example program I include here is sort of classic APL. i.e.,
rather cryptic. The three letter menomics (.ro for rho, for example),
don't help. The program is taken from a technical report by Alan Perlis of
many years ago (mid 70's, I believe). It orders the integers in a spiral,
50 51 52 53 54 55 56 57
49 26 27 28 29 30 31 58
48 25 10 11 12 13 32 59
47 24 9 2 3 14 33 60
46 23 8 1 4 15 34 61
45 22 7 6 5 16 35 62
44 21 20 19 18 17 36 63
43 42 41 40 39 38 37 64
and then replaces the prime numbers by a *, and the non-primes by a space.
*
* *
* * *
* **
* *
* *
* *
* * *
The resulting picture is somewhat interesting. Although this is not a
typical APL application, it does have the advantage of using most of the
APL functions, and is therefore a good test case for the compiler, as well
as illustrating the type of code the compiler produces.
Here is the program:
----------------------
scalar int n
.dl z _ spiral l
int l
vector int fun copies, linear
a _ .io n # 2
c _ 4 | a copies (| - \ a)
g _ .fl 0.5 + n % 2
e _ l [;(.ng1 + n # n) .ua c + 4 # 0 = c ]
z _ (2 .ro n) .ro .gu linear 1 1 2 .tr (2 .ro g) .so . + +\ 0 , e
.dl
.dl c _ a copies b
int vector b
vector a
c _ a [ + \ ( .io +/ b ) .ep .ng1 .da 1 + +\ 0 , b ]
.dl
.dl x _ primes a
s _ + / .ro , a
x _ a .ep (2 = + .bs 0 = (.io s) .so . | .io s)/ .io s
.dl
.dl l _ linear m
int m
l _ 1 + n .dc m - 1
.dl
int fun primes
n _ 8
.bx _ y _ spiral 2 4 .ro .ng1 0 1 0 0 1 0 .ng1
' *'[1 + primes y]
---------------
APL programmers will undoubtedly be upset at the appearance of
declarations. In the APL compiler, declarations are treated as hints to
the code generator. The only declarations that are absolutely required are
for forward defined functions (since otherwise the parser can't
disambiguate things). Declarations can optionally give rank (scalar,
vector, or other), type (bit, int, real, or char), or simply just a name
(var). Notice that most local vars aren't declared, only parameters. This
is because at the moment the compiler performs intra- but not
inter-procedural analysis, and thus can't discover the types of parameters
unless you tell it. Most of the declarations could be omitted, with the result
that larger (and slower) code would be produced.
Unfortunately, you won't be able to run the resulting code, since
there is a small run-time system that must be linked with the resulting
program. However you might have fun looking at the code and trying to
figure out how in the *ell the compiler generates THAT from the source.
--------------
# include "aplc.h"
extern struct trs_struct n;
int i_spiral[15] = {
0, 1, 2, 4, 2, -1, 4, 0, 2, 1,
1, 2, 3, 2, 0}
;
double r_spiral[1] = {
0.5}
;
spiral(z, _no2, l)
struct trs_struct *z, *_no2, *l;
{
struct trs_struct e;
struct trs_struct g;
struct trs_struct c;
struct trs_struct a;
struct trs_struct trs1, trs2, trs3, trs4;
union mp_struct mp1, mp2, mp3, mp4, mp5, mp6, mp7, mp8, mp9,
mp10, mp11, mp12, mp13, mp14, mp15, mp16, mp17, mp18, mp19,
mp20, mp21, mp22, mp23, mp24, mp25, mp26, mp27, mp28, mp29,
mp30, mp31, mp32;
union res_struct res1, res2, res3, res4, res5, res6, res7, res8, res9,
res10, res11, res12, res13, res14, res15, res16, res17, res18, res19,
res20, res21, res22;
int i0, i1, i2, i3, i4, i5, i6, i7, i8, i9,
i10, i11, i12, i13, i14, i15, i16, i17, i18, i19,
i20, i21, i22, i23, i24, i25, i26, i27, i28, i29,
i30, i31, i32, i33, i34, i35, i36, i37, i38, i39,
i40, i41, i42, i43, i44, i45, i46;
e.type = UKTYPE;
g.type = UKTYPE;
c.type = UKTYPE;
a.type = UKTYPE;
stmtno = 1;
while (stmtno)
switch(stmtno) {
default:
stmtno = 0;
break;
case 1:
stmtno = 1;
trace("spiral", 1);
valloc(&mp5, 1, INT);
if (n.type == UKTYPE) error("undefined value used");
mp3.ip = n.value.ip;
*mp5.ip = (*mp3.ip * 2);
i6 = 1;
settrs(&trs1, INT, 1, mp5.ip);
i1 = talloc(&trs1);
mp1.ip = trs1.value.ip;
for (i2 = 0; i2 < i1; i2++) {
(*mp1.ip++ = i6++ );
}
assign(&a, &trs1);
memfree(&mp5.ip);
case 2:
stmtno = 2;
trace("spiral", 2);
if (a.type == UKTYPE) error("undefined value used");
mp2.ip = a.value.ip;
settrs(&trs2, INT, 1, a.shape);
trs2.value.ip = mp2.ip;
mp5.ip = a.value.ip;
i8 = 1;
i9 = *a.shape;
i12 = *a.shape;
valloc(&mp6, i12, INT);
mp7 = mp6;
for (i5 = 0; i5 < i12; i5++) {
res5.i = 0;
for (i6 = i5; i6 >= 0; i6--) {
(res5.i = (*(mp5.ip + i6) - res5.i));
}
if (res5.i < 0)
res5.i = - res5.i;
(*mp6.ip++ = res5.i);
}
settrs(&trs3, INT, 1, a.shape);
trs3.value.ip = mp7.ip;
copies(&trs4, &trs2, &trs3);
mp8.ip = trs4.value.ip;
settrs(&trs1, INT, 1, trs4.shape);
i1 = talloc(&trs1);
mp1.ip = trs1.value.ip;
for (i2 = 0; i2 < i1; i2++) {
(*mp1.ip++ = (*mp8.ip++ % 4));
}
assign(&c, &trs1);
memfree(&mp7.ip);
case 3:
stmtno = 3;
trace("spiral", 3);
mp5.rp = &r_spiral[0];
if (n.type == UKTYPE) error("undefined value used");
mp3.ip = n.value.ip;
settrs(&trs1, INT, 0, &i_spiral[1]);
i1 = talloc(&trs1);
mp1.ip = trs1.value.ip;
{
(*mp1.ip++ = ((int) floor((*mp5.rp + (((double) *mp3.ip) / ((double) 2))))));
}
assign(&g, &trs1);
case 4:
stmtno = 4;
trace("spiral", 4);
if (l->type == UKTYPE) error("undefined value used");
mp2.ip = l->value.ip;
valloc(&mp3, 1, INT);
*mp3.ip = *l->shape;
if (n.type == UKTYPE) error("undefined value used");
mp11.ip = n.value.ip;
mp10.ip = n.value.ip;
i17 = 1;
valloc(&mp15, i17, INT);
mp16 = mp15;
{
(*mp15.ip++ = ((*mp11.ip * *mp10.ip) - 1));
}
if (c.type == UKTYPE) error("undefined value used");
mp22.ip = c.value.ip;
mp17.ip = c.value.ip;
i8 = 1;
valloc(&mp9, i8, INT);
for (i9 = i8 - 1; i9 >= 0; i9--) {
*(mp9.ip + i9) = iabs(*(mp16.ip + i9));
}
i10 = qsdalloc(1, &mp5, &mp6, &mp7);
i9 = 0;
{
if (*(mp16.ip + i9) < 0)
*(mp6.ip + i9) += *(c.shape + i9) + *(mp16.ip + i9);
}
i7 = accessor(1, mp9.ip, 1, c.shape, &mp8, mp5.ip, mp6.ip, mp7.ip);
outershape(&mp24, 1, mp3.ip, 1, mp9.ip);
i24 = *mp9.ip;
settrs(&trs1, INT, 2, mp24.ip);
i1 = talloc(&trs1);
mp1.ip = trs1.value.ip;
for (i2 = 0; i2 < i1; i2++) {
i6 = i2 % i24;
i8 = i6;
i11 = i7;
for (i9 = i10 - 1; i9 >= 0; i9--) {
i11 += i8 * *(mp8.ip + i9);
i8 /= *(mp9.ip + i9);
}
i4 = i2 / i24;
i3 = (((*(mp22.ip + i11) + ((0 == *(mp17.ip + i11)) * 4)) + (i4 * *(l->shape + 1))) - 1);
(*mp1.ip++ = *(mp2.ip + (l->rank?i3:0)));
}
assign(&e, &trs1);
memfree(&mp3.ip);
memfree(&mp4.ip);
memfree(&mp24.ip);
case 5:
stmtno = 5;
trace("spiral", 5);
if (n.type == UKTYPE) error("undefined value used");
mp5.ip = n.value.ip;
i8 = 2;
valloc(&mp6, i8, INT);
mp7 = mp6;
for (i3 = 0; i3 < i8; i3++) {
(*mp6.ip++ = *mp5.ip);
}
trs2.type = UKTYPE;
if (g.type == UKTYPE) error("undefined value used");
mp24.ip = g.value.ip;
i41 = 1;
if (e.type == UKTYPE) error("undefined value used");
mp18.ip = e.value.ip;
catshape(&mp16, 0, &i_spiral[1], 2, e.shape);
i28 = 1;
i31 = *(e.shape + 1);
i30 = i28 + i31;
i25 = 0;
i35 = *(mp16.ip + 1);
i23 = 0;
i37 = vsize(2, mp16.ip);
valloc(&mp19, i37, INT);
mp20 = mp19;
for (i22 = 0; i22 < i37; i22++) {
i36 = (i22 / i35) * i35;
if (i22 == i36) {
res11.i = 0;
}
i32 = i23 % i30;
if (i32 < i28) {
(res8.i = 0);
}
else {
(res8.i = *mp18.ip++ );
i25++;
}
res11.i += res8.i;
i23++;
(*mp19.ip++ = res11.i);
}
outershape(&mp25, 1, &i_spiral[13], 2, mp16.ip);
i43 = vsize(2, mp16.ip);
i20 = -1;
dtshape(&mp12, &i_spiral[9], 3, mp25.ip);
i16 = qsdalloc(2, &mp8, &mp9, &mp10);
dtmerge(&i_spiral[9], 3, &mp8, &mp9, &mp10);
i13 = accessor(2, mp12.ip, 3, mp25.ip, &mp11, mp8.ip, mp9.ip, mp10.ip);
i45 = vsize(2, mp12.ip);
valloc(&mp26, i45, INT);
mp27 = mp26;
for (i12 = 0; i12 < i45; i12++) {
i14 = i12;
i17 = i13;
for (i15 = i16 - 1; i15 >= 0; i15--) {
i17 += i14 * *(mp11.ip + i15);
i14 /= *(mp12.ip + i15);
}
if ((i17 / i43) != i20) {
i20 = i17 / i43;
i40 = i20 % i41;
(res16.i = *mp24.ip);
}
i21 = i17 % i43;
(*mp26.ip++ = (res16.i + *(mp20.ip + i21)));
}
settrs(&trs3, INT, 2, mp12.ip);
trs3.value.ip = mp27.ip;
linear(&trs4, &trs2, &trs3);
mp28.ip = trs4.value.ip;
aplsort(&mp31, &mp28, *trs4.shape, INT, 1);
i10 = *trs4.shape;
settrs(&trs1, INT, 2, mp7.ip);
i1 = talloc(&trs1);
mp1.ip = trs1.value.ip;
for (i2 = 0; i2 < i1; i2++) {
i9 = i2 % i10;
(*mp1.ip++ = (*(mp31.ip + i9) + 1));
}
assign( z, &trs1);
memfree(&mp7.ip);
memfree(&mp27.ip);
memfree(&mp20.ip);
memfree(&mp16.ip);
memfree(&mp25.ip);
memfree(&mp31.ip);
stmtno = 0;
}
}
int i_copies[5] = {
0, 1, -1, 1, 0}
;
copies(c, a, b)
struct trs_struct *c, *a, *b;
{
struct trs_struct trs1;
union mp_struct mp1, mp2, mp3, mp4, mp5, mp6, mp7, mp8, mp9,
mp10, mp11, mp12, mp13, mp14, mp15, mp16, mp17, mp18, mp19,
mp20, mp21, mp22, mp23, mp24, mp25;
union res_struct res1, res2, res3, res4, res5, res6, res7, res8, res9,
res10, res11, res12, res13, res14, res15, res16, res17, res18, res19;
int i0, i1, i2, i3, i4, i5, i6, i7, i8, i9,
i10, i11, i12, i13, i14, i15, i16, i17, i18, i19,
i20, i21, i22, i23, i24, i25, i26, i27, i28, i29,
i30, i31, i32, i33, i34, i35, i36, i37, i38, i39,
i40;
stmtno = 1;
while (stmtno)
switch(stmtno) {
default:
stmtno = 0;
break;
case 1:
stmtno = 1;
trace("copies", 1);
if (a->type == UKTYPE) error("undefined value used");
mp2 = a->value;
valloc(&mp5, 1, INT);
if (b->type == UKTYPE) error("undefined value used");
mp3.ip = b->value.ip;
i8 = *b->shape;
res4.i = 0;
for (i6 = 0; i6 < i8; i6++) {
res4.i += *mp3.ip++ ;
}
*mp5.ip = res4.i;
i10 = 1;
mp16.ip = b->value.ip;
catshape(&mp14, 0, &i_copies[1], 1, b->shape);
i23 = 1;
i26 = *b->shape;
i25 = i23 + i26;
i29 = 1;
i30 = *mp14.ip;
i13 = 1;
valloc(&mp10, i13, INT);
for (i14 = i13 - 1; i14 >= 0; i14--) {
*(mp10.ip + i14) = *(mp14.ip + i14) - iabs(i_copies[(i14 + 2)]);
}
i15 = qsdalloc(1, &mp6, &mp7, &mp8);
i14 = 0;
{
if (i_copies[(i14 + 2)] >= 0)
*(mp7.ip + i14) += i_copies[(i14 + 2)];
}
i12 = accessor(1, mp10.ip, 1, mp14.ip, &mp9, mp6.ip, mp7.ip, mp8.ip);
valloc(&mp19, 1, INT);
i34 = *mp10.ip;
*mp19.ip = i34;
i35 = *mp19.ip;
valloc(&mp20, i35, INT);
mp21 = mp20;
for (i11 = 0; i11 < i35; i11++) {
i13 = i11;
i16 = i12;
for (i14 = i15 - 1; i14 >= 0; i14--) {
i16 += i13 * *(mp9.ip + i14);
i13 /= *(mp10.ip + i14);
}
res11.i = 0;
for (i19 = i16; i19 >= 0; i19--) {
i20 = i19 % i25;
if (i20 < i23) {
(res8.i = 0);
}
else {
i20 -= i23;
(res8.i = *(mp16.ip + i20));
}
res11.i += res8.i;
}
(*mp20.ip++ = (res11.i + 1));
}
aplsort(&mp22, &mp21, *mp19.ip, INT, 1);
i38 = *mp5.ip;
i4 = 0;
settrs(&trs1, a->type, 1, mp5.ip);
i1 = talloc(&trs1);
mp1 = trs1.value;
for (i2 = 0; i2 < i1; i2++) {
i39 = (i2 / i38) * i38;
if (i2 == i39) {
res18.i = 0;
}
(res17.i = i10++ );
res17.i = aplsearch(mp22.ip, &mp21, &res17, INT, *mp19.ip) < *mp19.ip;
res18.i += res17.i;
i4++;
i3 = (res18.i - 1);
getmp(&res2, &mp2, i3, a->type);
setmp(&res2, &mp1, i2, trs1.type);
}
assign( c, &trs1);
memfree(&mp5.ip);
memfree(&mp21.ip);
memfree(&mp14.ip);
memfree(&mp19.ip);
memfree(&mp22.ip);
memfree(&mp25.ip);
stmtno = 0;
}
}
int i_primes[5] = {
0, 1, 2, 0, 1}
;
primes(x, _no2, a)
struct trs_struct *x, *_no2, *a;
{
struct trs_struct s;
struct trs_struct trs1;
union mp_struct mp1, mp2, mp3, mp4, mp5, mp6, mp7, mp8, mp9,
mp10, mp11, mp12, mp13, mp14, mp15, mp16, mp17, mp18, mp19,
mp20, mp21, mp22;
union res_struct res1, res2, res3, res4, res5, res6, res7, res8, res9,
res10, res11, res12, res13, res14, res15, res16, res17, res18, res19,
res20, res21, res22;
int i0, i1, i2, i3, i4, i5, i6, i7, i8, i9,
i10, i11, i12, i13, i14, i15, i16, i17, i18, i19,
i20, i21, i22, i23, i24, i25, i26, i27;
s.type = UKTYPE;
stmtno = 1;
while (stmtno)
switch(stmtno) {
default:
stmtno = 0;
break;
case 1:
stmtno = 1;
trace("primes", 1);
if (a->type == UKTYPE) error("undefined value used");
mp2 = a->value;
valloc(&mp3, 1, INT);
i4 = vsize(a->rank, a->shape);
*mp3.ip = i4;
mp5.ip = mp3.ip;
i6 = 1;
i3 = 0;
settrs(&trs1, INT, 0, &i_primes[1]);
i1 = talloc(&trs1);
mp1.ip = trs1.value.ip;
i2 = 0;
{
res3.i = 0;
for (i3 = 0; i3 < i6; i3++) {
res3.i += *mp5.ip++ ;
}
(*mp1.ip++ = res3.i);
}
assign(&s, &trs1);
memfree(&mp3.ip);
case 2:
stmtno = 2;
trace("primes", 2);
mp2 = a->value;
i25 = 0;
valloc(&mp6, 1, INT);
if (s.type == UKTYPE) error("undefined value used");
mp5.ip = s.value.ip;
*mp6.ip = *mp5.ip;
valloc(&mp4, 1, INT);
mp3.ip = s.value.ip;
*mp4.ip = *mp3.ip;
outershape(&mp7, 1, mp6.ip, 1, mp4.ip);
i12 = *mp4.ip;
i7 = -1;
i17 = *mp7.ip;
i16 = esubi(0, 2, mp7.ip);
valloc(&mp14, 1, INT);
mp13.ip = s.value.ip;
*mp14.ip = *mp13.ip;
i22 = 0;
i24 = *(mp14.ip + i22);
valloc(&mp15, i24, INT);
for (i4 = 0; i4 < i24; i4++) {
res12.i = 0;
i6 = (i17 - 1) * i16 + i4 % i16;
for (i18 = i17 - 1; i18 >= 0; i18--) {
if ((i6 / i12) != i7) {
i7 = i6 / i12;
(res7.i = (i7 + 1));
}
i8 = i6 % i12;
res12.i += (0 == ((i8 + 1) % res7.i));
i6 -= i16;
}
if (((2 == res12.i) != 0))
*(mp15.ip + i25++) = i4;
}
memfree(&mp6.ip);
memfree(&mp4.ip);
memfree(&mp7.ip);
valloc(&mp16, 1, INT);
*mp16.ip = i25;
valloc(&mp17, 1, INT);
i26 = *mp16.ip;
*mp17.ip = i26;
i27 = *mp17.ip;
valloc(&mp18, i27, INT);
mp19 = mp18;
for (i3 = 0; i3 < i27; i3++) {
i5 = *(mp15.ip + i3);
(*mp18.ip++ = (i5 + 1));
}
aplsort(&mp20, &mp19, *mp17.ip, INT, 1);
settrs(&trs1, BIT, a->rank, a->shape);
i1 = talloc(&trs1);
mp1.ip = trs1.value.ip;
for (i2 = 0; i2 < i1; i2++) {
getmp(&res2, &mp2, i2, a->type);
cktype(&res2, INT, a->type);
res22.i = aplsearch(mp20.ip, &mp19, &res2, INT, *mp17.ip) < *mp17.ip;
(*mp1.ip++ = res22.i);
}
assign( x, &trs1);
memfree(&mp19.ip);
memfree(&mp16.ip);
memfree(&mp15.ip);
memfree(&mp14.ip);
memfree(&mp17.ip);
memfree(&mp20.ip);
stmtno = 0;
}
}
int i_linear[4] = {
0, 1, 1, 1}
;
linear(l, _no2, m)
struct trs_struct *l, *_no2, *m;
{
struct trs_struct trs1;
union mp_struct mp1, mp2, mp3, mp4, mp5, mp6, mp7, mp8;
union res_struct res1, res2, res3, res4, res5, res6, res7, res8, res9,
res10, res11, res12, res13;
int i0, i1, i2, i3, i4, i5, i6, i7, i8, i9,
i10, i11, i12, i13, i14;
stmtno = 1;
while (stmtno)
switch(stmtno) {
default:
stmtno = 0;
break;
case 1:
stmtno = 1;
trace("linear", 1);
if (n.type == UKTYPE) error("undefined value used");
mp3.ip = n.value.ip;
if (m->type == UKTYPE) error("undefined value used");
mp5.ip = m->value.ip;
i4 = innershape(&mp2, 0, &i_linear[1], m->rank, m->shape);
i5 = *m->shape;
i12 = (m->rank?*((m->rank + m->shape) - 1):1);
settrs(&trs1, INT, i4, mp2.ip);
i1 = talloc(&trs1);
mp1.ip = trs1.value.ip;
for (i2 = 0; i2 < i1; i2++) {
res10.i = 0;
res2.i = 1;
for (i6 = i5 - 1; i6 >= 0; i6--) {
(res3.i = *mp3.ip);
i8 = i6 * i12 + i2 % i12;
res10.i += (res2.i * (*(mp5.ip + (m->rank?i8:0)) - 1));
res2.i *= res3.i;
}
(*mp1.ip++ = (res10.i + 1));
}
assign( l, &trs1);
stmtno = 0;
}
}
extern struct trs_struct y;
struct trs_struct y;
struct trs_struct n;
int i_main[17] = {
0, 1, 10, 2, 4, 2, -1, 0, 1, 0,
0, 1, 0, -1, 8, 2, 1}
;
char c_main[] = " *";
main() {
struct trs_struct trs1, trs2, trs3, trs4;
union mp_struct mp1, mp2, mp3, mp4, mp5, mp6, mp7, mp8, mp9;
union res_struct res1, res2, res3, res4, res5, res6, res7, res8, res9;
int i0, i1, i2, i3, i4, i5, i6, i7, i8, i9;
y.type = UKTYPE;
n.type = UKTYPE;
stmtno = 1;
while (stmtno)
switch(stmtno) {
default:
stmtno = 0;
break;
case 1:
stmtno = 1;
trace("main", 1);
settrs(&trs1, INT, 0, &i_main[1]);
i1 = talloc(&trs1);
mp1.ip = trs1.value.ip;
{
(*mp1.ip++ = 10);
}
assign(&n, &trs1);
case 2:
stmtno = 2;
trace("main", 2);
trs2.type = UKTYPE;
settrs(&trs3, INT, 2, &i_main[3]);
trs3.value.ip = &i_main[6];
spiral(&trs4, &trs2, &trs3);
mp9 = trs4.value;
i1 = vsize(trs4.rank, trs4.shape);
bldrqv(&mp1, trs4.rank);
for (i2 = 0; i2 < i1; i2++) {
getmp(&res7, &mp9, i2, trs4.type);
printit(&res7, trs4.type, bmprqv(mp1.ip, trs4.rank, trs4.shape));
}
assign(&y, &trs4);
memfree(&mp1.ip);
case 3:
stmtno = 3;
trace("main", 3);
mp2.cp = &c_main[0];
trs1.type = UKTYPE;
if (y.type == UKTYPE) error("undefined value used");
mp3 = y.value;
settrs(&trs2, y.type, y.rank, y.shape);
trs2.value = mp3;
primes(&trs3, &trs1, &trs2);
mp6.ip = trs3.value.ip;
i1 = vsize(trs3.rank, trs3.shape);
bldrqv(&mp1, trs3.rank);
for (i2 = 0; i2 < i1; i2++) {
i3 = *mp6.ip++ ;
(res1.c = *(mp2.cp + i3));
printit(&res1, CHAR, bmprqv(mp1.ip, trs3.rank, trs3.shape));
}
memfree(&mp9.ip);
memfree(&mp1.ip);
stmtno = 0;
}
}