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
  39 #ifndef NO_PROTOTYPES
  40 static void att2(virtaddr *, word, word);
  41 static void back1(word, word, virtaddr *, word *);
  42 #else
  43 static void att2();
  44 static void back1();
  45 #endif
  46
  47 /* Transfer control to the newly created object.
  48  */
  49
  50 void go(ah, am)
  51 word ah, am;
  52 {
  53     protdescr *ptr;
  54     word pnum, plen, node, apt;
  55     message msg;
  56
  57     ptr = prototype[ M[ am+PROTNUM ] ];
  58     apt = am+M[ am ];
  59     if (ptr->kind == PROCESS)           /* new process creation */
  60     {
  61         thisp->template.addr = ah;      /* save template address */
  62         thisp->template.mark = M[ ah+1 ];
  63         msg.control.type = CREATE;
  64         msg.control.par = M[ am+PROTNUM ];
  65         moveparams(thispix, am, &msg, PARIN, LOADPAR);
  66         msg.control.receiver.pix = 0;           /* pix  will create receiver */
  67         msg.control.receiver.mark= 0;           /* mark will create receiver */
  68         msg.control.receiver.node = getnode(am);        /* node we decided  */
  69         sendmsg1( &msg);        /* send create request */
  70 #       ifdef RPCDBG
  71         fprintf(
  72                 stderr, "send new process from %d to node %d\n",
  73                 thispix,
  74                 msg.control.receiver.node
  75                );
  76 #       endif
  77         passivate(WAITFORNEW);          /* and wait for return from process */
  78     }
  79     else
  80         if (isprocess((virtaddr*)(M+apt+SL)))   /* remote procedure call */
  81         {
  82             thisp->backobj.addr = ah;   /* save template address */
  83             thisp->backobj.mark = M[ ah+1 ];
  84             thisp->M[ temporary ] = am; /* physical address also */
  85             {
  86                virtaddr v;
  87                loadvirt( v, apt+SL );
  88                obj2mess( M, &v, &msg.control.receiver );
  89
  90               /* fprintf(
  91                         stderr, "send rpc from process %d to (%d,%d,%d)\n",
  92                         thispix,
  93                         msg.control.receiver.node,
  94                         msg.control.receiver.pix,
  95                         msg.control.receiver.mark
  96                       );*/
  97
  98             }
  99             msg.control.type = RPCALL;
 100             msg.control.par = M[ am+PROTNUM ];
 101             moveparams(thispix, am, &msg, PARIN, LOADPAR);
 102             sendmsg1( &msg);    /* send RPC request */
 103             passivate(WAITFORRPC);      /* and wait for RP return */
 104         }
 105         else
 106         {
 107             M[ c1+M[ c1 ]+LSC ] = ic;   /* save local control */
 108             loosen();                   /* release DISPLAY */
 109             update(am, ah);             /* update DISPLAY */
 110             c1 = am;                    /* new current */
 111             c2 = c1+ptr->span;
 112             pnum = ptr->preflist;
 113             plen = ptr->lthpreflist;
 114             while (TRUE)                /* search for executable prefix */
 115                 if (plen <= 1)
 116                 {
 117                     ic = ptr->codeaddr;
 118                     break;
 119                 }
 120                 else
 121                 {
 122                     ptr = prototype[ M[ pnum ] ];
 123                     plen--;
 124                     pnum++;
 125                     if (ptr->kind != RECORD) plen = 0;
 126                 }
 127         }
 128 }
 129
 130
 131 /* Transfer control to a local unprefixed procedure, function, block,
 132  * class or coroutine.
 133  */
 134
 135 void goloc(ah, am)
 136 word ah, am;
 137 {
 138     word t1;
 139     protdescr *ptr;
 140
 141     M[ c1+M[ c1 ]+LSC ] = ic;           /* save local control */
 142     c1 = am;                            /* new current */
 143     t1 = M[ am+PROTNUM ];
 144     ptr = prototype[ t1 ];
 145     c2 = am+ptr->span;
 146     ic = ptr->codeaddr;
 147     M[ display+t1 ] = am;               /* simulate update display */
 148     M[ display2+t1 ] = ah;
 149     M[ am+M[ am ]+STATSL ]++;
 150 }
 151
 152
 153 void backbl(virt, am)                   /* Return from block. */
 154 virtaddr *virt;
 155 word *am;
 156 {
 157     word t1;
 158
 159     t1 = M[ c1+PROTNUM ];
 160     virt->addr = M[ display2+t1 ];
 161     virt->mark = M[ virt->addr+1 ];     /* prepare old address */
 162     *am = c1;                           /* am of old */
 163     M[ display+t1 ] = 0;                /* simulate loosen */
 164     t1 = c1+M[ c1 ];
 165     M[ t1+STATSL ]--;                   /* remove from SL chain */
 166     c1 = M[ t1+SL ];                    /* return up along SL */
 167     if (c1 == DUMMY) endprocess(0);     /* return from main */
 168     c1 = M[ c1 ];                       /* am of new current */
 169     c2 = c1+prototype[ M[ c1+PROTNUM ] ]->span;
 170     ic = M[ c1+M[ c1 ]+LSC ];
 171     storevirt(*virt, *am+M[ *am ]+DL);  /* force DL consistency */
 172 }
 173
 174
 175 static void back1(at1, at2, virt, am)   /* Common code for some backs below. */
 176 word at1, at2;
 177 virtaddr *virt;
 178 word *am;
 179 {
 180     word t1;
 181
 182     loosen();
 183     if (at1 == 0) endprocess(0);
 184     t1 = M[ c1+PROTNUM ];
 185     virt->addr = M[ display2+t1 ];      /* ah of old */
 186     virt->mark = M[ virt->addr+1 ];
 187     *am = c1;                           /* am of old */
 188     storevirt(*virt, at2);              /* loop up DL */
 189     at2 = M[ at1 ];                     /* am of DL */
 190     update(at2, at1);
 191     c1 = at2;
 192     c2 = c1 + prototype[ M[ c1+PROTNUM ] ]->span;
 193     ic = M[ c1+M[ c1 ]+LSC ];
 194 }
 195
 196
 197 /* Return from classes, coroutines and by end from procedures.
 198  */
 199
 200 void back(virt, am, length)
 201 virtaddr *virt;
 202 word *am;
 203 word length;
 204 {
 205     word t1, t2, plist;
 206     int i;
 207     protdescr *ptr;
 208     message msg;
 209
 210     t2 = c1+M[ c1 ];
 211     t1 = M[ t2+DL ];                    /* ah of DL */
 212     ptr = prototype[ M[ c1+PROTNUM ] ]; /* prototype of current */
 213     if (ptr->kind == PROCESS)           /* RETURN in process */
 214     {
 215 #       ifdef RPCDBG
 216         fprintf( stderr, "return from process %d\n", thispix );
 217 #       endif
 218         if (M[ c1+PROTNUM ] == MAINBLOCK) endprocess(0);
 219         {
 220            virtaddr v;
 221            loadvirt( v, t2+DL );
 222            obj2mess( M, &v, &msg.control.receiver ); /* father process */
 223         }
 224         msg.control.type = CREACK;
 225         moveparams(thispix, c1, &msg, PAROUT, LOADPAR);
 226         sendmsg1(&msg);                 /* send create acknowledge */
 227         M[ t2+DL ] = 0;                 /* cut DL of new process head */
 228         passivate(STOPPED);             /* and suspend new process */
 229     }
 230     else
 231         if (ptr->kind == COROUTINE)
 232         {
 233             if (t1 != 0)                /* nothing if detached */
 234             {
 235                 M[ t2+LSC ] = ic;
 236                 back1(t1, t2+DL, virt, am);
 237             }
 238         }
 239         else
 240         {
 241             plist = ic;                 /* save begining of prototype list */
 242             if (ptr->lthpreflist==1 && t1==M[t2+SL] && M[t2+DL+1]==M[t2+SL+1])
 243                 backbl(virt, am);
 244             else
 245                 back1(t1, t2+DL, virt, am);
 246
 247 /*
 248 #           ifdef RPCDBG
 249             fprintf(
 250                      stderr, "back (thisp=%d) from %s to %s\n",
 251                      thispix,
 252                      (
 253                        (ptr->kind==PROCEDURE) ?
 254                          "PROCEDURE"          :
 255                        (ptr->kind==FUNCTION)  ?
 256                          "FUNCTION"           :
 257                          "???"
 258                      ),
 259                      isprocess((virtaddr*)(M+t2+RPCDL)) ? "PROCESS" : "OBJECT"
 260                    );
 261 #           endif
 262 */
 263             if ((ptr->kind == PROCEDURE || ptr->kind == FUNCTION) &&
 264                 isprocess((virtaddr*)(M+t2+RPCDL)))
 265             {
 266                 {
 267                    virtaddr v;
 268                    loadvirt( v, t2+RPCDL );
 269                    obj2mess( M, &v, &msg.control.receiver ); /* remote DL */
 270                 }
 271
 272                 /*fprintf(
 273                          stderr, "send rpc ack from process %d to (%d,%d,%d)\n",
 274                          thispix,
 275                          msg.control.receiver.node,
 276                          msg.control.receiver.pix,
 277                          msg.control.receiver.mark
 278                        );*/
 279
 280                 msg.control.type = RPCACK;
 281                 moveparams(thispix, *am, &msg, PAROUT, LOADPAR);
 282                 sendmsg1(&msg);         /* send RP return - acknowledge */
 283                 gkill(virt);            /* kill procedure object manualy */
 284                 popmask(thispix);       /* restore RPC mask from stack */
 285                 for (i = 0;  i < length;  i++)    /* and modify it */
 286                 {
 287                     t1 = virtprot(M[ plist++ ]);  /* prototype number */
 288                     if (t1 > 0) enable(thispix, t1);
 289                     else disable(thispix, -t1);
 290                 }
 291                 evaluaterpc(thispix);   /* check for enabled RPCs */
 292             }
 293         }
 294 }
 295
 296
 297 /* Return, end in procedures and functions without prefix.
 298  */
 299
 300 void backpr(virt, am)
 301 virtaddr *virt;
 302 word *am;
 303 {
 304     word t1, t2, t3;
 305
 306     t2 = c1+M[ c1 ]+DL;                 /* DL pointer of current */
 307     t1 = M[ t2 ];                       /* ah of DL */
 308     t3 = c1+M[ c1 ]+SL;                 /* SL pointer */
 309     if (t1 == M[ t3 ] && M[ t2+1 ] == M[ t3+1 ]) backbl(virt, am);  /* SL=DL */
 310     else back1(t1, t2, virt, am);
 311 }
 312
 313
 314 void fin(backic, virt, am)              /* End in classes and coroutines. */
 315 word backic;
 316 virtaddr *virt;
 317 word *am;
 318 {
 319     word t1, t2, knd;
 320
 321     knd = prototype[ M[ c1+PROTNUM ] ]->kind;
 322     if (knd != COROUTINE && knd != PROCESS)
 323         back(virt, am, (word) 0);       /* a class - exit as above */
 324     else
 325     {
 326         ic = backic;                    /* backspace ic */
 327         t2 = c1+M[ c1 ];
 328         t1 = M[ t2+DL ];                /* ah of DL */
 329         if (t1 == 0)
 330         {
 331             if (M[ t2+SL ] == DUMMY) endprocess(0);
 332             ic = 0;                     /* coroutine terminated */
 333             *am = 0;
 334             detach();
 335         }
 336         else
 337         {
 338             M[ t2+LSC ] = ic;
 339             back1(t1, t2+DL, virt, am);
 340         }
 341     }
 342 }
 343
 344
 345 static void att2(virt, ax, at1)         /* Helper for attach/detach */
 346 virtaddr *virt;
 347 word ax, at1;
 348 {
 349     word t1, t2, phead;
 350
 351     t1 = M[ display2+M[ c1+PROTNUM ] ]; /* ah of current */
 352     t2 = at1+M[ at1 ]+DL;               /* DL of coroutine head */
 353     M[ t2 ] = t1;                       /* loop up DL */
 354     M[ t2+1 ] = M[ t1+1 ];
 355     M[ c1+M[ c1 ]+LSC ] = ic;           /* preserve local control */
 356     loosen();
 357     phead = thisp->prochead;
 358     storevirt(*virt, phead+M[ phead ]+CHD);
 359     t2 = M[ ax+DL ];
 360     if (t2 == 0) errsignal(RTECORAC);   /* coroutine active */
 361     M[ ax+DL ] = 0;                     /* cut DL of new coroutine head */
 362     c1 = M[ t2 ];
 363     update(c1, t2);
 364     c2 = c1+prototype[ M[ c1+PROTNUM ] ]->span;
 365     ic = M[ c1+M[ c1 ]+LSC ];
 366     if (ic == 0) errsignal(RTECORTM);   /* coroutine terminated */
 367 }
 368
 369
 370 void attach(virt)
 371 virtaddr *virt;
 372 {
 373     word t1, ax, phead, chead;
 374     int knd;
 375
 376     if (M[ virt->addr+1 ] != virt->mark) errsignal(RTEILLAT);
 377     else ax = M[ virt->addr ];          /* am */
 378     t1 = M[ ax+PROTNUM ];
 379     if (t1 == AINT || t1 == AREAL || t1 == AVIRT || t1 == FILEOBJECT)
 380         errsignal(RTEILLAT);
 381     knd = prototype[ t1 ]->kind;
 382     if (knd != COROUTINE && knd != PROCESS) errsignal(RTEILLAT);
 383     ax = ax+M[ ax ];
 384     phead = thisp->prochead;
 385     chead = phead+M[ phead ]+CHD;
 386     if (virt->addr != M[ chead ] || virt->mark != M[ chead+1 ])
 387     {
 388         M[ ax+CL ] = M[ chead ];
 389         M[ ax+CL+1 ] = M[ chead+1 ];
 390         att2(virt, ax, M[ M[ chead ] ]);
 391     }
 392 }
 393
 394
 395 void detach()
 396 {
 397     virtaddr virt;
 398     word t1, phead;
 399
 400     phead = thisp->prochead;
 401     t1 = M[ M[ phead+M[ phead ]+CHD ] ]; /* am of coroutine head */
 402     loadvirt(virt, t1+M[ t1 ]+CL);      /* coroutine link */
 403     if (M[ virt.addr+1 ] != virt.mark) errsignal(RTEILLDT);
 404     att2(&virt, M[ virt.addr ]+M[ M[ virt.addr ] ], t1);
 405 }
 406
 407
 408 void inner(level)                       /* Simulate execution of inner */
 409 word level;
 410 {
 411     word t1;
 412     protdescr *ptr;
 413
 414     ptr = prototype[ M[ c1+PROTNUM ] ]; /* prototype of current */
 415     t1 = ptr->lthpreflist;
 416     if (t1 != level)
 417         if (level == t1-1) ic = ptr->codeaddr;
 418         else ic = prototype[ M[ ptr->preflist+level ] ]->codeaddr;
 419 }
 420
 421