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