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