src/int/control.c

   1 /*     Loglan82 Compiler&Interpreter
   2      Copyright (C) 1993 Institute of Informatics, University of Warsaw
   3      Copyright (C)  1993, 1994 LITA, Pau
   4
   5      This program is free software; you can redistribute it and/or modify
   6      it under the terms of the GNU General Public License as published by
   7      the Free Software Foundation; either version 2 of the License, or
   8      (at your option) any later version.
   9
  10      This program is distributed in the hope that it will be useful,
  11      but WITHOUT ANY WARRANTY; without even the implied warranty of
  12      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13      GNU General Public License for more details.
  14
  15              You should have received a copy of the GNU General Public License
  16              along with this program; if not, write to the Free Software
  17              Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18
  19  contacts:  Andrzej.Salwicki@univ-pau.fr
  20
  21 or             Andrzej Salwicki
  22                 LITA   Departement d'Informatique
  23                 Universite de Pau
  24                 Avenue de l'Universite
  25                 64000 Pau   FRANCE
  26                  tel.  ++33 59923154    fax. ++33 59841696
  27
  28 =======================================================================
  29 */
  30
  31 #include "depend.h"
  32 #include "genint.h"
  33 #include "int.h"
  34 #include "process.h"
  35 #include "intproto.h"
  36
  37 /* Transfer of control routines */
  38 #ifndef NO_PROTOTYPES
  39 static void att2(virtaddr *, word, word);
  40 static void back1(word, word, virtaddr *, word *);
  41 #else
  42 static void att2();
  43 static void back1();
  44 #endif
  45
  46 /**
  47  *Transfer control to the newly created object.
  48  */
  49 void go(word ah, word am)
  50 {
  51         protdescr *ptr;
  52         word pnum, plen, node, apt;
  53         message msg;
  54
  55         ptr = prototype[M[am + PROTNUM]];
  56         apt = am + M[am];
  57         /* new process creation */
  58         if (ptr->kind == PROCESS) {
  59                 /* save template address */
  60                 thisp->template.addr = ah;
  61                 thisp->template.mark = M[ah + 1];
  62                 msg.control.type = CREATE;
  63                 msg.control.par = M[am + PROTNUM];
  64                 moveparams(thispix, am, &msg, PARIN, LOADPAR);
  65                 /* pix  will create receiver */
  66                 msg.control.receiver.pix = 0;
  67                 /* mark will create receiver */
  68                 msg.control.receiver.mark= 0;
  69                 /* node we decided  */
  70                 msg.control.receiver.node = getnode(am);
  71                 /* send create request */
  72                 sendmsg1(&msg);
  73 #ifdef RPCDBG
  74                 fprintf(stderr, "send new process from %d to node %d\n",
  75                                         thispix, msg.control.receiver.node);
  76 #endif
  77                 /* and wait for return from process */
  78                 passivate(WAITFORNEW);
  79         } else if (isprocess((virtaddr*)(M+apt+SL))) {
  80                 /* remote procedure call */
  81                 /* save template address */
  82                 thisp->backobj.addr = ah;
  83                 thisp->backobj.mark = M[ah + 1];
  84                 /* physical address also */
  85                 thisp->M[temporary] = am;
  86                 {
  87                         virtaddr v;
  88                         loadvirt(v, apt + SL);
  89                         obj2mess(M, &v, &msg.control.receiver);
  90
  91                 /*
  92                         fprintf(
  93                                 stderr, "send rpc from process %d to (%d,%d,%d)\n",
  94                                 thispix,
  95                                 msg.control.receiver.node,
  96                                 msg.control.receiver.pix,
  97                                 msg.control.receiver.mark
  98                         );*/
  99
 100                 }
 101                 msg.control.type = RPCALL;
 102                 msg.control.par = M[am + PROTNUM];
 103                 moveparams(thispix, am, &msg, PARIN, LOADPAR);
 104                 /* send RPC request */
 105                 sendmsg1(&msg);
 106                 /* and wait for RP return */
 107                 passivate(WAITFORRPC);
 108         } else {
 109                 /* save local control */
 110                 M[c1 + M[c1] + LSC] = ic;
 111                 /* release DISPLAY */
 112                 loosen();
 113                 /* update DISPLAY */
 114                 update(am, ah);
 115                 /* new current */
 116                 c1 = am;
 117                 c2 = c1 + ptr->span;
 118                 pnum = ptr->preflist;
 119                 plen = ptr->lthpreflist;
 120                 /* search for executable prefix */
 121                 while (TRUE)
 122                         if (plen <= 1) {
 123                                 ic = ptr->codeaddr;
 124                                 break;
 125                         } else {
 126                                 ptr = prototype[M[pnum]];
 127                                 plen--;
 128                                 pnum++;
 129                                 if (ptr->kind != RECORD)
 130                                         plen = 0;
 131                         }
 132         }
 133 }
 134
 135
 136 /**
 137  * Transfer control to a local unprefixed procedure, function, block,
 138  * class or coroutine.
 139  */
 140 void goloc(word ah, word am)
 141 {
 142         word t1;
 143         protdescr *ptr;
 144
 145         /* save local control */
 146         M[c1 + M[c1] + LSC] = ic;
 147         /* new current */
 148         c1 = am;
 149         t1 = M[am + PROTNUM];
 150         ptr = prototype[t1];
 151         c2 = am + ptr->span;
 152         ic = ptr->codeaddr;
 153         /* simulate update display */
 154         M[display + t1] = am;
 155         M[display2 + t1] = ah;
 156         M[am + M[am]+STATSL ]++;
 157 }
 158
 159 /** Return from block. */
 160 void backbl(virtaddr *virt, word *am)
 161 {
 162         word t1;
 163
 164         t1 = M[c1 + PROTNUM];
 165         virt->addr = M[display2 + t1];
 166         /* prepare old address */
 167         virt->mark = M[virt->addr + 1];
 168         /* am of old */
 169         *am = c1;
 170         /* simulate loosen */
 171         M[display + t1] = 0;
 172         t1 = c1 + M[c1];
 173         /* remove from SL chain */
 174         M[t1 + STATSL]--;
 175         /* return up along SL */
 176         c1 = M[t1 + SL];
 177         /* return from main */
 178         if (c1 == DUMMY)
 179                 endprocess(0);
 180
 181         /* am of new current */
 182         c1 = M[c1];
 183         c2 = c1 + prototype[M[c1 + PROTNUM]]->span;
 184         ic = M[c1 + M[c1] + LSC];
 185         /* force DL consistency */
 186         storevirt(*virt, *am + M[*am]+DL);
 187 }
 188
 189
 190 /* Common code for some backs below. */
 191 static void back1(word at1, word at2, virtaddr *virt, word *am)
 192 {
 193         word t1;
 194
 195         loosen();
 196         if (at1 == 0)
 197                 endprocess(0);
 198         t1 = M[c1 + PROTNUM];
 199         /* ah of old */
 200         virt->addr = M[display2 + t1];
 201         virt->mark = M[virt->addr + 1];
 202         /* am of old */
 203         *am = c1;
 204         /* loop up DL */
 205         storevirt(*virt, at2);
 206         /* am of DL */
 207         at2 = M[at1];
 208         update(at2, at1);
 209         c1 = at2;
 210         c2 = c1 + prototype[M[c1 + PROTNUM]]->span;
 211         ic = M[c1 + M[c1] + LSC];
 212 }
 213
 214
 215 /**
 216  * Return from classes, coroutines and by end from procedures.
 217  */
 218 void back(virtaddr *virt, word *am, word length)
 219         {
 220         word t1, t2, plist;
 221         int i;
 222         protdescr *ptr;
 223         message msg;
 224
 225         t2 = c1 + M[c1];
 226         /* ah of DL */
 227         t1 = M[t2 + DL];
 228         /* prototype of current */
 229         ptr = prototype[M[c1 + PROTNUM]];
 230         /* RETURN in process */
 231         if (ptr->kind == PROCESS) {
 232 #ifdef RPCDBG
 233                 fprintf( stderr, "return from process %d\n", thispix);
 234 #endif
 235                 if (M[c1 + PROTNUM] == MAINBLOCK)
 236                         endprocess(0);
 237                 {
 238                         virtaddr v;
 239                         loadvirt(v, t2 + DL);
 240                         /* father process */
 241                         obj2mess(M, &v, &msg.control.receiver);
 242                 }
 243                 msg.control.type = CREACK;
 244                 moveparams(thispix, c1, &msg, PAROUT, LOADPAR);
 245                 /* send create acknowledge */
 246                 sendmsg1(&msg);
 247                 /* cut DL of new process head */
 248                 M[t2 + DL] = 0;
 249                 /* and suspend new process */
 250                 passivate(STOPPED);
 251         } else if (ptr->kind == COROUTINE) {
 252         /* nothing if detached */
 253                 if (t1 != 0) {
 254                         M[t2 + LSC] = ic;
 255                         back1(t1, t2 + DL, virt, am);
 256                 }
 257         } else {
 258                 /* save begining of prototype list */
 259                 plist = ic;
 260                 if (ptr->lthpreflist == 1 && t1 == M[t2 + SL] &&
 261                                         M[t2 + DL + 1] == M[t2 + SL + 1])
 262                         backbl(virt, am);
 263                 else
 264                         back1(t1, t2 + DL, virt, am);
 265
 266 /*
 267 #ifdef RPCDBG
 268             fprintf(
 269                      stderr, "back (thisp=%d) from %s to %s\n",
 270                      thispix,
 271                      (
 272                        (ptr->kind==PROCEDURE) ?
 273                          "PROCEDURE"          :
 274                        (ptr->kind==FUNCTION)  ?
 275                          "FUNCTION"           :
 276                          "???"
 277                      ),
 278                      isprocess((virtaddr*)(M+t2+RPCDL)) ? "PROCESS" : "OBJECT"
 279                    );
 280 #endif
 281 */
 282                 if ((ptr->kind == PROCEDURE || ptr->kind == FUNCTION) &&
 283                                         isprocess((virtaddr*)(M+t2+RPCDL))) {
 284
 285                         {
 286                                 virtaddr v;
 287                                 loadvirt(v, t2 + RPCDL);
 288                                 /* remote DL */
 289                                 obj2mess(M, &v, &msg.control.receiver);
 290                         }
 291
 292                         /*
 293                         fprintf(stderr,
 294                                 "send rpc ack from process %d to (%d,%d,%d)\n",
 295                                 thispix,
 296                                 msg.control.receiver.node,
 297                                 msg.control.receiver.pix,
 298                                 msg.control.receiver.mark
 299                         );
 300                         */
 301                         msg.control.type = RPCACK;
 302                         moveparams(thispix, *am, &msg, PAROUT, LOADPAR);
 303                         /* send RP return - acknowledge */
 304                         sendmsg1(&msg);
 305                         /* kill procedure object manualy */
 306                         gkill(virt);
 307                         /* restore RPC mask from stack */
 308                         popmask(thispix);
 309                         /* and modify it */
 310                         for (i = 0; i < length; i++) {
 311                                 /* prototype number */
 312                                 t1 = virtprot(M[plist++]);
 313                                 if (t1 > 0)
 314                                         enable(thispix, t1);
 315                                 else
 316                                         disable(thispix, -t1);
 317                         }
 318                         /* check for enabled RPCs */
 319                         evaluaterpc(thispix);
 320                 }
 321         }
 322 }
 323
 324
 325 /**
 326  * Return, end in procedures and functions without prefix.
 327  */
 328 void backpr(virtaddr *virt, word *am)
 329 {
 330         word t1, t2, t3;
 331         /* DL pointer of current */
 332         t2 = c1 + M[c1] + DL;
 333         /* ah of DL */
 334         t1 = M[t2];
 335         /* SL pointer */
 336         t3 = c1 + M[c1]+SL;
 337         /* SL=DL */
 338         if (t1 == M[t3] && M[t2 + 1] == M[t3 + 1])
 339                 backbl(virt, am);
 340         else
 341                 back1(t1, t2, virt, am);
 342 }
 343
 344 /** End in classes and coroutines. */
 345 void fin(word backic, virtaddr *virt, word *am)
 346 {
 347         word t1, t2, knd;
 348
 349         knd = prototype[M[c1 + PROTNUM]]->kind;
 350         if (knd != COROUTINE && knd != PROCESS) {
 351                 /* a class - exit as above */
 352                 back(virt, am, (word) 0);
 353         }
 354         else {
 355                 /* backspace ic */
 356                 ic = backic;
 357                 t2 = c1 + M[c1];
 358                 /* ah of DL */
 359                 t1 = M[t2 + DL];
 360                 if (t1 == 0) {
 361                         if (M[t2 + SL] == DUMMY)
 362                                 endprocess(0);
 363                         /* coroutine terminated */
 364                         ic = 0;
 365                         *am = 0;
 366                         detach();
 367                 } else {
 368                         M[t2 + LSC] = ic;
 369                         back1(t1, t2 + DL, virt, am);
 370                 }
 371         }
 372 }
 373
 374 /** Helper for attach/detach */
 375 static void att2(virtaddr *virt, word ax, word at1)
 376 {
 377         word t1, t2, phead;
 378
 379         /* ah of current */
 380         t1 = M[display2 + M[c1 + PROTNUM]];
 381         /* DL of coroutine head */
 382         t2 = at1 + M[at1] + DL;
 383         /* loop up DL */
 384         M[t2] = t1;
 385         M[t2 + 1] = M[t1 + 1];
 386         /* preserve local control */
 387         M[c1 + M[c1] + LSC] = ic;
 388         loosen();
 389         phead = thisp->prochead;
 390         storevirt(*virt, phead + M[phead] + CHD);
 391         t2 = M[ax + DL];
 392         /* coroutine active */
 393         if (t2 == 0)
 394                 errsignal(RTECORAC);
 395         /* cut DL of new coroutine head */
 396         M[ax + DL] = 0;
 397         c1 = M[t2];
 398         update(c1, t2);
 399         c2 = c1 + prototype[M[c1 + PROTNUM]]->span;
 400         ic = M[ c1 + M[c1] + LSC];
 401         /* coroutine terminated */
 402         if (ic == 0)
 403                 errsignal(RTECORTM);
 404 }
 405
 406
 407 void attach(virtaddr *virt)
 408 {
 409         word t1, ax, phead, chead;
 410         int knd;
 411
 412         if (M[virt->addr + 1] != virt->mark)
 413                 errsignal(RTEILLAT);
 414         else {
 415                 /* am */
 416                 ax = M[virt->addr];
 417         }
 418         t1 = M[ax + PROTNUM];
 419         if (t1 == AINT || t1 == AREAL || t1 == AVIRT || t1 == FILEOBJECT)
 420                 errsignal(RTEILLAT);
 421         knd = prototype[t1]->kind;
 422         if (knd != COROUTINE && knd != PROCESS)
 423                 errsignal(RTEILLAT);
 424         ax = ax + M[ax];
 425         phead = thisp->prochead;
 426         chead = phead + M[phead] + CHD;
 427         if (virt->addr != M[chead] || virt->mark != M[chead + 1]) {
 428                 M[ax + CL] = M[chead];
 429                 M[ax + CL + 1] = M[chead + 1];
 430                 att2(virt, ax, M[M[chead]]);
 431         }
 432 }
 433
 434
 435 void detach()
 436 {
 437         virtaddr virt;
 438         word t1, phead;
 439
 440         phead = thisp->prochead;
 441         /* am of coroutine head */
 442         t1 = M[M[phead + M[phead] + CHD]];
 443         /* coroutine link */
 444         loadvirt(virt, t1 + M[t1] + CL);
 445         if (M[virt.addr + 1] != virt.mark)
 446                 errsignal(RTEILLDT);
 447         att2(&virt, M[virt.addr] + M[M[virt.addr]], t1);
 448 }
 449
 450 /* Simulate execution of inner */
 451 void inner(word level)
 452 {
 453         word t1;
 454         protdescr *ptr;
 455
 456         /* prototype of current */
 457         ptr = prototype[M[c1 + PROTNUM]];
 458         t1 = ptr->lthpreflist;
 459         if (t1 != level)
 460                 if (level == t1-1)
 461                         ic = ptr->codeaddr;
 462                 else
 463                         ic = prototype[M[ptr->preflist + level]]->codeaddr;
 464 }
 465