1 /* Loglan82 Compiler&Interpreter
\r
2 Copyright (C) 1993 Institute of Informatics, University of Warsaw
\r
3 Copyright (C) 1993, 1994 LITA, Pau
\r
5 This program is free software; you can redistribute it and/or modify
\r
6 it under the terms of the GNU General Public License as published by
\r
7 the Free Software Foundation; either version 2 of the License, or
\r
8 (at your option) any later version.
\r
10 This program is distributed in the hope that it will be useful,
\r
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
\r
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
\r
13 GNU General Public License for more details.
\r
15 You should have received a copy of the GNU General Public License
\r
16 along with this program; if not, write to the Free Software
\r
17 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
\r
19 contacts: Andrzej.Salwicki@univ-pau.fr
\r
22 LITA Departement d'Informatique
\r
24 Avenue de l'Universite
\r
26 tel. ++33 59923154 fax. ++33 59841696
\r
28 =======================================================================
\r
34 #include "process.h"
\r
35 #include "intproto.h"
\r
40 #ifndef NO_PROTOTYPES
\r
42 static word get_pointer(word,word);
\r
43 static void phase1(void);
\r
44 static void phase2(void);
\r
45 static void phase2a(void);
\r
46 static void phase3(void);
\r
47 static void phase4(void);
\r
48 static void phase5(void);
\r
49 static void phase6(void);
\r
50 static void curtain(void);
\r
51 static void heap_walk(word);
\r
52 static void nonefy(virtaddr *);
\r
53 static void relocate(virtaddr *);
\r
54 static void traverse(word,void (*)(virtaddr *));
\r
55 static void what_we_have(virtaddr *);
\r
59 static word get_pointer();
\r
60 static void phase1();
\r
61 static void phase2();
\r
62 static void phase2a();
\r
63 static void phase3();
\r
64 static void phase4();
\r
65 static void phase5();
\r
66 static void phase6();
\r
67 static void curtain();
\r
68 static void heap_walk();
\r
69 static void nonefy();
\r
70 static void relocate();
\r
71 static void traverse();
\r
72 static void what_we_have();
\r
79 static void what_we_have(va) virtaddr *va; {
\r
80 fprintf(ff," pointer offset %d:|va=%d,va_m=%d,M[va]=%d,M[va+1]=%d|\n",
\r
81 ((word*)va)-M,va->addr,va->mark,M[va->addr],M[va->addr+1]);
\r
88 * Memory compactifier - a play in 6 acts
\r
91 static word nleng; /* free memory before compact. */
\r
92 static word curah; /* to preserve ah of current object */
\r
94 /* One of the actions for traverse: see below;
\r
95 * converts none to absolute none, i.e. (0, 0)
\r
99 static void nonefy(va) virtaddr *va; {
\r
102 if(va->addr==0 && va->mark!=0){
\r
103 fprintf(ff,"nonefy:|va=%d,va_m=%d,M[va]=%d,M[va+1]=%d|\n",
\r
104 va->addr,va->mark,M[va->addr],M[va->addr+1]);
\r
112 assert( va->mark >= 0 );
\r
113 /* assert( va->mark <= M[ va->addr+1 ] );*/
\r
116 fprintf(ff,"nonefy:|va=%d,va_mark=%d,am=%d,mark=%d|\n",
\r
117 va->addr,va->mark,M[va->addr],M[va->addr+1]);
\r
120 if( va->mark != M[ va->addr+1 ] ) /* if NONE */
\r
124 fprintf(ff," set to NONE\n"); fflush(ff);
\r
129 assert( va->addr != 1 );
\r
133 /* One of the actions for traverse; update the virtual address to
\r
134 * correspond to its dictionary entry after compactification.
\r
137 static void relocate(va) virtaddr *va; {
\r
139 if(!isprocess(va)){
\r
141 va->addr = M[ va->addr+1 ]; /* new ah (after compression) */
\r
142 va->mark = 0; /* clear mark */
\r
146 } /* end relocate */
\r
149 /* Traverse all the virtual variables of object am and perform action
\r
150 * on each of them. Skip references to processes (see nonefy() and
\r
154 static void traverse(am, action)
\r
156 #ifndef NO_PROTOTYPES
\r
157 void (*action)(virtaddr *);
\r
162 word t1, t2, t3, length;
\r
165 t1 = am+M[ am ]; /* LWA+1 of the object */
\r
166 length = M[ am+PROTNUM ]; /* prototype number */
\r
167 if (length == AINT || length == AREAL || length == AVIRT ||
\r
168 length == FILEOBJECT
\r
170 || length == APROCESS
\r
174 if (length == AVIRT) /* ARRAYOF <reference> */
\r
175 for (t2 = am+3; t2 < t1; t2 += 2)
\r
176 (*action)((virtaddr *)(M+t2));
\r
178 else /* neither an array nor a file */
\r
180 ptr = prototype [ length ];
\r
181 switch (ptr->kind) /* compute the number of the system */
\r
182 /* virtual variables */
\r
184 case RECORD : length = 0; t3 = 0; break;
\r
185 case COROUTINE : length = 3; t3 = CL; break;
\r
186 case PROCESS : length = 5; t3 = disp2off; break;
\r
188 case PROCEDURE : length = 2; t3 = RPCDL+1; break; /* PS */
\r
189 case HANDLER : length = 2; t3 = SIGNR; break;
\r
190 default : length = 2; t3 = STATSL; break;
\r
193 /* action for system reference variables */
\r
194 for (t2 = length; t2 >= 1; t2-- )
\r
195 (*action)((virtaddr *)(M+t1+offset[ t2 ]));
\r
197 /* action for temporary reference variables */
\r
198 t1 = am+M[ am ]+t3;
\r
199 for (t2 = am+ptr->span; t2 < t1; t2 += 2)
\r
200 (*action)((virtaddr *)(M+t2));
\r
202 /* action for user reference variables */
\r
204 for (t2 = t1+ptr->lthreflist-1; t2 >= t1; t2-- )
\r
205 (*action)((virtaddr *)(M+am+M[ t2 ]));
\r
207 } /* end traverse */
\r
210 /* Mark killed objects by substituting prototype number by a special value.
\r
211 * This way we will be able to tell apart the killed objects without
\r
212 * recalling to the dictionary or to the list of killed objects.
\r
215 static void phase1()
\r
217 word t1, t2, t3, phead;
\r
219 nleng = thisp->lastitem-thisp->lastused-1; /* free memory before comp. */
\r
220 M[ 1 ] = 0; /* for proper update of none */
\r
221 phead = thisp->prochead; /* head of current process */
\r
222 M[ phead+M[ phead ]+SL ] = 0; /* make SL of head look like none */
\r
223 t1 = thisp->headk2; /* flag killed objects */
\r
224 while (t1 != 0) /* special list for appetite=2 */
\r
228 M[ t2 ] = SKILLED; /* flag object killed */
\r
230 t1 = thisp->headk; /* now other killed objects */
\r
231 while (t1 != thisp->lower)
\r
238 M[ t3 ] = SKILLED; /* flag object killed */
\r
240 t1 = M[ t1+LONGLINK ]; /* goto other size list */
\r
245 /* Step thru the memory area containing objects. For each object not being
\r
246 * killed detect all its virtual variables pointing to none and convert
\r
247 * them to absolute none i.e. (0, 0).
\r
250 static void phase2()
\r
254 nonefy( &(thisp->procref ) );
\r
256 t1 = thisp->lower+1; /* FWA of object area */
\r
257 while (t1 <= thisp->lastused)
\r
261 fprintf(ff,"OBJECT am=%d,SIZE=%d,TYPE=%d\n",t1,M[t1],M[t1+1]);
\r
263 if (M[ t1+1 ] != SKILLED) traverse(t1,what_we_have);
\r
266 if (M[ t1+1 ] != SKILLED) /* an active object */
\r
267 traverse(t1, nonefy);
\r
268 t1 += M[ t1 ]; /* next object address */
\r
273 /* garbage collection */
\r
275 /* Find x-th pointer in am.
\r
276 * Skip references to processes.
\r
279 static word get_pointer(am,x) word am,x; {
\r
281 word t1, t2, t3, length, va;
\r
284 t1 = am+M[ am ]; /* LWA+1 of the object */
\r
285 length = M[ am+PROTNUM ]; /* prototype number */
\r
288 fprintf(ff,"|get_pointer(am=%d,x=%d)lenght=%d|",am,x,length);
\r
292 if (length == AINT || length == AREAL || length == AVIRT ||
\r
293 length == FILEOBJECT
\r
295 || length == APROCESS
\r
299 if(length == AVIRT) /* ARRAYOF <reference> */
\r
300 for(t2 = am+3; t2 < t1; t2 += 2){
\r
302 if(isprocess((virtaddr *)(M+t2))) continue;
\r
304 if(M[t2]==0){ assert( M[t2+1]==0 ); continue; }
\r
311 fprintf(ff,"=%d|\n",t2);
\r
319 else /* neither an array nor a file */
\r
321 ptr = prototype [ length ];
\r
322 switch (ptr->kind) /* compute the number of the system */
\r
323 /* virtual variables */
\r
325 case RECORD : length = 0; t3 = 0; break;
\r
326 case COROUTINE : length = 3; t3 = CL; break;
\r
327 case PROCESS : length = 5; t3 = disp2off; break;
\r
329 case PROCEDURE : length = 2; t3 = RPCDL+1; break; /* PS */
\r
330 case HANDLER : length = 2; t3 = SIGNR; break;
\r
331 default : length = 2; t3 = STATSL; break;
\r
334 /* system reference variables */
\r
335 for(t2 = length; t2 >= 1; t2-- ){
\r
336 va=t1+offset[ t2 ];
\r
338 if(isprocess((virtaddr *)(M+va))) continue;
\r
340 if(M[va]==0){ assert( M[va+1]==0 ); continue; }
\r
343 fprintf(ff,"=%d|\n",va);
\r
351 /* temporary reference variables */
\r
352 t1 = am+M[ am ]+t3;
\r
353 for(t2 = am+ptr->span; t2 < t1; t2 += 2){
\r
355 if(isprocess((virtaddr *)(M+t2))) continue;
\r
357 if(M[t2]==0){ assert( M[t2+1]==0 ); continue; }
\r
360 fprintf(ff,"=%d|\n",t2);
\r
368 /* user reference variables */
\r
370 for(t2 = t1+ptr->lthreflist-1; t2 >= t1; t2-- ){
\r
373 if(isprocess((virtaddr *)(M+va))) continue;
\r
375 if(M[va]==0){ assert( M[va+1]==0 ); continue; }
\r
378 fprintf(ff,"=%d|\n",va);
\r
388 fprintf(ff,"=-1|\n");
\r
395 static void heap_walk(curr_ah) word curr_ah;{
\r
396 word aux,prev_ah=1; /* 1 is special value not expected in anyone virtaddr */
\r
400 fprintf(ff,"|prev_ah=%d|\n",prev_ah);
\r
405 word am=get_pointer(M[curr_ah],M[curr_ah+1]);
\r
408 if(M[ M[am] +1] >0){
\r
410 fprintf(ff,"Object %d->%d invited.\n",M[am],M[M[am]]);
\r
423 fprintf(ff,"|curr_ah set to %d|\n",curr_ah);
\r
431 fprintf(ff,"going back (prev_ah=%d)(lvl=%d)\n",prev_ah,level);
\r
437 am=get_pointer(M[prev_ah],M[prev_ah+1]-1);
\r
441 fprintf(ff,"|prev_ah set to %d,next set to %d|\n",prev_ah,aux);
\r
447 assert( prev_ah==1 );
\r
448 assert( level == 0 );
\r
449 break; /*** now all 'invited' objects have its mark >0 ***/
\r
453 static void phase2a()
\r
457 /*** generation number already is not needed so we reset it ***/
\r
459 t1 = thisp->upper-1;
\r
460 while(t1 >= thisp->lastitem){
\r
461 if( M[t1] == c1 ) c1_ah=t1;
\r
467 fprintf(ff,"first phase of walk |from=%d,to=%d,procah=%d|\n",
\r
470 thisp->procref.addr);
\r
474 heap_walk(thisp->procref.addr);
\r
477 fprintf(ff,"second phase of walk c1_ah=%d,c1=%d\n",c1_ah,c1);
\r
483 if( thisp->blck1 != 0 )
\r
484 heap_walk(thisp->blck1);
\r
486 /*** Mark objects not traversed like SKILLED ***/
\r
488 t1 = thisp->freeitem; /* head of free item list */
\r
493 M[ t1 ]= 0-1; /* mark not to set object SKILLED */
\r
494 t1 = t2; /* next free item */
\r
497 t1 = thisp->upper-1; /* last dictionary item pointer */
\r
498 while (t1 >= thisp->lastitem)
\r
500 if (M[ t1+1 ] == 0 ){ /* entry not traversed - so killed */
\r
503 fprintf(ff,"MARKING dict. entry %d -> %d like SKILLED\n",t1,M[t1]);
\r
507 M[ t1+1 ] = MAXMARKER;
\r
508 if( M[ t1 ] > 0 ) M [ M[ t1 ] +1 ] = SKILLED;
\r
509 /* mark SKILLED if not set yet */
\r
513 } /* end phase2a */
\r
517 /* For each free dictionary item set its mark to unusable status.
\r
520 static void phase3()
\r
524 t1 = thisp->freeitem; /* head of free item list */
\r
527 M[ t1+1 ] = MAXMARKER; /* flag item unusable */
\r
528 t1 = M[ t1 ]; /* next free item */
\r
533 /* Step thru the dictionary and virtually remove all unusable items.
\r
534 * For each active item (after phase3 we have only active and unusable
\r
535 * items) its mark is set to the new address of this item (after
\r
536 * forthcomming compression). Moreover the contents of locations am and
\r
537 * (old) ah are interchanged.
\r
540 static void phase4()
\r
544 t1 = thisp->upper-1; /* last dictionary item pointer */
\r
545 t2 = t1; /* initialize new address */
\r
546 while (t1 >= thisp->lastitem)
\r
548 if (M[ t1+1 ] == MAXMARKER) /* entry killed - don't decrement t2 */
\r
552 M[ t1+1 ] = t2; /* store new ah */;
\r
554 t3 = M[ t1 ]; /* am */
\r
555 M[ t1 ] = M[ t3 ]; /* save (am) in (old ah) */
\r
556 M[ t3 ] = t1; /* move old ah to (am) */
\r
563 /* The memory area of objects is traversed once again. Now the killed
\r
564 * objects are removed and the remaining ones compressed. For each active
\r
565 * object its virtual variables are relocated, their marks cleared, their
\r
566 * ah's set to the proper new values. The contents of locations am and ah
\r
567 * are interchanged back.
\r
570 static void phase5()
\r
572 word t1, t2, t3, t4, t5;
\r
574 t2 = t1 = thisp->lower+1;
\r
575 while (t1 <= thisp->lastused) /* traverse object area */
\r
577 t5 = M[ t1 ]; /* old ah saved by phase4 */
\r
578 if (M[ t1+1 ] == SKILLED){ /* ignore this object */
\r
580 fprintf(ff,"OBJECT am=%d,SIZE=%d,TYPE=%d\n",t1,M[t1],M[t1+1]);
\r
583 t1 += t5; /* t5=appetite in this case */
\r
588 fprintf(ff,"OBJECT am=%d,SIZE=%d,TYPE=%d\n",t1,M[t1],M[t1+1]);
\r
591 t3 = M[ t5 ]; /* appetite saved by phase4 */
\r
592 M[ t2 ] = t3; /* send it to the new am */
\r
593 for (t4 = 1; t4 < t3; t4++ ) /* copy the object into new am */
\r
594 M[ t2+t4 ] = M[ t1+t4 ];
\r
596 traverse(t2,what_we_have);
\r
599 /* Update global absolute pointer to current object : */
\r
600 if (t1 == c1) /* locate am of current */
\r
603 curah = M[ t5+1 ]; /* new ah of current */
\r
605 if (t1 == M[ temporary ])
\r
606 M[ temporary ] = t2;
\r
608 M[ t5 ] = t2; /* make (ah) looking ok */
\r
609 traverse(t2, relocate); /* relocate virtual variables */
\r
611 fprintf(ff," --> am=%d,SIZE=%d,TYPE=%d\n",t2,M[t2],M[t2+1]);
\r
613 traverse(t2,what_we_have);
\r
619 thisp->lastused = t2-1;
\r
622 /* Update global absolute pointers to objects : */
\r
624 relocate(&(thisp->procref ));
\r
628 v.addr=thisp->blck1;
\r
631 thisp->blck1=v.addr;
\r
637 /* The dictionary is compressed. The unusable entries are moved out and
\r
638 * the remaining ones are moved up to the positions indicated by their
\r
640 * If pointers to processes are implemented as objects we have to rebuild
\r
641 * has table of these pointers too.
\r
644 static void phase6()
\r
649 hash_create(thisp,thisp->hash_size);
\r
652 t1 = thisp->upper+1;
\r
653 for (t2 = t1-2; t2 >= thisp->lastitem; t2 -= 2) /* compress dictionary */
\r
656 if (t3 != 0) /* this is new ah */
\r
659 M[ t3+1 ] = 0; /* clear mark */
\r
666 if( isprocess(&vt3) ){
\r
671 obj2mess(M,&obj,&mess);
\r
672 /* force to create item - we not need it yet */
\r
673 hash_set(&mess,t3);
\r
679 thisp->lastitem = t1;
\r
681 thisp->prochead = M[ thisp->procref.addr ];
\r
682 thisp->blck2 = M[ thisp->blck1 ];
\r
687 /* System invariants are recovered, e.g. display is rebuilt to reflect the
\r
688 * new physical addresses.
\r
691 static void curtain()
\r
695 phead = thisp->prochead;
\r
696 t1=M[ c1 + PROTNUM ];
\r
697 c2 = c1+prototype[ t1 ]->span;
\r
698 t1 = phead+M[ phead ]; /* first free after process head */
\r
699 display = t1+dispoff; /* display address */
\r
700 display2 = t1+disp2off; /* indirect display */
\r
701 M[ t1+SL ] = DUMMY; /* restore head's SL */
\r
702 loosen(); /* rebuild DISPLAY */
\r
706 "\n(COMPACTIFIER used for process %d,%ld words reclaimed,now %ld free)\n",
\r
708 (long) (thisp->lastitem-thisp->lastused-1-nleng),
\r
709 (long) (thisp->lastitem-thisp->lastused-1));
\r
714 "(COMPACTIFIER used for process %d,%ld words reclaimed,now %ld free)\n",
\r
716 (long) (thisp->lastitem-thisp->lastused-1-nleng),
\r
717 (long) (thisp->lastitem-thisp->lastused-1));
\r
720 thisp->freeitem = 0;
\r
722 thisp->headk = thisp->lower;
\r
723 M[ 1 ] = 1; /* absolute none */
\r
724 ic = lastic; /* re-decode current instruction ! */
\r
726 if (opcode == 3 /*LRAISE*/) ic++; /* skip address after LRAISE */
\r
727 } /* end curtain */
\r
730 void compactify() /* Compactification */
\r
733 ff=fopen("trace","a");
\r
734 fprintf(ff,"----------------------------------------\n");
\r
735 fprintf(ff,"COMPACTIFY (thisp=%d)\n",thispix);
\r
736 fprintf(ff,"c1=%d,c2=%d,templ=%d\n",
\r
737 thisp->c1,thisp->c2,thisp->template.addr);
\r
738 fprintf(ff,"back=%d,back.mark=%d,backam=%d,backam.mark=%d\n",
\r
739 thisp->backobj.addr,thisp->backobj.mark,
\r
740 M[thisp->backobj.addr],M[thisp->backobj.addr+1]);
\r
741 fprintf(ff,"blck1=%d,blck2=%d\n",thisp->blck1,thisp->blck2);
\r
747 phase2a(); /* garbage collection */
\r
748 /* phase3(); if only compactifier is needed uncomment this statement */
\r
749 /* and comment statement phase2a() */
\r
756 fprintf(ff,"----------------------------------------\n");
\r
761 } /* end compactify */
\r