lang/occam/comp/code.c

   1 /* $Id: code.c,v 1.8 1994/06/24 12:26:43 ceriel Exp $ */
   2 /*
   3  * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
   4  * See the copyright notice in the ACK home directory, in the file "Copyright".
   5  */
   6 #include "em.h"
   7 #include "expr.h"
   8 #include "symtab.h"
   9 #include "sizes.h"
  10 #include "Lpars.h"
  11 #include "code.h"
  12
  13 extern err;
  14
  15 static void subscript();
  16 enum addr_val { address, value };
  17
  18 void code_val(e) register struct expr *e;
  19 /* Compile e for its value, which is put on the stack. */
  20 {
  21         register struct expr *left, *right;
  22
  23         if (err) return;
  24
  25         switch(e->kind) {
  26         case E_NODE:
  27                 left=e->u.node.left;
  28                 right=e->u.node.right;
  29
  30                 switch (e->u.node.op) {
  31                 case '+':
  32                 case '-':
  33                 case '*':
  34                 case '/':
  35                 case BS:
  36                         code_val(left);
  37                         code_val(right);
  38                         xxi(e->u.node.op);
  39                         break;
  40                 case '<':
  41                 case '>':
  42                 case LE:
  43                 case GE:
  44                 case NE:
  45                 case '=':
  46                         code_val(left);
  47                         code_val(right);
  48                         cmi();
  49                         Txx(e->u.node.op);
  50                         break;
  51                 case AFTER:
  52                         code_val(left);
  53                         code_val(right);
  54                         xxi('-');
  55                         cvw();
  56                         tst();
  57                         Txx('>');
  58                         break;
  59                 case BA:
  60                         code_val(left);
  61                         code_val(right);
  62                         and();
  63                         break;
  64                 case BO:
  65                         code_val(left);
  66                         code_val(right);
  67                         ior();
  68                         break;
  69                 case BX:
  70                         code_val(left);
  71                         code_val(right);
  72                         xor();
  73                         break;
  74                 case AND:
  75                 case OR: {
  76                         int T=0, F=0, L=0;
  77
  78                         code_bool(e, positive, &T, &F);
  79                         Label(T);
  80                         Loc(-1L);
  81                         branch(&L);
  82                         Label(F);
  83                         Loc(0L);
  84                         Label(L);
  85                         }break;
  86                 case LS:
  87                         code_val(left);
  88                         code_val(right);
  89                         cvw();
  90                         sli();
  91                         break;
  92                 case RS:
  93                         code_val(left);
  94                         code_val(right);
  95                         cvw();
  96                         sri();
  97                         break;
  98                 case '~':
  99                         code_val(left);
 100                         ngi();
 101                         break;
 102                 case NOT:
 103                         code_val(left);
 104                         com();
 105                         break;
 106                 case '[':
 107                         subscript(e, value);
 108                         break;
 109                 }
 110                 break;
 111         case E_VAR: {
 112                 register struct symbol *var=e->u.var;
 113
 114                 if (var->s_type&T_BUILTIN)
 115                         Loe(var->s_info.vc.st.builtin, var->s_info.vc.offset);
 116                 else
 117                 if (var->s_info.vc.st.level==curr_level)
 118                         if (var->s_type&T_PARAM && (var->s_type&T_TYPE)!=T_VALUE)
 119                                 Lil(var->s_info.vc.offset);
 120                         else
 121                                 Lol(var->s_info.vc.offset);
 122                 else {
 123                         if (var->s_info.vc.offset<0)
 124                                 lxl(curr_level-var->s_info.vc.st.level);
 125                         else
 126                                 lxa(curr_level-var->s_info.vc.st.level);
 127                         if (var->s_type&T_PARAM && (var->s_type&T_TYPE)!=T_VALUE)
 128                                 Lif(var->s_info.vc.offset);
 129                         else
 130                                 Lof(var->s_info.vc.offset);
 131                 }
 132                 }break;
 133         case E_CONST:
 134                 Loc(e->u.cst);
 135                 break;
 136         case E_NOW:
 137                 cal("now");
 138                 lfr(vz);
 139                 break;
 140         }
 141 }
 142
 143 static void subscript(e, av) register struct expr *e; enum addr_val av;
 144 /* Produce code to compute the address or value of e->left[e->right] or
 145  * the address of e->left[e->right->left FOR e->right->right].
 146  */
 147 {
 148         register char *des;
 149         register struct expr *left;
 150         register struct expr *index;
 151
 152         code_addr(left=e->u.node.left);
 153
 154         if ((index=e->u.node.right)->kind==E_NODE && index->u.node.op==FOR)
 155                 index=index->u.node.left;
 156
 157         if (left->arr_siz==0) {
 158                 if ((left->type&T_TYPE)==T_CHAN)
 159                         des="maxcdes";
 160                 else
 161                         des= e->type&T_BYTE ? "maxbdes" : "maxwdes";
 162         } else {
 163                 register lsiz=left->arr_siz;
 164
 165                 if (left->type&T_BYTE && !(e->type&T_BYTE))
 166                         lsiz/=vz;
 167                 else
 168                 if (!(left->type&T_BYTE) && e->type&T_BYTE)
 169                         lsiz*=vz;
 170
 171                 if (e->type&T_ARR)
 172                         lsiz-=(e->arr_siz -1);
 173
 174                 if (constant(index)) {
 175                         if (index->u.cst<0 || index->u.cst>=lsiz) {
 176                                 warning("constant index outside vector");
 177                                 lin();
 178                                 loc(0);
 179                                 trp();
 180                         }
 181                 } else {
 182                         loc(lsiz);
 183
 184                         if ((left->type&T_TYPE)==T_CHAN)
 185                                 des="chandes";
 186                         else
 187                                 des= e->type&T_BYTE ? "bytedes" : "worddes";
 188                         ste(des, wz);
 189                 }
 190         }
 191         if (constant(index)) {
 192                 register offset=index->u.cst;
 193
 194                 if ((left->type&T_TYPE)==T_CHAN)
 195                         offset*=(wz+vz);
 196                 else
 197                 if ( !(e->type&T_BYTE) )
 198                         offset*=vz;
 199
 200                 if (av==address)
 201                         adp(offset);
 202                 else {
 203                         if (e->type&T_BYTE) {
 204                                 adp(offset);
 205                                 loi(1);
 206                                 cwv();
 207                         } else
 208                                 Lof(offset);
 209                 }
 210         } else {
 211                 code_val(index);
 212                 cvw();
 213                 lin();
 214                 lae(des, 0);
 215                 if (av==address) {
 216                         aar();
 217                 } else {
 218                         lar();
 219                         if (e->type&T_BYTE) cwv();
 220                 }
 221         }
 222 }
 223
 224 void code_addr(e) register struct expr *e;
 225 /* The address of e is wat we want. */
 226 {
 227         if (err) return;
 228
 229         switch(e->kind) {
 230         case E_NODE:
 231                 subscript(e, address);
 232                 break;
 233         case E_VAR: {   /* variable or channel */
 234                 register struct symbol *var=e->u.var;
 235
 236                 if (var->s_type&T_BUILTIN)
 237                         lae(var->s_info.vc.st.builtin, var->s_info.vc.offset);
 238                 else
 239                 if (var->s_info.vc.st.level==curr_level)
 240                         if (var->s_type&T_PARAM
 241                             && (var->s_type&(T_TYPE|T_ARR))!=T_VALUE)
 242                                 Lolp(var->s_info.vc.offset);
 243                         else
 244                                 lal(var->s_info.vc.offset);
 245                 else {
 246                         if (var->s_info.vc.offset<0)
 247                                 lxl(curr_level-var->s_info.vc.st.level);
 248                         else
 249                                 lxa(curr_level-var->s_info.vc.st.level);
 250                         if (var->s_type&T_PARAM
 251                             && (var->s_type&(T_TYPE|T_ARR))!=T_VALUE)
 252                                 Lofp(var->s_info.vc.offset);
 253                         else
 254                                 adp(var->s_info.vc.offset);
 255                 }
 256                 } break;
 257         case E_TABLE:
 258         case E_BTAB:
 259                 laedot(e->u.tab);
 260                 break;
 261         }
 262 }
 263
 264 void code_bool(e, pos, T, F)
 265         register struct expr *e;
 266         register pos;
 267         register int *T, *F;
 268 /* if e = pos then
 269         fall through or jump to T;
 270    else
 271         jump to F;
 272    fi
 273  */
 274 {
 275         register Default=0;
 276
 277         if (err) return;
 278
 279         if (e->kind==E_NODE) {
 280                 register struct expr *left=e->u.node.left;
 281                 register struct expr *right=e->u.node.right;
 282
 283                 switch(e->u.node.op) {
 284                 case '<':
 285                 case '>':
 286                 case LE:
 287                 case GE:
 288                 case NE:
 289                 case '=':
 290                 case AFTER:
 291                         code_val(left);
 292                         code_val(right);
 293                         bxx(pos, e->u.node.op, new_label(F));
 294                         break;
 295                 case AND:
 296                 case OR:
 297                         if ((e->u.node.op==AND && pos)
 298                          || (e->u.node.op==OR && !pos)
 299                         ) {
 300                                 int L=0;
 301                                 code_bool(left, pos, &L, F);
 302                                 Label(L);
 303                                 code_bool(right, pos, T, F);
 304                         } else {
 305                                 int L=0;
 306                                 code_bool(left, !pos, &L, T);
 307                                 Label(L);
 308                                 code_bool(right, pos, T, F);
 309                         }
 310                         break;
 311                 case NOT:
 312                         code_bool(left, !pos, T, F);
 313                         break;
 314                 default:
 315                         Default=1;
 316                 }
 317         } else
 318                 Default=1;
 319
 320         if (Default) {
 321                 code_val(e);
 322                 if (vz>wz) {
 323                         ldc0();
 324                         cmi();
 325                 } else
 326                         tst();
 327                 if (pos) zeq(new_label(F)); else zne(new_label(F));
 328         }
 329 }
 330
 331 void code_assignment(e) register struct expr *e;
 332 /* e->left := e->right */
 333 {
 334         register struct expr *left=e->u.node.left;
 335         register struct expr *right=e->u.node.right;
 336
 337         if (left->type&T_ARR) {
 338                 register siz=left->arr_siz;
 339
 340                 code_addr(right);
 341                 code_addr(left);
 342                 blm(left->type&T_BYTE ? siz : siz*vz);
 343         } else {
 344                 code_val(right);
 345                 code_addr(left);
 346                 sti(left->type&T_BYTE ? 1 : vz);
 347         }
 348 }
 349
 350 void code_input(e) register struct expr *e;
 351 /* Input one v from c ? v0; v1; ... */
 352 {
 353         if (e==nil) {
 354                 lae("any", 0);
 355                 cal("chan_in");
 356                 asp(pz);
 357         } else
 358         if (e->type&T_ARR) {
 359                 loc(e->arr_siz);
 360                 code_addr(e);
 361                 cal(e->type&T_BYTE ? "c_ba_in" : "c_wa_in");
 362                 asp(pz+wz);
 363         } else {
 364                 code_addr(e);
 365                 cal(e->type&T_BYTE ? "cbyte_in" : "chan_in");
 366                 asp(pz);
 367         }
 368 }
 369
 370 void code_output(e) register struct expr *e;
 371 /* Output one e from c ? e0; e1; ... */
 372 {
 373         if (e==nil) {
 374                 Loc(0L);
 375                 cal("chan_out");
 376                 asp(vz);
 377         } else
 378         if (e->type&T_ARR) {
 379                 loc(e->arr_siz);
 380                 code_addr(e);
 381                 cal(e->type&T_BYTE ? "c_ba_out" : "c_wa_out");
 382                 asp(pz+wz);
 383         } else {
 384                 code_val(e);
 385                 cal("chan_out");
 386                 asp(vz);
 387         }
 388 }
 389
 390 void code_any(e, NO) register struct expr *e; int *NO;
 391 /* Test if the channel (push address on stack) has input. If not so remove the
 392  * channel pointer and jump to NO.  Otherwise input values.
 393  */
 394 {
 395         int YES=0;
 396         register struct expr_list *elp;
 397
 398         if (err) return;
 399
 400         code_addr(e->u.io.chan);
 401         cal("chan_any");
 402         lfr(wz);
 403         tst();
 404         zne(new_label(&YES));
 405         asp(pz);
 406         branch(NO);
 407         Label(YES);
 408         elp=e->u.io.args;
 409         while (elp!=nil) {
 410                 code_input(elp->arg);
 411                 elp=elp->next;
 412         }
 413         asp(pz);
 414 }
 415
 416 void code_void(e) register struct expr *e;
 417 /* Assignment, I/O, or procedure call. */
 418 {
 419         if (err) return;
 420
 421         switch (e->kind) {
 422         case E_NODE:    /* Must be assignment */
 423                 code_assignment(e);
 424                 break;
 425         case E_IO: {
 426                 register struct expr_list *elp;
 427
 428                 code_addr(e->u.io.chan);
 429
 430                 elp=e->u.io.args;
 431                 while (elp!=nil) {
 432                         if (e->u.io.out)
 433                                 code_output(elp->arg);
 434                         else
 435                                 code_input(elp->arg);
 436                         elp=elp->next;
 437                 }
 438                 asp(pz);
 439                 }
 440                 break;
 441         case E_CALL: {
 442                 register size=0;
 443                 register struct expr_list *elp=e->u.call.c_args;
 444                 register struct symbol *proc=e->u.call.c_proc->u.var;
 445                 register struct par_list *pars=proc->s_info.proc.pars;
 446
 447                 while (elp!=nil) {
 448                         if (pars->pr_type==T_VALUE) {
 449                                 code_val(elp->arg);
 450                                 size+=vz;
 451                         } else {
 452                                 code_addr(elp->arg);
 453                                 size+=pz;
 454                         }
 455                         elp=elp->next;
 456                         pars=pars->pr_next;
 457                 }
 458                 if (proc->s_type&T_BUILTIN) {
 459                         cal(proc->s_info.proc.st.builtin);
 460                         asp(size);
 461                 } else {
 462                         if (proc->s_info.proc.st.level>curr_level) {
 463                                 /* Call down */
 464                                 lor0();
 465                         } else
 466                         if (proc->s_info.proc.st.level==curr_level) {
 467                                 /* Call at same level */
 468                                 Lolp(0);
 469                         } else {
 470                                 /* Call up */
 471                                 lxa(curr_level-proc->s_info.proc.st.level);
 472                                 loi(pz);
 473                         }
 474                         cal(proc_label(proc->s_info.proc.label, proc->s_name));
 475                         asp(size+pz);
 476                         if (proc->s_info.proc.file!=curr_file) fil();
 477                 }
 478                 } break;
 479         }
 480 }
 481
 482 void prologue(proc) register struct symbol *proc;
 483 /* Open up the scope for a new proc definition. */
 484 {
 485         static P=0;
 486
 487         if (err) return;
 488
 489         proc->s_info.proc.st.level= ++curr_level;
 490         proc->s_info.proc.file= curr_file;
 491         proc->s_info.proc.label= ++P;
 492         curr_offset=min_offset=0;
 493         pro(proc_label(proc->s_info.proc.label, proc->s_name));
 494         if (curr_level==1) fil();
 495 }
 496
 497 void epilogue(proc) register struct symbol *proc;
 498 /* Close the scope of a proc def. */
 499 {
 500         if (err) return;
 501
 502         curr_level--;
 503         ret(0);
 504         x_end(-min_offset);
 505 }
 506
 507 void rep_init(v, e1, e2, r_info)
 508         struct symbol *v;
 509         register struct expr *e1, *e2;
 510         register struct replicator *r_info;
 511 /* Compile v=[e1 FOR e2].  Info tells rep_test what decisions rep_init makes. */
 512 {
 513         if (err) return;
 514
 515         r_info->BEGIN=r_info->END=0;
 516
 517         code_val(e1);
 518         Stl(v->s_info.vc.offset);
 519
 520         if (!constant(e1) || !constant(e2)) {
 521                 if (constant(e2) && word_constant(e2->u.cst)) {
 522                         r_info->counter=memory(wz);
 523                         loc((int) e2->u.cst);
 524                         stl(r_info->counter);
 525                 } else {
 526                         r_info->counter=memory(vz);
 527                         code_val(e2);
 528                         Stl(r_info->counter);
 529                 }
 530         }
 531         if (!constant(e2) || e2->u.cst<=0L)
 532                 branch(&r_info->END);
 533         Label(new_label(&r_info->BEGIN));
 534 }
 535
 536 void rep_test(v, e1, e2, r_info)
 537         register struct symbol *v;
 538         register struct expr *e1, *e2;
 539         register struct replicator *r_info;
 540 {
 541         if (err) return;
 542
 543         Inl(v->s_info.vc.offset);
 544
 545         if (constant(e1) && constant(e2)) {
 546                 Lol(v->s_info.vc.offset);
 547                 Loc(e1->u.cst+e2->u.cst);
 548                 if (vz>wz) {
 549                         cmi();
 550                         zlt(r_info->BEGIN);
 551                 } else
 552                         blt(r_info->BEGIN);
 553                 Label(r_info->END);
 554         } else {
 555                 if (constant(e2) && word_constant(e2->u.cst)) {
 556                         del(r_info->counter);
 557                         Label(r_info->END);
 558                         lol(r_info->counter);
 559                         tst();
 560                 } else {
 561                         Del(r_info->counter);
 562                         Label(r_info->END);
 563                         Lol(r_info->counter);
 564                         if (vz>wz) {
 565                                 ldc0();
 566                                 cmi();
 567                         } else
 568                                 tst();
 569                 }
 570                 zgt(r_info->BEGIN);
 571         }
 572 }
 573
 574 void chan_init(info, arr_siz) union type_info *info; int arr_siz;
 575 /* Garbage disposal unit for fresh channels. */
 576 {
 577         if (err) return;
 578
 579         loc(arr_siz);
 580         lal(info->vc.offset);
 581         cal("c_init");
 582         asp(wz+pz);
 583 }
 584
 585 void leader()
 586 {
 587         init();
 588         openfile((char *) nil);
 589         magic();
 590         meswp();
 591         maxdes();
 592 }
 593
 594 void header()
 595 {
 596         exp("main");
 597         pro("main");
 598         init_rt();
 599         main_fil();
 600 }
 601
 602 void trailer()
 603 {
 604         if (err)
 605                 meserr();
 606         else {
 607                 loc(0);
 608                 ret(wz);
 609                 x_end(-min_offset);
 610         }
 611         closefile();
 612 }