--- /dev/null
+/* Loglan82 Compiler&Interpreter
+ Copyright (C) 1993 Institute of Informatics, University of Warsaw
+ Copyright (C) 1993, 1994 LITA, Pau
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ contacts: Andrzej.Salwicki@univ-pau.fr
+
+or Andrzej Salwicki
+ LITA Departement d'Informatique
+ Universite de Pau
+ Avenue de l'Universite
+ 64000 Pau FRANCE
+ tel. ++33 59923154 fax. ++33 59841696
+
+=======================================================================
+*/
+
+#include "depend.h"
+#include "genint.h"
+#include "int.h"
+#include "process.h"
+#include "intproto.h"
+
+#include <assert.h>
+
+
+#ifndef NO_PROTOTYPES
+
+static word get_pointer(word,word);
+static void phase1(void);
+static void phase2(void);
+static void phase2a(void);
+static void phase3(void);
+static void phase4(void);
+static void phase5(void);
+static void phase6(void);
+static void curtain(void);
+static void heap_walk(word);
+static void nonefy(virtaddr *);
+static void relocate(virtaddr *);
+static void traverse(word,void (*)(virtaddr *));
+static void what_we_have(virtaddr *);
+
+#else
+
+static word get_pointer();
+static void phase1();
+static void phase2();
+static void phase2a();
+static void phase3();
+static void phase4();
+static void phase5();
+static void phase6();
+static void curtain();
+static void heap_walk();
+static void nonefy();
+static void relocate();
+static void traverse();
+static void what_we_have();
+
+#endif
+
+
+#ifdef CDBG
+FILE *ff;
+static void what_we_have(va) virtaddr *va; {
+ fprintf(ff," pointer offset %d:|va=%d,va_m=%d,M[va]=%d,M[va+1]=%d|\n",
+ ((word*)va)-M,va->addr,va->mark,M[va->addr],M[va->addr+1]);
+ fflush(ff);
+}
+#endif
+
+
+/*
+ * Memory compactifier - a play in 6 acts
+ */
+
+static word nleng; /* free memory before compact. */
+static word curah; /* to preserve ah of current object */
+
+/* One of the actions for traverse: see below;
+ * converts none to absolute none, i.e. (0, 0)
+ */
+
+
+static void nonefy(va) virtaddr *va; {
+
+#ifdef CDBG
+ if(va->addr==0 && va->mark!=0){
+ fprintf(ff,"nonefy:|va=%d,va_m=%d,M[va]=%d,M[va+1]=%d|\n",
+ va->addr,va->mark,M[va->addr],M[va->addr+1]);
+ fflush(ff);
+ }
+#endif
+
+#ifndef OBJECTADDR
+ if(!isprocess(va))
+#else
+ assert( va->mark >= 0 );
+/* assert( va->mark <= M[ va->addr+1 ] );*/
+#endif
+#ifdef CDBG
+ fprintf(ff,"nonefy:|va=%d,va_mark=%d,am=%d,mark=%d|\n",
+ va->addr,va->mark,M[va->addr],M[va->addr+1]);
+ fflush(ff);
+#endif
+ if( va->mark != M[ va->addr+1 ] ) /* if NONE */
+ {
+
+#ifdef CDBG
+ fprintf(ff," set to NONE\n"); fflush(ff);
+#endif
+ va->addr = 0;
+ va->mark = 0;
+ }
+ assert( va->addr != 1 );
+} /* end nonefy */
+
+
+/* One of the actions for traverse; update the virtual address to
+ * correspond to its dictionary entry after compactification.
+ */
+
+static void relocate(va) virtaddr *va; {
+#ifndef OBJECTADDR
+ if(!isprocess(va)){
+#endif
+ va->addr = M[ va->addr+1 ]; /* new ah (after compression) */
+ va->mark = 0; /* clear mark */
+#ifndef OBJECTADDR
+ }
+#endif
+} /* end relocate */
+
+
+/* Traverse all the virtual variables of object am and perform action
+ * on each of them. Skip references to processes (see nonefy() and
+ * relocate()).
+ */
+
+static void traverse(am, action)
+ word am;
+#ifndef NO_PROTOTYPES
+ void (*action)(virtaddr *);
+#else
+ void (*action)();
+#endif
+{
+ word t1, t2, t3, length;
+ protdescr *ptr;
+
+ t1 = am+M[ am ]; /* LWA+1 of the object */
+ length = M[ am+PROTNUM ]; /* prototype number */
+ if (length == AINT || length == AREAL || length == AVIRT ||
+ length == FILEOBJECT
+#ifdef OBJECTADDR
+ || length == APROCESS
+#endif
+ )
+ {
+ if (length == AVIRT) /* ARRAYOF <reference> */
+ for (t2 = am+3; t2 < t1; t2 += 2)
+ (*action)((virtaddr *)(M+t2));
+ }
+ else /* neither an array nor a file */
+ {
+ ptr = prototype [ length ];
+ switch (ptr->kind) /* compute the number of the system */
+ /* virtual variables */
+ {
+ case RECORD : length = 0; t3 = 0; break;
+ case COROUTINE : length = 3; t3 = CL; break;
+ case PROCESS : length = 5; t3 = disp2off; break;
+ case FUNCTION :
+ case PROCEDURE : length = 2; t3 = RPCDL+1; break; /* PS */
+ case HANDLER : length = 2; t3 = SIGNR; break;
+ default : length = 2; t3 = STATSL; break;
+ }
+
+ /* action for system reference variables */
+ for (t2 = length; t2 >= 1; t2-- )
+ (*action)((virtaddr *)(M+t1+offset[ t2 ]));
+
+ /* action for temporary reference variables */
+ t1 = am+M[ am ]+t3;
+ for (t2 = am+ptr->span; t2 < t1; t2 += 2)
+ (*action)((virtaddr *)(M+t2));
+
+ /* action for user reference variables */
+ t1 = ptr->reflist;
+ for (t2 = t1+ptr->lthreflist-1; t2 >= t1; t2-- )
+ (*action)((virtaddr *)(M+am+M[ t2 ]));
+ }
+} /* end traverse */
+
+
+/* Mark killed objects by substituting prototype number by a special value.
+ * This way we will be able to tell apart the killed objects without
+ * recalling to the dictionary or to the list of killed objects.
+ */
+
+static void phase1()
+{
+ word t1, t2, t3, phead;
+
+ nleng = thisp->lastitem-thisp->lastused-1; /* free memory before comp. */
+ M[ 1 ] = 0; /* for proper update of none */
+ phead = thisp->prochead; /* head of current process */
+ M[ phead+M[ phead ]+SL ] = 0; /* make SL of head look like none */
+ t1 = thisp->headk2; /* flag killed objects */
+ while (t1 != 0) /* special list for appetite=2 */
+ {
+ t2 = t1+SHORTLINK;
+ t1 = M[ t2 ];
+ M[ t2 ] = SKILLED; /* flag object killed */
+ }
+ t1 = thisp->headk; /* now other killed objects */
+ while (t1 != thisp->lower)
+ {
+ t2 = t1;
+ while (t2 != 0)
+ {
+ t3 = t2+SHORTLINK;
+ t2 = M[ t3 ];
+ M[ t3 ] = SKILLED; /* flag object killed */
+ }
+ t1 = M[ t1+LONGLINK ]; /* goto other size list */
+ }
+} /* end phase1 */
+
+
+/* Step thru the memory area containing objects. For each object not being
+ * killed detect all its virtual variables pointing to none and convert
+ * them to absolute none i.e. (0, 0).
+ */
+
+static void phase2()
+{
+ word t1;
+
+ nonefy( &(thisp->procref ) );
+
+ t1 = thisp->lower+1; /* FWA of object area */
+ while (t1 <= thisp->lastused)
+ {
+
+#ifdef CDBG
+ fprintf(ff,"OBJECT am=%d,SIZE=%d,TYPE=%d\n",t1,M[t1],M[t1+1]);
+ fflush(ff);
+ if (M[ t1+1 ] != SKILLED) traverse(t1,what_we_have);
+#endif
+
+ if (M[ t1+1 ] != SKILLED) /* an active object */
+ traverse(t1, nonefy);
+ t1 += M[ t1 ]; /* next object address */
+ }
+} /* end phase2 */
+
+
+/* garbage collection */
+
+/* Find x-th pointer in am.
+ * Skip references to processes.
+ */
+
+static word get_pointer(am,x) word am,x; {
+
+ word t1, t2, t3, length, va;
+ protdescr *ptr;
+
+ t1 = am+M[ am ]; /* LWA+1 of the object */
+ length = M[ am+PROTNUM ]; /* prototype number */
+
+#ifdef CDBG
+ fprintf(ff,"|get_pointer(am=%d,x=%d)lenght=%d|",am,x,length);
+ fflush(ff);
+#endif
+
+ if (length == AINT || length == AREAL || length == AVIRT ||
+ length == FILEOBJECT
+#ifdef OBJECTADDR
+ || length == APROCESS
+#endif
+ )
+ {
+ if(length == AVIRT) /* ARRAYOF <reference> */
+ for(t2 = am+3; t2 < t1; t2 += 2){
+#ifndef OBJECTADDR
+ if(isprocess((virtaddr *)(M+t2))) continue;
+#endif
+ if(M[t2]==0){ assert( M[t2+1]==0 ); continue; }
+#ifdef CDBG
+ fprintf(ff,"ARR");
+ fflush(ff);
+#endif
+ if(x==0){
+#ifdef CDBG
+ fprintf(ff,"=%d|\n",t2);
+ fflush(ff);
+#endif
+ return t2;
+ }
+ x--;
+ }
+ }
+ else /* neither an array nor a file */
+ {
+ ptr = prototype [ length ];
+ switch (ptr->kind) /* compute the number of the system */
+ /* virtual variables */
+ {
+ case RECORD : length = 0; t3 = 0; break;
+ case COROUTINE : length = 3; t3 = CL; break;
+ case PROCESS : length = 5; t3 = disp2off; break;
+ case FUNCTION :
+ case PROCEDURE : length = 2; t3 = RPCDL+1; break; /* PS */
+ case HANDLER : length = 2; t3 = SIGNR; break;
+ default : length = 2; t3 = STATSL; break;
+ }
+
+ /* system reference variables */
+ for(t2 = length; t2 >= 1; t2-- ){
+ va=t1+offset[ t2 ];
+#ifndef OBJECTADDR
+ if(isprocess((virtaddr *)(M+va))) continue;
+#endif
+ if(M[va]==0){ assert( M[va+1]==0 ); continue; }
+ if(x==0){
+#ifdef CDBG
+ fprintf(ff,"=%d|\n",va);
+ fflush(ff);
+#endif
+ return va;
+ }
+ x--;
+ }
+
+ /* temporary reference variables */
+ t1 = am+M[ am ]+t3;
+ for(t2 = am+ptr->span; t2 < t1; t2 += 2){
+#ifndef OBJECTADDR
+ if(isprocess((virtaddr *)(M+t2))) continue;
+#endif
+ if(M[t2]==0){ assert( M[t2+1]==0 ); continue; }
+ if(x==0){
+#ifdef CDBG
+ fprintf(ff,"=%d|\n",t2);
+ fflush(ff);
+#endif
+ return t2;
+ }
+ x--;
+ }
+
+ /* user reference variables */
+ t1 = ptr->reflist;
+ for(t2 = t1+ptr->lthreflist-1; t2 >= t1; t2-- ){
+ va=am+M[ t2 ];
+#ifndef OBJECTADDR
+ if(isprocess((virtaddr *)(M+va))) continue;
+#endif
+ if(M[va]==0){ assert( M[va+1]==0 ); continue; }
+ if(x==0){
+#ifdef CDBG
+ fprintf(ff,"=%d|\n",va);
+ fflush(ff);
+#endif
+ return va;
+ }
+ x--;
+ }
+ }
+
+#ifdef CDBG
+ fprintf(ff,"=-1|\n");
+ fflush(ff);
+#endif
+
+ return -1;
+}
+
+static void heap_walk(curr_ah) word curr_ah;{
+ word aux,prev_ah=1; /* 1 is special value not expected in anyone virtaddr */
+ word level=0;
+
+#ifdef CDBG
+ fprintf(ff,"|prev_ah=%d|\n",prev_ah);
+ fflush(ff);
+#endif
+
+ for(;;){
+ word am=get_pointer(M[curr_ah],M[curr_ah+1]);
+ M[curr_ah+1]++;
+ if(am >= 0){
+ if(M[ M[am] +1] >0){
+#ifdef CDBG
+ fprintf(ff,"Object %d->%d invited.\n",M[am],M[M[am]]);
+ fflush(ff);
+#endif
+ continue;
+ }
+
+ /*** go ahead ***/
+ level++;
+ aux=M[am];
+ M[am]=prev_ah;
+ prev_ah=curr_ah;
+ curr_ah=aux;
+#ifdef CDBG
+ fprintf(ff,"|curr_ah set to %d|\n",curr_ah);
+ fflush(ff);
+#endif
+ continue;
+ }
+ if(prev_ah > 1){
+ /*** go back ***/
+#ifdef CDBG
+ fprintf(ff,"going back (prev_ah=%d)(lvl=%d)\n",prev_ah,level);
+ fflush(ff);
+#endif
+ level--;
+ aux=curr_ah;
+ curr_ah=prev_ah;
+ am=get_pointer(M[prev_ah],M[prev_ah+1]-1);
+ prev_ah=M[am];
+#ifdef CDBG
+ if(level==0)
+ fprintf(ff,"|prev_ah set to %d,next set to %d|\n",prev_ah,aux);
+ fflush(ff);
+#endif
+ M[am]=aux;
+ continue;
+ }
+ assert( prev_ah==1 );
+ assert( level == 0 );
+ break; /*** now all 'invited' objects have its mark >0 ***/
+ }
+}
+
+static void phase2a()
+{
+ word t1,c1_ah;
+
+ /*** generation number already is not needed so we reset it ***/
+
+ t1 = thisp->upper-1;
+ while(t1 >= thisp->lastitem){
+ if( M[t1] == c1 ) c1_ah=t1;
+ M[ t1+1 ] = 0;
+ t1-=2;
+ }
+
+#ifdef CDBG
+ fprintf(ff,"first phase of walk |from=%d,to=%d,procah=%d|\n",
+ thisp->lastitem,
+ thisp->upper-1,
+ thisp->procref.addr);
+ fflush(ff);
+#endif
+
+ heap_walk(thisp->procref.addr);
+
+#ifdef CDBG
+ fprintf(ff,"second phase of walk c1_ah=%d,c1=%d\n",c1_ah,c1);
+ fflush(ff);
+#endif
+
+ heap_walk(c1_ah);
+
+ if( thisp->blck1 != 0 )
+ heap_walk(thisp->blck1);
+
+ /*** Mark objects not traversed like SKILLED ***/
+
+ t1 = thisp->freeitem; /* head of free item list */
+ while (t1 != 0)
+ {
+ word t2;
+ t2 = M[ t1 ];
+ M[ t1 ]= 0-1; /* mark not to set object SKILLED */
+ t1 = t2; /* next free item */
+ }
+
+ t1 = thisp->upper-1; /* last dictionary item pointer */
+ while (t1 >= thisp->lastitem)
+ {
+ if (M[ t1+1 ] == 0 ){ /* entry not traversed - so killed */
+
+#ifdef CDBG
+ fprintf(ff,"MARKING dict. entry %d -> %d like SKILLED\n",t1,M[t1]);
+ fflush(ff);
+#endif
+
+ M[ t1+1 ] = MAXMARKER;
+ if( M[ t1 ] > 0 ) M [ M[ t1 ] +1 ] = SKILLED;
+ /* mark SKILLED if not set yet */
+ }
+ t1 -= 2;
+ }
+} /* end phase2a */
+
+
+
+/* For each free dictionary item set its mark to unusable status.
+ */
+
+static void phase3()
+{
+ word t1;
+
+ t1 = thisp->freeitem; /* head of free item list */
+ while (t1 != 0)
+ {
+ M[ t1+1 ] = MAXMARKER; /* flag item unusable */
+ t1 = M[ t1 ]; /* next free item */
+ }
+} /* end phase3 */
+
+
+/* Step thru the dictionary and virtually remove all unusable items.
+ * For each active item (after phase3 we have only active and unusable
+ * items) its mark is set to the new address of this item (after
+ * forthcomming compression). Moreover the contents of locations am and
+ * (old) ah are interchanged.
+ */
+
+static void phase4()
+{
+ word t1, t2, t3;
+
+ t1 = thisp->upper-1; /* last dictionary item pointer */
+ t2 = t1; /* initialize new address */
+ while (t1 >= thisp->lastitem)
+ {
+ if (M[ t1+1 ] == MAXMARKER) /* entry killed - don't decrement t2 */
+ M[ t1+1 ] = 0;
+ else
+ {
+ M[ t1+1 ] = t2; /* store new ah */;
+ t2 -= 2;
+ t3 = M[ t1 ]; /* am */
+ M[ t1 ] = M[ t3 ]; /* save (am) in (old ah) */
+ M[ t3 ] = t1; /* move old ah to (am) */
+ }
+ t1 -= 2;
+ }
+} /* end phase4 */
+
+
+/* The memory area of objects is traversed once again. Now the killed
+ * objects are removed and the remaining ones compressed. For each active
+ * object its virtual variables are relocated, their marks cleared, their
+ * ah's set to the proper new values. The contents of locations am and ah
+ * are interchanged back.
+ */
+
+static void phase5()
+{
+ word t1, t2, t3, t4, t5;
+
+ t2 = t1 = thisp->lower+1;
+ while (t1 <= thisp->lastused) /* traverse object area */
+ {
+ t5 = M[ t1 ]; /* old ah saved by phase4 */
+ if (M[ t1+1 ] == SKILLED){ /* ignore this object */
+#ifdef CDBG
+ fprintf(ff,"OBJECT am=%d,SIZE=%d,TYPE=%d\n",t1,M[t1],M[t1+1]);
+ fflush(ff);
+#endif
+ t1 += t5; /* t5=appetite in this case */
+ }
+ else
+ {
+#ifdef CDBG
+ fprintf(ff,"OBJECT am=%d,SIZE=%d,TYPE=%d\n",t1,M[t1],M[t1+1]);
+ fflush(ff);
+#endif
+ t3 = M[ t5 ]; /* appetite saved by phase4 */
+ M[ t2 ] = t3; /* send it to the new am */
+ for (t4 = 1; t4 < t3; t4++ ) /* copy the object into new am */
+ M[ t2+t4 ] = M[ t1+t4 ];
+#ifdef CDBG
+ traverse(t2,what_we_have);
+#endif
+
+ /* Update global absolute pointer to current object : */
+ if (t1 == c1) /* locate am of current */
+ {
+ c1 = t2;
+ curah = M[ t5+1 ]; /* new ah of current */
+ }
+ if (t1 == M[ temporary ])
+ M[ temporary ] = t2;
+
+ M[ t5 ] = t2; /* make (ah) looking ok */
+ traverse(t2, relocate); /* relocate virtual variables */
+#ifdef CDBG
+ fprintf(ff," --> am=%d,SIZE=%d,TYPE=%d\n",t2,M[t2],M[t2+1]);
+ fflush(ff);
+ traverse(t2,what_we_have);
+#endif
+ t1 += t3;
+ t2 += t3;
+ }
+ }
+ thisp->lastused = t2-1;
+
+
+ /* Update global absolute pointers to objects : */
+
+ relocate(&(thisp->procref ));
+
+ {
+ virtaddr v;
+ v.addr=thisp->blck1;
+ v.mark=0;
+ relocate(&v);
+ thisp->blck1=v.addr;
+ }
+
+} /* end phase5 */
+
+
+/* The dictionary is compressed. The unusable entries are moved out and
+ * the remaining ones are moved up to the positions indicated by their
+ * marks.
+ * If pointers to processes are implemented as objects we have to rebuild
+ * has table of these pointers too.
+ */
+
+static void phase6()
+{
+ word t1, t2, t3;
+
+#ifdef OBJECTADDR
+ hash_create(thisp,thisp->hash_size);
+#endif
+
+ t1 = thisp->upper+1;
+ for (t2 = t1-2; t2 >= thisp->lastitem; t2 -= 2) /* compress dictionary */
+ {
+ t3 = M[ t2+1 ];
+ if (t3 != 0) /* this is new ah */
+ {
+ M[ t3 ] = M[ t2 ];
+ M[ t3+1 ] = 0; /* clear mark */
+ t1 = t3;
+#ifdef OBJECTADDR
+ {
+ virtaddr vt3;
+ vt3.addr=t3;
+ vt3.mark=0;
+ if( isprocess(&vt3) ){
+ virtaddr obj;
+ procaddr mess;
+ obj.addr=t3;
+ obj.mark=0;
+ obj2mess(M,&obj,&mess);
+ /* force to create item - we not need it yet */
+ hash_set(&mess,t3);
+ }
+ }
+#endif
+ }
+ }
+ thisp->lastitem = t1;
+
+ thisp->prochead = M[ thisp->procref.addr ];
+ thisp->blck2 = M[ thisp->blck1 ];
+
+} /* end phase6 */
+
+
+/* System invariants are recovered, e.g. display is rebuilt to reflect the
+ * new physical addresses.
+ */
+
+static void curtain()
+{
+ word t1, phead;
+
+ phead = thisp->prochead;
+ t1=M[ c1 + PROTNUM ];
+ c2 = c1+prototype[ t1 ]->span;
+ t1 = phead+M[ phead ]; /* first free after process head */
+ display = t1+dispoff; /* display address */
+ display2 = t1+disp2off; /* indirect display */
+ M[ t1+SL ] = DUMMY; /* restore head's SL */
+ loosen(); /* rebuild DISPLAY */
+ update(c1, curah);
+ if (infmode){
+ fprintf(stderr,
+ "\n(COMPACTIFIER used for process %d,%ld words reclaimed,now %ld free)\n",
+ thispix,
+ (long) (thisp->lastitem-thisp->lastused-1-nleng),
+ (long) (thisp->lastitem-thisp->lastused-1));
+ fflush(stderr);
+ }
+#ifdef CDBG
+ fprintf(ff,
+ "(COMPACTIFIER used for process %d,%ld words reclaimed,now %ld free)\n",
+ thispix,
+ (long) (thisp->lastitem-thisp->lastused-1-nleng),
+ (long) (thisp->lastitem-thisp->lastused-1));
+ fflush(ff);
+#endif
+ thisp->freeitem = 0;
+ thisp->headk2 = 0;
+ thisp->headk = thisp->lower;
+ M[ 1 ] = 1; /* absolute none */
+ ic = lastic; /* re-decode current instruction ! */
+ decode();
+ if (opcode == 3 /*LRAISE*/) ic++; /* skip address after LRAISE */
+} /* end curtain */
+
+
+void compactify() /* Compactification */
+{
+#ifdef CDBG
+ ff=fopen("trace","a");
+ fprintf(ff,"----------------------------------------\n");
+ fprintf(ff,"COMPACTIFY (thisp=%d)\n",thispix);
+ fprintf(ff,"c1=%d,c2=%d,templ=%d\n",
+ thisp->c1,thisp->c2,thisp->template.addr);
+ fprintf(ff,"back=%d,back.mark=%d,backam=%d,backam.mark=%d\n",
+ thisp->backobj.addr,thisp->backobj.mark,
+ M[thisp->backobj.addr],M[thisp->backobj.addr+1]);
+ fprintf(ff,"blck1=%d,blck2=%d\n",thisp->blck1,thisp->blck2);
+ fflush(ff);
+#endif
+
+ phase1();
+ phase2();
+ phase2a(); /* garbage collection */
+/* phase3(); if only compactifier is needed uncomment this statement */
+/* and comment statement phase2a() */
+ phase4();
+ phase5();
+ phase6();
+ curtain();
+
+#ifdef CDBG
+ fprintf(ff,"----------------------------------------\n");
+ fflush(ff);
+ fclose(ff);
+#endif
+
+} /* end compactify */
+
+
projects / vlp.git / blobdiff