Initial revision

util/ego/cf/Makefile

@@ -0,0 +1,57 @@
+EMH=../../../h
+EML=../../../lib
+CFLAGS=
+SHARE=../share
+CF=.
+OBJECTS=cf.o cf_idom.o cf_loop.o cf_succ.o 
+SHOBJECTS=$(SHARE)/get.o $(SHARE)/put.o $(SHARE)/alloc.o $(SHARE)/global.o $(SHARE)/debug.o $(SHARE)/files.o $(SHARE)/map.o $(SHARE)/lset.o $(SHARE)/cset.o $(SHARE)/aux.o
+SRC=cf.h cf_succ.h cf_idom.h cf_loop.h cf.c cf_succ.c cf_idom.c cf_loop.c
+.c.o:
+	cc $(CFLAGS) -c $<
+all:	$(OBJECTS)
+cf: \
+	$(OBJECTS) $(SHOBJECTS)
+	 cc -o cf -i $(OBJECTS) $(SHOBJECTS) $(EML)/em_data.a
+lpr:
+	pr $(SRC) | lpr
+dumpflop:
+	tar -uf /mnt/ego/cf/cf.tarf $(SRC)
+# the next lines are generated automatically
+# AUTOAUTOAUTOAUTOAUTOAUTO
+cf.o:	../../../h/em_mnem.h
+cf.o:	../share/alloc.h
+cf.o:	../share/cset.h
+cf.o:	../share/debug.h
+cf.o:	../share/files.h
+cf.o:	../share/get.h
+cf.o:	../share/global.h
+cf.o:	../share/lset.h
+cf.o:	../share/map.h
+cf.o:	../share/put.h
+cf.o:	../share/types.h
+cf.o:	cf.h
+cf.o:	cf_idom.h
+cf.o:	cf_loop.h
+cf.o:	cf_succ.h
+cf_idom.o:	../share/alloc.h
+cf_idom.o:	../share/debug.h
+cf_idom.o:	../share/lset.h
+cf_idom.o:	../share/types.h
+cf_idom.o:	cf.h
+cf_loop.o:	../share/alloc.h
+cf_loop.o:	../share/debug.h
+cf_loop.o:	../share/lset.h
+cf_loop.o:	../share/types.h
+cf_loop.o:	cf.h
+cf_succ.o:	../../../h/em_flag.h
+cf_succ.o:	../../../h/em_mnem.h
+cf_succ.o:	../../../h/em_pseu.h
+cf_succ.o:	../../../h/em_spec.h
+cf_succ.o:	../share/cset.h
+cf_succ.o:	../share/debug.h
+cf_succ.o:	../share/def.h
+cf_succ.o:	../share/global.h
+cf_succ.o:	../share/lset.h
+cf_succ.o:	../share/map.h
+cf_succ.o:	../share/types.h
+cf_succ.o:	cf.h

util/ego/cf/cf.c

@@ -0,0 +1,334 @@
+/*  C O N T R O L   F L O W
+ *
+ *  M A I N   R O U T I N E
+ */
+
+#include <stdio.h>
+#include "../share/types.h"
+#include "../share/debug.h"
+#include "../share/map.h"
+#include "../share/files.h"
+#include "../share/global.h"
+#include "../share/alloc.h"
+#include "../share/lset.h"
+#include "../share/cset.h"
+#include "../share/get.h"
+#include "../share/put.h"
+#include "../../../h/em_mnem.h"
+#include "cf.h"
+#include "cf_succ.h"
+#include "cf_idom.h"
+#include "cf_loop.h"
+
+
+STATIC cset	lpi_set;	/* set of procedures used in LPI instruction */
+STATIC cset	cai_set;	/* set of all procedures doing a CAI */
+
+STATIC interproc_analysis(p)
+	proc_p p;
+{
+	/* Interprocedural analysis of a procedure p determines:
+	 *  - all procedures called by p (the 'call graph')
+	 *  - the set of objects changed by p (directly)
+	 *  - whether p does a load-indirect (loi,lof etc.)
+	 *  - whether p does a store-indirect (sti, stf etc.)
+	 * The changed/used variables information will be
+	 * transitively closed, i.e. if P calls Q and Q changes
+	 * a variable X, the P changes X too.
+	 * (The same applies for used variables and for use/store
+	 * indirect).
+	 * The transitive closure will be computed by main
+	 * after all procedures have been processed.
+	 */
+
+	bblock_p b;
+	line_p   lnp;
+	bool inloop;
+
+	/* Allocate memory for structs and sets */
+
+	p->p_use = newuse();
+	p->p_change = newchange();
+	p->p_change->c_ext = Cempty_set(olength);
+	p->p_calling = Cempty_set(plength);
+
+	for (b = p->p_start; b != (bblock_p) 0; b = b->b_next) {
+	   inloop = (Lnrelems(b->b_loops) > 0);
+	   for (lnp = b->b_start; lnp != (line_p) 0; lnp = lnp->l_next) {
+		/* for all instructions of p do */
+		switch(INSTR(lnp)) {
+		   case op_cal:
+			Cadd(PROC(lnp)->p_id, &p->p_calling);
+			/* add called proc to p_calling */
+			if (inloop) {
+				CALLED_IN_LOOP(PROC(lnp));
+			}
+			break;
+		   case op_cai:
+			Cadd(p->p_id,&cai_set);
+			break;
+		   case op_lpi:
+			Cadd(PROC(lnp)->p_id, &lpi_set);
+			/* All procedures that have their names used
+			 * in an lpi instruction, may be called via
+			 * a cai instruction.
+			 */
+			PROC(lnp)->p_flags1 |= PF_LPI;
+			break;
+		   case op_ste:
+		   case op_sde:
+		   case op_ine:
+		   case op_dee:
+		   case op_zre:
+			Cadd(OBJ(lnp)->o_id, &p->p_change->c_ext);
+			/* Add changed object to c_ext */
+			break;
+		   case op_lil:
+		   case op_lof:
+		   case op_loi:
+		   case op_los:
+		   case op_lar:
+			p->p_use->u_flags |= UF_INDIR;
+			/* p does a load-indirect */
+			break;
+		   case op_sil:
+		   case op_stf:
+		   case op_sti:
+		   case op_sts:
+		   case op_sar:
+			p->p_change->c_flags |= CF_INDIR;
+			/* p does a store-indirect */
+			break;
+		   case op_blm:
+		   case op_bls:
+			p->p_use->u_flags |= UF_INDIR;
+			p->p_change->c_flags |= CF_INDIR;
+			/* p does both */
+			break;
+		   case op_mon:
+			printf("mon not yet implemented\n");
+			break;
+		   case op_lxl:
+		   case op_lxa:
+			curproc->p_flags1 |= PF_ENVIRON;
+			break;
+		}
+	   }
+	}
+}
+
+
+STATIC cf_cleanproc(p)
+	proc_p p;
+{
+	/* Remove the extended data structures of p */
+
+	register bblock_p b;
+	register Lindex pi;
+	loop_p lp;
+
+	for (b = p->p_start; b != (bblock_p) 0; b = b->b_next) {
+		oldcfbx(b->b_extend);
+	}
+	for (pi = Lfirst(p->p_loops); pi != (Lindex) 0; pi = Lnext(pi,
+							p->p_loops)) {
+		lp = (loop_p) Lelem(pi);
+		oldcflpx(lp->lp_extend);
+	}
+}
+
+
+
+#define CHANGE_INDIR(ch)	((ch->c_flags & CF_INDIR) != 0)
+#define USE_INDIR(us)		((us->u_flags & UF_INDIR) != 0)
+#define CALLS_UNKNOWN(p)	(p->p_flags1 & (byte) PF_CALUNKNOWN)
+#define BODY_KNOWN(p)		(p->p_flags1 & (byte) PF_BODYSEEN)
+#define ENVIRON(p)		(p->p_flags1 & (byte) PF_ENVIRON)
+
+
+STATIC bool add_info(q,p)
+	proc_p q,p;
+{
+	/* Determine the consequences for used/changed variables info
+	 * of the fact that p calls q. If e.g. q changes a variable X
+	 * then p changes this variable too. This routine is an
+	 * auxiliary routine of the transitive closure process.
+	 * The returned value indicates if there was any change in
+	 * the information of p.
+	 */
+
+	change_p chp, chq;
+	use_p    usp, usq;
+	bool     diff = FALSE;
+
+	chp = p->p_change;
+	chq = q->p_change;
+	usp = p->p_use;
+	usq = q->p_use;
+
+	if (!BODY_KNOWN(q)) {
+		/* q is a procedure of which the body is not available
+		 * as EM text.
+		 */
+		if (CALLS_UNKNOWN(p)) {
+			return FALSE;
+			/* p already called an unknown procedure */
+		} else {
+			p->p_flags1 |= PF_CALUNKNOWN;
+			return TRUE;
+		}
+	}
+	if (CALLS_UNKNOWN(q)) {
+		/* q calls a procedure of which the body is not available
+		 * as EM text.
+		 */
+		if (!CALLS_UNKNOWN(p)) {
+			p->p_flags1 |= PF_CALUNKNOWN;
+			diff = TRUE;
+		}
+	}
+	if (IS_CALLED_IN_LOOP(p) && !IS_CALLED_IN_LOOP(q)) {
+		CALLED_IN_LOOP(q);
+		diff = TRUE;
+	}
+	if (!Cis_subset(chq->c_ext, chp->c_ext)) {
+		/* q changes global variables (objects) that
+		* p did not (yet) change. Add all variables
+		* changed by q to the c_ext set of p.
+		*/
+		Cjoin(chq->c_ext, &chp->c_ext);
+		diff = TRUE;
+	}
+	if (CHANGE_INDIR(chq) && !CHANGE_INDIR(chp)) {
+		/* q does a change-indirect (sil etc.)
+		 * and p did not (yet).
+		 */
+		chp->c_flags |= CF_INDIR;
+		diff = TRUE;
+	}
+	if (USE_INDIR(usq) && !USE_INDIR(usp)) {
+		/* q does a use-indirect (lil etc.)
+		 * and p dis not (yet).
+		 */
+		usp->u_flags |= UF_INDIR;
+		diff = TRUE;
+	}
+	if (ENVIRON(q) && !ENVIRON(p)) {
+		/* q uses or changes local variables in its
+		 * environment while p does not (yet).
+		 */
+		p->p_flags1 |= PF_ENVIRON;
+		diff = TRUE;
+	}
+	return diff;
+}
+
+
+
+STATIC trans_clos(head)
+	proc_p head;
+{
+	/* Compute the transitive closure of the used/changed
+	 * variable information.
+	 */
+
+	register proc_p p,q;
+	Cindex i;
+	bool changes = TRUE;
+
+	while(changes) {
+		changes = FALSE;
+		for (p = head; p != (proc_p) 0; p = p->p_next) {
+		   if (!BODY_KNOWN(p)) continue;
+		   for (i = Cfirst(p->p_calling); i != (Cindex) 0;
+						i = Cnext(i,p->p_calling)) {
+			q = pmap[Celem(i)];
+			if (add_info(q,p)) {
+				changes = TRUE;
+			}
+		   }
+		}
+	}
+}
+
+
+
+
+indir_calls()
+{
+	Cindex i;
+	proc_p p;
+
+	for (i = Cfirst(cai_set); i != (Cindex) 0; i = Cnext(i,cai_set)) {
+		p = pmap[Celem(i)];  /* p does a CAI */
+		Cjoin(lpi_set, &p->p_calling);
+	}
+	Cdeleteset(lpi_set);
+	Cdeleteset(cai_set);
+}
+
+
+
+main(argc,argv)
+	int argc;
+	char *argv[];
+{
+	FILE *f, *f2, *gf2;  /* The EM input, EM output, basic block output */
+	bblock_p g;
+	short n, kind;
+	line_p l;
+
+	linecount = 0;
+	fproc = getptable(pname); /* proc table */
+	fdblock = getdtable(dname);  /* data block table */
+	lpi_set = Cempty_set(plength);
+	cai_set = Cempty_set(plength);
+	if ((f = fopen(lname,"r")) == NULL) {
+		error("cannot open %s", lname);
+	}
+	if ((f2 = fopen(lname2,"w")) == NULL) {
+		error("cannot open %s", lname2);
+	}
+	if ((gf2 = fopen(bname2,"w")) == NULL) {
+		error("cannot open %s",bname2);
+	}
+	while (getbblocks(f,&kind,&n,&g,&l)) {
+		/* read EM text of one unit and
+		 * (if it is a procedure)
+		 * partition it into n basic blocks.
+		 */
+		if (kind == LDATA) {
+			putunit(LDATA,(proc_p) 0,l,gf2,f2);
+		} else {
+			curproc->p_start = g;
+			/* The global variable curproc points to the
+			 * current procedure. It is set by getbblocks
+			 */
+			control_flow(g); /* compute pred and succ */
+			dominators(g,n); /* compute immediate dominators */
+			loop_detection(curproc); /* compute loops */
+			interproc_analysis(curproc);
+			/* Interprocedural analysis */
+			cf_cleanproc(curproc);
+			putunit(LTEXT,curproc,(line_p) 0,gf2,f2);
+			/* output control flow graph + text */
+		}
+	}
+	fclose(f);
+	fclose(f2);
+	fclose(gf2);
+	indir_calls();
+	trans_clos(fproc);
+	/* Compute transitive closure of used/changed
+	 * variables information for every procedure.
+	 */
+	if ((f = fopen(dname2,"w")) == NULL) {
+		error("cannot open %s",dname2);
+	}
+	putdtable(fdblock,f);
+	if ((f = fopen(pname2,"w")) == NULL) {
+		error("cannot open %s",pname2);
+	}
+	putptable(fproc,f,TRUE);
+	exit(0);
+}

util/ego/cf/cf.h

@@ -0,0 +1,13 @@
+/*  C O N T R O L   F L O W  */
+
+/* Macro's for extended data structures: */
+
+#define B_SEMI		b_extend->bx_cf.bx_semi
+#define B_PARENT	b_extend->bx_cf.bx_parent
+#define B_BUCKET	b_extend->bx_cf.bx_bucket
+#define B_ANCESTOR	b_extend->bx_cf.bx_ancestor
+#define B_LABEL		b_extend->bx_cf.bx_label
+
+#define LP_BLOCKS	lp_extend->lpx_cf.lpx_blocks
+#define LP_COUNT	lp_extend->lpx_cf.lpx_count
+#define LP_MESSY	lp_extend->lpx_cf.lpx_messy

util/ego/cf/cf_idom.c

@@ -0,0 +1,138 @@
+/*  C O N T R O L   F L O W
+ *
+ *  C F _ I D O M . C
+ */
+
+
+#include "../share/types.h"
+#include "../share/debug.h"
+#include "../share/lset.h"
+#include "../share/alloc.h"
+#include "cf.h"
+
+
+/* The algorithm for finding dominators in a flowgraph
+ * that is used here, was developed by Thomas Lengauer
+ * and Robert E. Tarjan of Stanford University.
+ * The algorithm is described in their article:
+ *	    A Fast Algorithm for Finding Dominators
+ *	    in a Flowgraph
+ *  which was published in:
+ *	   ACM Transactions on Programming Languages and Systems,
+ *	   Vol. 1, No. 1, July 1979, Pages 121-141.
+ */
+
+
+#define UNREACHABLE(b) (b->B_SEMI == (short) 0)
+
+short	dfs_nr;
+bblock_p *vertex;  /* dynamically allocated array */
+
+
+STATIC dfs(v)
+	bblock_p v;
+{
+	/* Depth First Search */
+
+	Lindex i;
+	bblock_p w;
+
+	v->B_SEMI = ++dfs_nr;
+	vertex[dfs_nr] = v->B_LABEL = v;
+	v->B_ANCESTOR = (bblock_p) 0;
+	for (i = Lfirst(v->b_succ); i != (Lindex) 0; i = Lnext(i,v->b_succ)) {
+		w = (bblock_p) Lelem(i);
+		if (w->B_SEMI == 0) {
+			w->B_PARENT = v;
+			dfs(w);
+		}
+	}
+}
+
+
+
+STATIC compress(v)
+	bblock_p v;
+{
+	if (v->B_ANCESTOR->B_ANCESTOR != (bblock_p) 0) {
+		compress(v->B_ANCESTOR);
+		if (v->B_ANCESTOR->B_LABEL->B_SEMI < v->B_LABEL->B_SEMI) {
+			v->B_LABEL = v->B_ANCESTOR->B_LABEL;
+		}
+		v->B_ANCESTOR = v->B_ANCESTOR->B_ANCESTOR;
+	}
+}
+
+
+
+STATIC bblock_p eval(v)
+	bblock_p v;
+{
+	if (v->B_ANCESTOR == (bblock_p) 0) {
+		return v;
+	} else {
+		compress(v);
+		return v->B_LABEL;
+	}
+}
+
+
+
+STATIC linkblocks(v,w)
+	bblock_p v,w;
+{
+	w->B_ANCESTOR = v;
+}
+
+
+
+dominators(r,n)
+	bblock_p r;
+	short n;
+{
+	/* Compute the immediate dominator of every basic
+	 * block in the control flow graph rooted by r.
+	 */
+
+	register short i;
+	Lindex ind, next;
+	bblock_p v,w,u;
+
+	dfs_nr = 0;
+	vertex = (bblock_p *) newmap(n);
+	/* allocate vertex (dynamic array). All remaining
+	 * initializations were done by the routine
+	 * nextblock of get.c.
+	 */
+	dfs(r);
+	for (i = dfs_nr; i > 1; i--) {
+		w = vertex[i];
+		for (ind = Lfirst(w->b_pred); ind != (Lindex) 0;
+						ind = Lnext(ind,w->b_pred)) {
+			v = (bblock_p) Lelem(ind);
+			if (UNREACHABLE(v)) continue;
+			u = eval(v);
+			if (u->B_SEMI < w->B_SEMI) {
+				w->B_SEMI = u->B_SEMI;
+			}
+		}
+		Ladd(w,&(vertex[w->B_SEMI]->B_BUCKET));
+		linkblocks(w->B_PARENT,w);
+		for (ind = Lfirst(w->B_PARENT->B_BUCKET); ind != (Lindex) 0;
+							   ind = next) {
+			next = Lnext(ind,w->B_PARENT->B_BUCKET);
+			v = (bblock_p) Lelem(ind);
+			Lremove(v,&w->B_PARENT->B_BUCKET);
+			u = eval(v);
+			v->b_idom = (u->B_SEMI < v->B_SEMI ? u : w->B_PARENT);
+		}
+	}
+	for (i = 2; i <= dfs_nr; i++) {
+		w = vertex[i];
+		if (w->b_idom != vertex[w->B_SEMI]) {
+			w->b_idom = w->b_idom->b_idom;
+		}
+	}
+	r->b_idom = (bblock_p) 0;
+	oldmap(vertex,n);   /* release memory for dynamic array vertex */
+}

util/ego/cf/cf_idom.h

@@ -0,0 +1,15 @@
+/*  C O N T R O L   F L O W
+ *
+ *  I M M E D I A T E   D O M I N A T O R S
+ */
+
+
+extern dominator();	/* (bblock_p head, short n)
+			 * Compute for every basic block its immediate
+			 * dominator. The dominator relation is hence
+			 * recorded as a tree in which every node contains
+			 * a pointer to its parent, which is its
+			 * immediate dominator.
+			 * 'n' is the number of nodes (basic blocks) in
+			 * the control flow graph.
+			 */

util/ego/cf/cf_loop.c

@@ -0,0 +1,400 @@
+/*  C O N T R O L   F L O W
+ *
+ *  C F _ L O O P . C
+ */
+
+
+#include "../share/types.h"
+#include "../share/debug.h"
+#include "../share/lset.h"
+#include "../share/alloc.h"
+#include "../share/aux.h"
+#include "cf.h"
+
+#define MARK_STRONG(b)	b->b_flags |= BF_STRONG
+#define MARK_FIRM(b)	b->b_flags |= BF_FIRM
+#define BF_MARK		04
+#define MARK(b)		b->b_flags |= BF_MARK
+#define MARKED(b)	(b->b_flags&BF_MARK)
+#define INSIDE_LOOP(b,lp)  Lis_elem(b,lp->LP_BLOCKS)
+
+
+
+/* The algorithm to detect loops that is used here is taken
+ * from: Aho & Ullman, Principles of Compiler Design, section 13.1.
+ * The algorithm uses the dominator relation between nodes
+ * of the control flow graph:
+ *  d DOM n => every path from the initial node to n goes through d.
+ * The dominator relation is recorded via the immediate dominator tree
+ * (b_idom field of bblock struct) from which the dominator relation
+ * can be easily computed (see procedure 'dom' below).
+ * The algorithm first finds 'back edges'. A back edge is an edge
+ * a->b in the flow graph whose head (b) dominates its tail (a).
+ * The 'natural loop' of back edge n->d consists of those nodes
+ * that can reach n without going through d. These nodes, plus d
+ * form the loop.
+ * The whole process is rather complex, because different back edges
+ * may result in the same loop and because loops may partly overlap
+ * each other (without one being nested inside the other).
+ */
+
+
+
+STATIC bool same_loop(l1,l2)
+	loop_p l1,l2;
+{
+	/* Two loops are the same if:
+	 * (1)  they have the same number of basic blocks, and
+	 * (2)  the head of the back edge of the first loop
+	 *      also is part of the second loop, and
+	 * (3)  the tail of the back edge of the first loop
+	 *      also is part of the second loop.
+	 */
+
+	return (l1->LP_COUNT == l2->LP_COUNT &&
+		Lis_elem(l1->lp_entry, l2->LP_BLOCKS) &&
+		Lis_elem(l1->lp_end,   l2->LP_BLOCKS));
+}
+
+
+
+STATIC bool inner_loop(l1,l2)
+	loop_p l1,l2;
+{
+	/* Loop l1 is an inner loop of l2 if:
+	 * (1)  the first loop has fewer basic blocks than
+	 *      the second one, and
+	 * (2)  the head of the back edge of the first loop
+	 *      also is part of the second loop, and
+	 * (3)  the tail of the back edge of the first loop
+	 *      also is part of the second loop.
+	 */
+
+	return (l1->LP_COUNT < l2->LP_COUNT &&
+		Lis_elem(l1->lp_entry, l2->LP_BLOCKS) &&
+		Lis_elem(l1->lp_end,   l2->LP_BLOCKS));
+}
+
+
+
+STATIC insrt(b,lpb,s_p)
+	bblock_p b;
+	lset *lpb;
+	lset *s_p;
+{
+	/* Auxiliary routine used by 'natural_loop'.
+	 * Note that we use a set rather than a stack,
+	 * as Aho & Ullman do.
+	 */
+
+	if (!Lis_elem(b,*lpb)) {
+		Ladd(b,lpb);
+		Ladd(b,s_p);
+	}
+}
+
+
+STATIC loop_p natural_loop(d,n)
+	bblock_p d,n;
+{
+	/* Find the basic blocks of the natural loop of the
+	 * back edge 'n->d' (i.e. n->d is an edge in the control
+	 * flow graph and d dominates n). The natural loop consists
+	 * of those blocks which can reach n without going through d.
+	 * We find these blocks by finding all predecessors of n,
+	 * up to d.
+	 */
+
+	loop_p lp;
+	bblock_p m;
+	lset loopblocks;
+	Lindex pi;
+	lset s;
+
+	lp = newloop();
+	lp->lp_extend = newcflpx();
+	lp->lp_entry = d;	/* loop entry block */
+	lp->lp_end = n;		/* tail of back edge */
+	s = Lempty_set();
+	loopblocks = Lempty_set();
+	Ladd(d,&loopblocks);
+	insrt(n,&loopblocks,&s);
+	while ((pi = Lfirst(s)) != (Lindex) 0) {
+		m = (bblock_p) Lelem(pi);
+		Lremove(m,&s);
+		for (pi = Lfirst(m->b_pred); pi != (Lindex) 0;
+					pi = Lnext(pi,m->b_pred)) {
+			insrt((bblock_p) Lelem(pi),&loopblocks,&s);
+		}
+	}
+	lp->LP_BLOCKS = loopblocks;
+	lp->LP_COUNT = Lnrelems(loopblocks);
+	return lp;
+}
+
+
+STATIC loop_p org_loop(lp,loops)
+	loop_p lp;
+	lset   loops;
+{
+	/* See if the loop lp was already found via another
+	 * back edge; if so return this loop; else return 0.
+	 */
+
+	register Lindex li;
+
+	for (li = Lfirst(loops); li != (Lindex) 0; li = Lnext(li,loops)) {
+		if (same_loop((loop_p) Lelem(li), lp)) {
+#ifdef DEBUG
+			/* printf("messy loop found\n"); */
+#endif
+			return (loop_p) Lelem(li);
+		}
+	}
+	return (loop_p) 0;
+}
+
+
+
+STATIC collapse_loops(loops_p)
+	lset *loops_p;
+{
+	register Lindex li1, li2;
+	register loop_p lp1,lp2;
+
+	for (li1 = Lfirst(*loops_p); li1 != (Lindex) 0; li1 = Lnext(li1,*loops_p)) {
+		lp1 = (loop_p) Lelem(li1);
+		lp1->lp_level = (short) 0;
+		for (li2 = Lfirst(*loops_p); li2 != (Lindex) 0;
+					li2 = Lnext(li2,*loops_p)) {
+			lp2 = (loop_p) Lelem(li2);
+			if (lp1 != lp2 && lp1->lp_entry == lp2->lp_entry) {
+			    Ljoin(lp2->LP_BLOCKS,&lp1->LP_BLOCKS);
+			    oldcflpx(lp2->lp_extend);
+			    Lremove(lp2,loops_p);
+			}
+		}
+	}
+}
+
+
+STATIC loop_per_block(lp)
+	loop_p lp;
+{
+	bblock_p b;
+
+	/* Update the b_loops sets */
+
+	register Lindex bi;
+
+	for (bi = Lfirst(lp->LP_BLOCKS); bi != (Lindex) 0;
+		bi = Lnext(bi,lp->LP_BLOCKS)) {
+			b = (bblock_p) Lelem(bi);
+			Ladd(lp,&(b->b_loops));
+	}
+}
+
+
+
+STATIC loop_attrib(loops)
+	lset loops;
+{
+	/* Compute several attributes */
+
+	register Lindex li;
+	register loop_p lp;
+	loop_id lastlpid = 0;
+
+	for (li = Lfirst(loops); li != (Lindex) 0; li = Lnext(li,loops)) {
+		lp = (loop_p) Lelem(li);
+		lp->lp_id = ++lastlpid;
+		loop_per_block(lp);
+	}
+}
+
+
+
+STATIC nest_levels(loops)
+	lset loops;
+{
+	/* Compute the nesting levels of all loops of
+	 * the current procedure. For every loop we just count
+	 * all loops of which the former is an inner loop.
+	 * The running time is quadratic in the number of loops
+	 * of the current procedure. As this number tends to be
+	 * very small, there is no cause for alarm.
+	 */
+
+	register Lindex li1, li2;
+	register loop_p lp;
+
+	for (li1 = Lfirst(loops); li1 != (Lindex) 0; li1 = Lnext(li1,loops)) {
+		lp = (loop_p) Lelem(li1);
+		lp->lp_level = (short) 0;
+		for (li2 = Lfirst(loops); li2 != (Lindex) 0;
+					li2 = Lnext(li2,loops)) {
+			if (inner_loop(lp,(loop_p) Lelem(li2))) {
+				lp->lp_level++;
+			}
+		}
+	}
+}
+
+
+STATIC cleanup(loops)
+	lset loops;
+{
+	/* Throw away the LP_BLOCKS sets */
+
+	register Lindex i;
+
+	for (i = Lfirst(loops); i != (Lindex) 0; i = Lnext(i,loops)) {
+		Ldeleteset(((loop_p) Lelem(i))->LP_BLOCKS);
+	}
+}
+
+
+STATIC bool does_exit(b,lp)
+	bblock_p b;
+	loop_p   lp;
+{
+	/* See if b may exit the loop, i.e. if it
+	 * has a successor outside the loop
+	 */
+
+	Lindex i;
+
+	for (i = Lfirst(b->b_succ); i != (Lindex) 0; i = Lnext(i,b->b_succ)) {
+		if (!INSIDE_LOOP(Lelem(i),lp)) return TRUE;
+	}
+	return FALSE;
+}
+
+
+STATIC mark_succ(b,lp)
+	bblock_p b;
+	loop_p   lp;
+{
+	Lindex i;
+	bblock_p succ;
+
+	for (i = Lfirst(b->b_succ); i != (Lindex) 0; i = Lnext(i,b->b_succ)) {
+		succ = (bblock_p) Lelem(i);
+		if (succ != b && succ != lp->lp_entry && INSIDE_LOOP(succ,lp) &&
+		   !MARKED(succ)) {
+			MARK(succ);
+			mark_succ(succ,lp);
+		}
+	}
+}
+
+
+STATIC mark_blocks(lp)
+	loop_p lp;
+{
+	/* Mark the strong and firm blocks of a loop.
+	 * The last set of blocks consists of the end-block
+	 * of the loop (i.e. the head of the back edge
+	 * of the natural loop) and its dominators
+	 * (including the loop entry block, i.e. the
+	 * tail of the back edge).
+	 */
+
+	register bblock_p b;
+
+	/* First mark all blocks that are the successor of a
+	 * block that may exit the loop (i.e. contains a
+	 * -possibly conditional- jump to somewhere outside
+	 * the loop.
+	 */
+
+	if (lp->LP_MESSY) return; /* messy loops are hopeless cases */
+	for (b = lp->lp_entry; b != (bblock_p) 0; b = b->b_next) {
+		if (!MARKED(b) && does_exit(b,lp)) {
+			mark_succ(b,lp);
+		}
+	}
+
+	/* Now find all firm blocks. A block is strong
+	 * if it is firm and not marked.
+	 */
+
+	for (b = lp->lp_end; ; b = b->b_idom) {
+		MARK_FIRM(b);
+		if (!MARKED(b)) {
+			MARK_STRONG(b);
+		}
+		if (b == lp->lp_entry) break;
+	}
+}
+
+
+
+STATIC mark_loopblocks(loops)
+	lset loops;
+{
+	/* Determine for all loops which basic blocks
+	 * of the loop are strong (i.e. are executed
+	 * during every iteration) and which blocks are
+	 * firm (i.e. executed during every iteration with
+	 * the only possible exception of the last one).
+	 */
+	
+	Lindex i;
+	loop_p lp;
+
+	for (i = Lfirst(loops); i != (Lindex) 0; i = Lnext(i,loops)) {
+		lp = (loop_p) Lelem(i);
+		mark_blocks(lp);
+	}
+}
+
+
+
+loop_detection(p)
+	proc_p p;
+{
+	/* Find all natural loops of procedure p. Every loop is
+	 * assigned a unique identifying number, a set of basic
+	 * blocks, a loop entry block and a nesting level number.
+	 * Every basic block is assigned a nesting level number
+	 * and a set of loops it is part of.
+	 */
+
+	lset loops;  /* the set of all loops */
+	loop_p lp,org;
+	register bblock_p b;
+	bblock_p s;
+	Lindex si;
+
+	loops = Lempty_set();
+	for (b = p->p_start; b != (bblock_p) 0; b = b->b_next) {
+		for (si = Lfirst(b->b_succ); si != (Lindex) 0;
+						si = Lnext(si,b->b_succ)) {
+			s = (bblock_p) Lelem(si);
+			if (dom(s,b)) {
+				/* 'b->s' is a back edge */
+				lp = natural_loop(s,b);
+				if ((org = org_loop(lp,loops)) == (loop_p) 0) {
+				   /* new loop */
+				   Ladd(lp,&loops);
+				} else {
+				   /* Same loop, generated by several back
+				    * edges; such a loop is called a messy
+				    * loop.
+				    */
+				   org->LP_MESSY = TRUE;
+				   Ldeleteset(lp->LP_BLOCKS);
+				   oldcflpx(lp->lp_extend);
+				   oldloop(lp);
+				}
+			}
+		}
+	}
+	collapse_loops(&loops);
+	loop_attrib(loops);
+	nest_levels(loops);
+	mark_loopblocks(loops); /* determine firm and strong blocks */
+	cleanup(loops);
+	p->p_loops = loops;
+}

util/ego/cf/cf_loop.h

@@ -0,0 +1,14 @@
+/*  C O N T R O L   F L O W
+ *
+ *  L O O P   D E T E C T I O N
+ */
+
+extern loop_detection();	/* (proc_p p)
+				 * Detect all loops of procedure p.
+				 * Every basic block of p is assigned
+				 * a set of all loops it is part of.
+				 * For every loop we record the number
+				 * of blocks it contains, the loop entry
+				 * block and its nesting level (0 = outer
+				 * loop, 1 = loop within loop etc.).
+				 */

util/ego/cf/cf_succ.c

@@ -0,0 +1,250 @@
+/*  C O N T R O L   F L O W
+ *
+ *  C F _ S U C C . C
+ */
+
+
+#include <stdio.h>
+#include "../share/types.h"
+#include "../share/def.h"
+#include "../share/debug.h"
+#include "../share/global.h"
+#include "../share/lset.h"
+#include "../share/cset.h"
+#include "../../../h/em_spec.h"
+#include "../../../h/em_pseu.h"
+#include "../../../h/em_flag.h"
+#include "../../../h/em_mnem.h"
+#include "cf.h"
+#include "../share/map.h"
+
+extern char em_flag[];
+
+
+STATIC succeeds(succ,pred)
+	bblock_p succ, pred;
+{
+	assert(pred != (bblock_p) 0);
+	if (succ != (bblock_p) 0) {
+		Ladd(succ, &pred->b_succ);
+		Ladd(pred, &succ->b_pred);
+	}
+}
+
+
+#define IS_RETURN(i)	(i == op_ret || i == op_rtt)
+#define IS_CASE_JUMP(i)	(i == op_csa || i == op_csb)
+#define IS_UNCOND_JUMP(i) (i <= sp_lmnem && (em_flag[i-sp_fmnem] & EM_FLO) == FLO_T)
+#define IS_COND_JUMP(i)	(i <= sp_lmnem && (em_flag[i-sp_fmnem] & EM_FLO) == FLO_C)
+#define TARGET(lnp)	(lbmap[INSTRLAB(lnp)])
+#define ATARGET(arg)	(lbmap[arg->a_a.a_instrlab])
+
+
+
+STATIC arg_p skip_const(arg)
+	arg_p arg;
+{
+	assert(arg != (arg_p) 0);
+	switch(arg->a_type) {
+		case ARGOFF:
+		case ARGICN:
+		case ARGUCN:
+			break;
+		default:
+			error("bad case descriptor");
+	}
+	return arg->a_next;
+}
+
+
+STATIC arg_p use_label(arg,b)
+	arg_p arg;
+	bblock_p b;
+{
+	if (arg->a_type == ARGINSTRLAB) {
+		/* arg is a non-null label */
+		succeeds(ATARGET(arg),b);
+	}
+	return arg->a_next;
+}
+
+
+
+STATIC case_flow(instr,desc,b)
+	short    instr;
+	line_p   desc;
+	bblock_p b;
+{
+	/* Analyse the case descriptor (given as a ROM pseudo instruction).
+	 * Every instruction label appearing in the descriptor
+	 * heads a basic block that is a successor of the block
+	 * in which the case instruction appears (b).
+	 */
+
+	register arg_p arg;
+
+	assert(instr == op_csa || instr == op_csb);
+	assert(TYPE(desc) == OPLIST);
+	arg = ARG(desc);
+	arg = use_label(arg,b);
+	/* See if there is a default label. If so, then
+	 * its block is a successor of b. Set arg to
+	 * next argument.
+	 */
+	if (instr == op_csa) {
+		arg = skip_const(arg); /* skip lower bound */
+		arg = skip_const(arg); /* skip lower-upper bound */
+		while (arg != (arg_p) 0) {
+			/* All following arguments are case labels
+			 * or zeroes.
+			 */
+			arg = use_label(arg,b);
+		}
+	} else {
+		/* csb instruction */
+		arg = skip_const(arg);  /* skip #entries */
+		while (arg != (arg_p) 0) {
+			/* All following arguments are alternatively
+			 * an index and an instruction label (possibly 0).
+			 */
+			arg = skip_const(arg);  /* skip index */
+			arg = use_label(arg,b);
+		}
+	}
+}
+
+
+
+STATIC line_p case_descr(lnp)
+	line_p lnp;
+{
+	/* lnp is the instruction just before a csa or csb,
+	 * so it is the instruction that pushes the address
+	 * of a case descriptor on the stack. Find that
+	 * descriptor, i.e. a rom pseudo instruction.
+	 * Note that this instruction will always be part
+	 * of the procedure in which the csa/csb occurs.
+	 */
+
+	register line_p l;
+	dblock_p d;
+	obj_p    obj;
+	dblock_id id;
+
+	if (lnp == (line_p) 0 || (INSTR(lnp)) != op_lae) {
+		error("cannot find 'lae descr' before csa/csb");
+	}
+	/* We'll first find the ROM and its dblock_id */
+	obj = OBJ(lnp);
+	if (obj->o_off != (offset) 0) {
+		error("bad 'lae descr' before csa/csb");
+		/* We require a descriptor to be an entire rom,
+		 * not part of a rom.
+		 */
+	}
+	d = obj->o_dblock;
+	assert(d != (dblock_p) 0);
+	if (d->d_pseudo != DROM) {
+		error("case descriptor must be in rom");
+	}
+	id = d->d_id;
+	/* We'll use the dblock_id to find the defining occurrence
+	 * of the rom in the EM text (i.e. a rom pseudo). As all
+	 * pseudos appear at the beginning of a procedure, we only
+	 * have to look in its first basic block.
+	 */
+	assert(curproc != (proc_p) 0);
+	assert(curproc->p_start != (bblock_p) 0);
+	l = curproc->p_start->b_start; /* first instruction of curproc */
+	while (l != (line_p) 0) {
+		if ((INSTR(l)) == ps_sym &&
+		    SHORT(l) == id) {
+			/* found! */
+			assert((INSTR(l->l_next)) == ps_rom);
+			return l->l_next;
+		}
+		l = l->l_next;
+	}
+	error("cannot find rom pseudo for case descriptor");
+	/* NOTREACHED */
+}
+
+
+
+STATIC last2_instrs(b,last_out,prev_out)
+	bblock_p b;
+	line_p   *last_out,*prev_out;
+{
+	/* Determine the last and one-but-last instruction
+	 * of basic block b. An end-pseudo is not regarded
+	 * as an instruction. If the block contains only 1
+	 * instruction, prev_out is 0.
+	 */
+
+	register line_p l1,l2;
+
+	l2 = b->b_start;  /* first instruction of b */
+	assert(l2 != (line_p) 0); /* block can not be empty */
+	if ((l1 = l2->l_next) == (line_p) 0 || INSTR(l1) == ps_end) {
+		*last_out = l2; /* single instruction */
+		*prev_out = (line_p) 0;
+	} else {
+		while(l1->l_next != (line_p) 0 && INSTR(l1->l_next) != ps_end) {
+			l2 = l1;
+			l1 = l1->l_next;
+		}
+		*last_out = l1;
+		*prev_out = l2;
+	}
+}
+
+
+
+control_flow(head)
+	bblock_p head;
+{
+	/* compute the successor and predecessor relation
+	 * for every basic block.
+	 */
+
+	register bblock_p b;
+	line_p lnp, prev;
+	short instr;
+
+	for (b = head; b != (bblock_p) 0; b = b->b_next) {
+		/* for every basic block, in textual order, do */
+		last2_instrs(b, &lnp, &prev);
+		/* find last and one-but-last instruction */
+		instr = INSTR(lnp);
+		/* The last instruction of the basic block
+		 * determines the set of successors of the block.
+		 */
+		if (IS_CASE_JUMP(instr)) {
+			case_flow(instr,case_descr(prev),b);
+			/* If lnp is a csa or csb, then the instruction
+			 * just before it (i.e. prev) must be the
+			 * instruction that pushes the address of the
+			 * case descriptor. This descriptor is found
+			 * and analysed in order to build the successor
+			 * and predecessor sets of b.
+			 */
+		} else {
+		   if (!IS_RETURN(instr)) {
+			if (IS_UNCOND_JUMP(instr)) {
+				succeeds(TARGET(lnp),b);
+			} else {
+				if (IS_COND_JUMP(instr)) {
+					succeeds(TARGET(lnp),b);
+					succeeds(b->b_next, b);
+					/* Textually next block is
+					 * a successor of b.
+					 */
+				} else {
+					/* normal instruction */
+					succeeds(b->b_next, b);
+				}
+			}
+		   }
+		}
+	}
+}

util/ego/cf/cf_succ.h

@@ -0,0 +1,10 @@
+/*  C O N T R O L   F L O W
+ *
+ *  S U C C E S S O R  /  P R E D E C E S S O R   R E L A T I O N S
+ */
+
+extern control_flow();		/* (bblock_p head)
+				 * Compute for every basic block
+				 * its successors and predecessors
+				 * in the control flow graph.
+				 */

util/ego/cs/cs.h

@@ -0,0 +1,123 @@
+typedef short		valnum;
+typedef struct entity 	*entity_p;
+typedef struct avail 	*avail_p;
+typedef struct token	*token_p;
+typedef struct occur	*occur_p;
+
+struct token {
+	valnum	tk_vn;
+	offset	tk_size;
+	line_p	tk_lfirst;	/* Textually first instruction, involved
+			 	 * in pushing this token.
+				 */
+};
+
+	/* We distinguish these entities. */
+#define ENCONST		0
+#define ENLOCAL		1
+#define ENEXTERNAL	2
+#define ENINDIR		3
+#define ENOFFSETTED	4
+#define ENALOCAL	5
+#define ENAEXTERNAL	6
+#define ENAOFFSETTED	7
+#define ENALOCBASE	8
+#define ENAARGBASE	9
+#define ENPROC		10
+#define ENFZER		11
+#define ENARRELEM	12
+#define ENLOCBASE	13
+#define ENHEAPPTR	14
+#define ENIGNMASK	15
+
+struct entity {
+	valnum	en_vn;
+	bool	en_static;
+	byte	en_kind;		/* ENLOCAL, ENEXTERNAL, etc.	*/
+	offset	en_size;
+	union {
+		offset	en__val;	/* ENCONST.			*/
+		offset	en__loc;	/* ENLOCAL, ENALOCAL.		*/
+		obj_p	en__ext;	/* ENEXTERNAL, ENAEXTERNAL.	*/
+		valnum	en__ind;	/* ENINDIR.			*/
+		struct {
+			valnum	en__base;
+			offset	en__off;
+		} en_offs;		/* ENOFFSETTED, ENAOFFSETTED.	*/
+		offset	en__levels;	/* ENALOCBASE, ENAARGBASE.	*/
+		proc_p	en__pro;	/* ENPROC.			*/
+		struct {
+			valnum	en__arbase;
+			valnum	en__index;
+			valnum	en__adesc;
+		} en_arr;		/* ENARRELEM.			*/
+	} en_inf;
+};
+
+	/* Macros to increase ease of use. */
+#define en_val		en_inf.en__val
+#define en_loc		en_inf.en__loc
+#define en_ext		en_inf.en__ext
+#define en_ind		en_inf.en__ind
+#define en_base		en_inf.en_offs.en__base
+#define en_off		en_inf.en_offs.en__off
+#define en_levels	en_inf.en__levels
+#define en_pro		en_inf.en__pro
+#define en_arbase	en_inf.en_arr.en__arbase
+#define en_index	en_inf.en_arr.en__index
+#define en_adesc	en_inf.en_arr.en__adesc
+
+struct occur {
+	line_p		oc_lfirst;  /* First instruction of expression. */
+	line_p		oc_llast;   /* Last one. */
+	bblock_p	oc_belongs; /* Basic block it belongs to. */
+};
+	    
+	/* We distinguish these groups of instructions. */
+#define SIMPLE_LOAD	0
+#define EXPENSIVE_LOAD	1
+#define LOAD_ARRAY	2
+#define STORE_DIRECT	3
+#define STORE_INDIR	4
+#define STORE_ARRAY	5
+#define UNAIR_OP	6
+#define BINAIR_OP	7
+#define TERNAIR_OP	8
+#define KILL_ENTITY	9
+#define SIDE_EFFECTS	10
+#define FIDDLE_STACK	11
+#define IGNORE		12
+#define HOPELESS	13
+#define BBLOCK_END	14
+
+struct avail {
+	avail_p	av_before;	/* Ptr to earlier discovered expressions. */
+	byte	av_instr;	/* Operator instruction. */
+	offset	av_size;
+	line_p	av_found;	/* Line where expression is first found. */
+	lset	av_occurs;	/* Set of recurrences of expression. */
+	entity_p av_saveloc;	/* Local where result is put in. */
+	valnum	av_result;
+	union {
+		valnum	av__operand;		/* EXPENSIVE_LOAD, UNAIR_OP. */
+		struct {
+			valnum	av__oleft;
+			valnum	av__oright;
+		} av_2;				/* BINAIR_OP. */
+		struct {
+			valnum	av__ofirst;
+			valnum	av__osecond;
+			valnum	av__othird;
+		} av_3;				/* TERNAIR_OP. */
+	} av_o;
+};
+
+	/* Macros to increase ease of use. */
+#define av_operand	av_o.av__operand
+#define av_oleft	av_o.av_2.av__oleft
+#define av_oright	av_o.av_2.av__oright
+#define av_ofirst	av_o.av_3.av__ofirst
+#define av_osecond	av_o.av_3.av__osecond
+#define av_othird	av_o.av_3.av__othird
+
+extern int Scs; /* Number of optimizations found. */

util/ego/cs/cs_alloc.c

@@ -0,0 +1,44 @@
+#include "../share/types.h"
+#include "../share/alloc.h"
+#include "cs.h"
+
+occur_p newoccur(l1, l2, b)
+	line_p l1, l2;
+	bblock_p b;
+{
+	/* Allocate a new struct occur and initialize it. */
+
+	register occur_p rop;
+
+	rop = (occur_p) newcore(sizeof(struct occur));
+	rop->oc_lfirst = l1; rop->oc_llast = l2; rop->oc_belongs = b;
+	return rop;
+}
+
+oldoccur(ocp)
+	occur_p ocp;
+{
+	oldcore((short *) ocp, sizeof(struct occur));
+}
+
+avail_p newavail()
+{
+	return (avail_p) newcore(sizeof(struct avail));
+}
+
+oldavail(avp)
+	avail_p avp;
+{
+	oldcore((short *) avp, sizeof(struct avail));
+}
+
+entity_p newentity()
+{
+	return (entity_p) newcore(sizeof(struct entity));
+}
+
+oldentity(enp)
+	entity_p enp;
+{
+	oldcore((short *) enp, sizeof(struct entity));
+}

util/ego/cs/cs_alloc.h

@@ -0,0 +1,24 @@
+extern occur_p	newoccur();	/* (line_p l1, l2; bblock_p b)
+				 * Returns a pointer to a new struct occur
+				 * and initializes it.
+				 */
+
+extern		oldoccur();	/* (occur_p ocp)
+				 * Release the struct occur ocp points to.
+				 */
+
+extern avail_p	newavail();	/* ()
+				 * Return a pointer to a new struct avail.
+				 */
+
+extern		oldavail();	/* (avail_p avp)
+				 * Release the struct avail avp points to.
+				 */
+
+extern entity_p	newentity();	/* ()
+				 * Return a pointer to a new struct entity.
+				 */
+
+extern		oldentity();	/* (entity_p enp)
+				 * Release the struct entity enp points to.
+				 */

util/ego/cs/cs_aux.c

@@ -0,0 +1,64 @@
+#include "../share/types.h"
+#include "../share/debug.h"
+#include "../share/aux.h"
+#include "../share/global.h"
+#include "../share/lset.h"
+#include "cs.h"
+#include "cs_entity.h"
+
+offset array_elemsize(vn)
+	valnum vn;
+{
+	/* Vn is the valuenumber of an entity that points to
+	 * an array-descriptor. The third element of this descriptor holds
+	 * the size of the array-elements.
+	 * IF we can find this entity, AND IF we can find the descriptor AND IF
+	 * this descriptor is located in ROM, then we return the size.
+	 */
+	entity_p enp;
+
+	enp = find_entity(vn);
+
+	if (enp == (entity_p) 0)
+		return UNKNOWN_SIZE;
+
+	if (enp->en_kind != ENAEXTERNAL)
+		return UNKNOWN_SIZE;
+
+	if (enp->en_ext->o_dblock->d_pseudo != DROM)
+		return UNKNOWN_SIZE;
+
+	return aoff(enp->en_ext->o_dblock->d_values, 2);
+}
+
+occur_p occ_elem(i)
+	Lindex i;
+{
+	return (occur_p) Lelem(i);
+}
+
+entity_p en_elem(i)
+	Lindex i;
+{
+	return (entity_p) Lelem(i);
+}
+
+/* The value numbers associated with each distinct value
+ * start at 1.
+ */
+
+STATIC valnum val_no;
+
+valnum newvalnum()
+{
+	/* Return a completely new value number. */
+
+	return ++val_no;
+}
+
+start_valnum()
+{
+	/* Restart value numbering. */
+
+	val_no = 0;
+}

util/ego/cs/cs_aux.h

@@ -0,0 +1,25 @@
+extern offset	array_elemsize();	/* (valnum vm)
+					 * Returns the size of array-elements,
+					 * if vn is the valuenumber of the
+					 * address of an array-descriptor.
+					 */
+
+extern occur_p	occ_elem();		/* (Lindex i)
+					 * Returns a pointer to the occurrence
+					 * of which i is an index in a set.
+					 */
+
+extern entity_p	en_elem();		/* (Lindex i)
+					 * Returns a pointer to the entity
+					 * of which i is an index in a set.
+					 */
+
+extern valnum	newvalnum();		/* ()
+					 * Returns a completely new
+					 * value number.
+					 */
+
+extern		start_valnum();		/* ()
+					 * Restart value numbering.
+					 */
+

util/ego/cs/cs_avail.h

@@ -0,0 +1,18 @@
+extern avail_p	avails;		/* The set of available expressions. */
+
+extern avail_p	av_enter();	/* (avail_p avp, occur_p ocp, byte kind)
+				 * Puts the available expression in avp
+				 * in the list of available expressions,
+				 * if it is not already there. Add ocp to set of
+				 * occurrences of this expression.
+				 * If we have a new expression, we test whether
+				 * the result is saved. When this expression
+				 * recurs,we test if we can still use the 
+				 * variable into which it was saved.
+				 * (Kind is the kind of the expression.)
+				 * Returns a pointer into the list.
+				 */
+
+extern		clr_avails();	/* Release all space occupied by the old list
+				 * of available expressions.
+				 */

util/ego/cs/cs_debug.c

@@ -0,0 +1,156 @@
+#include <stdio.h>
+#include "../../../h/em_spec.h"
+#include "../share/types.h"
+#include "../share/debug.h"
+#include "../share/lset.h"
+#include "cs.h"
+#include "cs_aux.h"
+#include "cs_avail.h"
+#include "cs_entity.h"
+
+#ifdef VERBOSE
+
+extern char em_mnem[]; /* The mnemonics of the EM instructions. */
+
+STATIC showinstr(lnp)
+	line_p lnp;
+{
+	/* Makes the instruction in `lnp' human readable. Only lines that
+	 * can occur in expressions that are going to be eliminated are
+	 * properly handled.
+	 */
+	if (INSTR(lnp) < sp_fmnem && INSTR(lnp) > sp_lmnem) {
+		fprintf(stderr,"*** ?\n");
+		return;
+	}
+
+	fprintf(stderr,"%s", &em_mnem[4 * (INSTR(lnp)-sp_fmnem)]);
+	switch (TYPE(lnp)) {
+		case OPNO:
+			break;
+		case OPSHORT:
+			fprintf(stderr," %d", SHORT(lnp));
+			break;
+		case OPOBJECT:
+			fprintf(stderr," %d", OBJ(lnp)->o_id);
+			break;
+		case OPOFFSET:
+			fprintf(stderr," %D", OFFSET(lnp));
+			break;
+		default:
+			fprintf(stderr," ?");
+			break;
+	}
+	fprintf(stderr,"\n");
+}
+
+SHOWOCCUR(ocp)
+	occur_p ocp;
+{
+	/* Shows all instructions in an occurrence. */
+
+	register line_p lnp, next;
+
+	if (verbose_flag) {
+		for (lnp = ocp->oc_lfirst; lnp != (line_p) 0; lnp = next) {
+			next = lnp == ocp->oc_llast ? (line_p) 0 : lnp->l_next;
+
+			showinstr(lnp);
+		}
+	}
+}
+
+#endif
+
+#ifdef TRACE
+
+SHOWAVAIL(avp)
+	avail_p avp;
+{
+	/* Shows an available expression. */
+	showinstr(avp->av_found);
+	fprintf(stderr,"result %d,", avp->av_result);
+	fprintf(stderr,"occurred %d times\n", Lnrelems(avp->av_occurs) + 1);
+
+}
+
+OUTAVAILS()
+{
+	register avail_p ravp;
+
+	fprintf(stderr,"AVAILABLE EXPRESSIONS\n");
+
+	for (ravp = avails; ravp != (avail_p) 0; ravp = ravp->av_before) {
+		SHOWAVAIL(ravp);
+		fprintf(stderr,"\n");
+	}
+}
+
+STATIC char *enkinds[] = {
+	"constant",
+	"local",
+	"external",
+	"indirect",
+	"offsetted",
+	"address of local",
+	"address of external",
+	"address of offsetted",
+	"address of local base",
+	"address of argument base",
+	"procedure",
+	"floating zero",
+	"array element",
+	"local base",
+	"heap pointer",
+	"ignore mask"
+};
+
+OUTENTITIES()
+{
+	register Lindex i;
+
+	fprintf(stderr,"ENTITIES\n");
+	for (i = Lfirst(entities); i != (Lindex) 0; i = Lnext(i, entities)) {
+		register entity_p rep = en_elem(i);
+
+		fprintf(stderr,"%s,", enkinds[rep->en_kind]);
+		fprintf(stderr,"size %D,", rep->en_size);
+		fprintf(stderr,"valno %d,", rep->en_vn);
+		switch (rep->en_kind) {
+			case ENCONST:
+				fprintf(stderr,"$%D\n", rep->en_val);
+				break;
+			case ENLOCAL:
+			case ENALOCAL:
+				fprintf(stderr,"%D(LB)\n", rep->en_loc);
+				break;
+			case ENINDIR:
+				fprintf(stderr,"*%d\n", rep->en_ind);
+				break;
+			case ENOFFSETTED:
+			case ENAOFFSETTED:
+				fprintf(stderr,"%D(%d)\n", rep->en_off, rep->en_base);
+				break;
+			case ENALOCBASE:
+			case ENAARGBASE:
+				fprintf(stderr,"%D levels\n", rep->en_levels);
+				break;
+			case ENARRELEM:
+				fprintf(stderr,"%d[%d], ",rep->en_arbase,rep->en_index);
+				fprintf(stderr,"rom at %d\n", rep->en_adesc);
+				break;
+		}
+		fprintf(stderr,"\n");
+	}
+}
+
+/* XXX */
+OUTTRACE(s, n)
+	char *s;
+{
+	fprintf(stderr,"trace: ");
+	fprintf(stderr,s, n);
+	fprintf(stderr,"\n");
+}
+
+#endif TRACE

util/ego/cs/cs_debug.h

@@ -0,0 +1,33 @@
+#ifdef VERBOSE
+
+extern SHOWOCCUR();	/* (occur_p ocp)
+			 * Shows all lines in an occurrence.
+			 */
+
+#else
+
+#define SHOWOCCUR(x)
+
+#endif
+
+#ifdef TRACE
+
+extern OUTAVAILS();	/* ()
+			 * Prints all available expressions.
+			 */
+
+extern OUTENTITIES();	/* ()
+			 * Prints all entities.
+			 */
+
+extern SHOWAVAIL();	/* (avail_p avp)
+			 * Shows an available expression.
+			 */
+
+#else TRACE
+
+#define OUTAVAILS()
+#define OUTENTITIES()
+#define SHOWAVAIL(x)
+
+#endif TRACE

util/ego/cs/cs_entity.c

@@ -0,0 +1,142 @@
+/* F U N C T I O N S   F O R   A C C E S S I N G   T H E   S E T
+ *
+ * O F   E N T I T I E S
+ */
+
+#include "../share/types.h"
+#include "../share/global.h"
+#include "../share/lset.h"
+#include "../share/debug.h"
+#include "cs.h"
+#include "cs_alloc.h"
+#include "cs_aux.h"
+
+lset entities; /* Our pseudo symbol-table. */
+
+entity_p find_entity(vn)
+	valnum vn;
+{
+	/* Try to find the entity with valuenumber vn. */
+
+	register Lindex i; 
+
+	for (i = Lfirst(entities); i != (Lindex) 0; i = Lnext(i, entities)) {
+		if (en_elem(i)->en_vn == vn)
+			return en_elem(i);
+	}
+
+	return (entity_p) 0;
+}
+
+STATIC bool same_entity(enp1, enp2)
+	entity_p enp1, enp2;
+{
+	if (enp1->en_kind != enp2->en_kind) return FALSE;
+	if (enp1->en_size != enp2->en_size) return FALSE;
+	if (enp1->en_size == UNKNOWN_SIZE) return FALSE;
+
+	switch (enp1->en_kind) {
+		case ENCONST:
+			return	enp1->en_val == enp2->en_val;
+		case ENLOCAL:
+		case ENALOCAL:
+			return	enp1->en_loc == enp2->en_loc;
+		case ENEXTERNAL:
+		case ENAEXTERNAL:
+			return	enp1->en_ext == enp2->en_ext;
+		case ENINDIR:
+			return	enp1->en_ind == enp2->en_ind;
+		case ENOFFSETTED:
+		case ENAOFFSETTED:
+			return	enp1->en_base == enp2->en_base &&
+				enp1->en_off == enp2->en_off;
+		case ENALOCBASE:
+		case ENAARGBASE:
+			return	enp1->en_levels == enp2->en_levels;
+		case ENPROC:
+			return	enp1->en_pro == enp2->en_pro;
+		case ENARRELEM:
+			return	enp1->en_arbase == enp2->en_arbase &&
+				enp1->en_index == enp2->en_index &&
+				enp1->en_adesc == enp2->en_adesc;
+		default:
+			return	TRUE;
+	}
+}
+
+STATIC copy_entity(src, dst)
+	entity_p src, dst;
+{
+	dst->en_static = src->en_static;
+	dst->en_kind = src->en_kind;
+	dst->en_size = src->en_size;
+
+	switch (src->en_kind) {
+		case ENCONST:
+			dst->en_val = src->en_val;
+			break;
+		case ENLOCAL:
+		case ENALOCAL:
+			dst->en_loc = src->en_loc;
+			break;
+		case ENEXTERNAL:
+		case ENAEXTERNAL:
+			dst->en_ext = src->en_ext;
+			break;
+		case ENINDIR:
+			dst->en_ind = src->en_ind;
+			break;
+		case ENOFFSETTED:
+		case ENAOFFSETTED:
+			dst->en_base = src->en_base;
+			dst->en_off = src->en_off;
+			break;
+		case ENALOCBASE:
+		case ENAARGBASE:
+			dst->en_levels = src->en_levels;
+			break;
+		case ENPROC:
+			dst->en_pro = src->en_pro;
+			break;
+		case ENARRELEM:
+			dst->en_arbase = src->en_arbase;
+			dst->en_index = src->en_index;
+			dst->en_adesc = src->en_adesc;
+			break;
+	}
+}
+
+entity_p en_enter(enp)
+	register entity_p enp;
+{
+	/* Put the entity in enp in the entity set, if it is not already there.
+	 * Return pointer to stored entity.
+	 */
+	register Lindex i;
+	register entity_p new;
+
+	for (i = Lfirst(entities); i != (Lindex) 0; i = Lnext(i, entities)) {
+		if (same_entity(en_elem(i), enp))
+			return en_elem(i);
+	}
+	/* A new entity. */
+	new = newentity();
+	new->en_vn = newvalnum();
+	copy_entity(enp, new);
+	Ladd(new, &entities);
+
+	return new;
+}
+
+clr_entities()
+{
+	/* Throw away all pseudo-symboltable information. */
+
+	register Lindex i;
+
+	for (i = Lfirst(entities); i != (Lindex) 0; i = Lnext(i, entities)) {
+		oldentity(en_elem(i));
+	}
+	Ldeleteset(entities);
+	entities = Lempty_set();
+}

util/ego/cs/cs_entity.h

@@ -0,0 +1,15 @@
+extern lset	entities;	/* The pseudo-symboltable. */
+
+extern entity_p	find_entity();	/* (valnum vn)
+				 * Tries to find an entity with value number vn.
+				 */
+
+extern entity_p	en_enter();	/* (entity_p enp)
+				 * Enter the entity in enp in the set of
+				 * entities if it was not already there.
+				 */
+
+extern		clr_entities();	/* ()
+				 * Release all space occupied by our
+				 * pseudo-symboltable.
+				 */

util/ego/cs/cs_kill.c

@@ -0,0 +1,372 @@
+#include "../../../h/em_mnem.h"
+#include "../share/types.h"
+#include "../share/debug.h"
+#include "../share/global.h"
+#include "../share/lset.h"
+#include "../share/cset.h"
+#include "../share/aux.h"
+#include "../share/map.h"
+#include "cs.h"
+#include "cs_aux.h"
+#include "cs_debug.h"
+#include "cs_avail.h"
+#include "cs_entity.h"
+
+STATIC base_valno(enp)
+	entity_p enp;
+{
+	/* Return the value number of the (base) address of an indirectly
+	 * accessed entity.
+	 */
+	switch (enp->en_kind) {
+		default:
+			assert(FALSE);
+			break;
+		case ENINDIR:
+			return enp->en_ind;
+		case ENOFFSETTED:
+			return enp->en_base;
+		case ENARRELEM:
+			return enp->en_arbase;
+	}
+	/* NOTREACHED */
+}
+
+STATIC entity_p find_base(vn)
+	valnum vn;
+{
+	/* Vn is the valuenumber of the (base) address of an indirectly
+	 * accessed entity. Return the entity that holds this address
+	 * recursively.
+	 */
+	register Lindex i;
+	register avail_p ravp;
+
+	for (i = Lfirst(entities); i != (Lindex) 0; i = Lnext(i, entities)) {
+		register entity_p renp = en_elem(i);
+
+		if (renp->en_vn == vn) {
+			switch (renp->en_kind) {
+				case ENAEXTERNAL:
+				case ENALOCAL:
+				case ENALOCBASE:
+				case ENAARGBASE:
+					return renp;
+				case ENAOFFSETTED:
+					return find_base(renp->en_base);
+			}
+		}
+	}
+
+	/* We couldn't find it among the entities.
+	 * Let's try the available expressions.
+	 */
+	for (ravp = avails; ravp != (avail_p) 0; ravp = ravp->av_before) {
+		if (ravp->av_result == vn) {
+			if (ravp->av_instr == (byte) op_aar)
+				return find_base(ravp->av_ofirst);
+			if (ravp->av_instr == (byte) op_ads)
+				return find_base(ravp->av_oleft);
+		}
+	}
+
+	/* Bad luck. */
+	return (entity_p) 0;
+}
+
+STATIC bool obj_overlap(op1, op2)
+	obj_p op1, op2;
+{
+	/* Op1 and op2 point to two objects in the same datablock.
+	 * Obj_overlap returns whether these objects might overlap.
+	 */
+	obj_p tmp;
+
+	if (op1->o_off > op2->o_off) {
+		/* Exchange them. */
+		tmp = op1; op1 = op2; op2 = tmp;
+	}
+	return	op1->o_size == UNKNOWN_SIZE ||
+		op1->o_off + op1->o_size > op2->o_off;
+}
+
+#define same_datablock(o1, o2)	((o1)->o_dblock == (o2)->o_dblock)
+
+STATIC bool addr_local(enp)
+	entity_p enp;
+{
+	/* Is enp the address of a stack item. */
+
+	if (enp == (entity_p) 0) return FALSE;
+
+	return	enp->en_kind == ENALOCAL || enp->en_kind == ENALOCBASE ||
+		enp->en_kind == ENAARGBASE;
+}
+
+STATIC bool addr_external(enp)
+	entity_p enp;
+{
+	/* Is enp the address of an external. */
+
+	return enp != (entity_p) 0 && enp->en_kind == ENAEXTERNAL;
+}
+
+STATIC kill_external(obp, indir)
+	obj_p obp;
+	int indir;
+{
+	/* A store is done via the object in obp. If this store is direct
+	 * we kill directly accessed entities in the same data block only
+	 * if they overlap with obp, otherwise we kill everything in the
+	 * data block. Indirectly accessed entities of which it can not be
+	 * proven taht they are not in the same data block, are killed in
+	 * both cases.
+	 */
+	register Lindex i;
+
+	OUTTRACE("kill external", 0);
+	for (i = Lfirst(entities); i != (Lindex) 0; i = Lnext(i, entities)) {
+		entity_p enp = en_elem(i);
+		entity_p base;
+
+		switch (enp->en_kind) {
+			case ENEXTERNAL:
+				if (!same_datablock(enp->en_ext, obp))
+					break;
+				if (!indir && !obj_overlap(enp->en_ext, obp))
+					break;
+				OUTTRACE("kill %d", enp->en_vn);
+				enp->en_vn = newvalnum();
+				break;
+			case ENINDIR:
+			case ENOFFSETTED:
+			case ENARRELEM:
+				/* We spare its value number if we are sure
+				 * that its (base) address points into the
+				 * stack or into another data block.
+				 */
+				base = find_base(base_valno(enp));
+				if (addr_local(base))
+					break;
+				if (addr_external(base) &&
+				    !same_datablock(base->en_ext, obp)
+				   )
+					break;
+				OUTTRACE("kill %d", enp->en_vn);
+				enp->en_vn = newvalnum();
+				break;
+		}
+	}
+}
+
+STATIC bool loc_overlap(enp1, enp2)
+	entity_p enp1, enp2;
+{
+	/* Enp1 and enp2 point to two locals. Loc_overlap returns whether
+	 * they overlap.
+	 */
+	entity_p tmp;
+
+	assert(enp1->en_kind == ENLOCAL && enp2->en_kind == ENLOCAL);
+
+	if (enp1->en_loc > enp2->en_loc) {
+		/* Exchange them. */
+		tmp = enp1; enp1 = enp2; enp2 = tmp;
+	}
+	if (enp1->en_loc < 0 && enp2->en_loc >= 0)
+		return	FALSE; /* Locals and parameters do not overlap. */
+	else	return	enp1->en_size == UNKNOWN_SIZE ||
+			enp1->en_loc + enp1->en_size > enp2->en_loc;
+}
+
+STATIC kill_local(enp, indir)
+	entity_p enp;
+	bool indir;
+{
+	/* This time a store is done into an ENLOCAL. */
+
+	register Lindex i;
+
+	OUTTRACE("kill local", 0);
+	for (i = Lfirst(entities); i != (Lindex) 0; i = Lnext(i, entities)) {
+		entity_p rep = en_elem(i);
+		entity_p base;
+
+		switch (rep->en_kind) {
+			case ENLOCAL:
+				if (indir) {
+					/* Kill locals that might be stored into
+					 * via a pointer. Note: enp not used.
+					 */
+					if (!is_regvar(rep->en_loc)) {
+						OUTTRACE("kill %d", rep->en_vn);
+						rep->en_vn = newvalnum();
+					}
+				} else if (loc_overlap(rep, enp)) {
+					/* Only kill overlapping locals. */
+					OUTTRACE("kill %d", rep->en_vn);
+					rep->en_vn = newvalnum();
+				}
+				break;
+			case ENINDIR:
+			case ENOFFSETTED:
+			case ENARRELEM:
+				if (!is_regvar(enp->en_loc)) {
+					base = find_base(base_valno(rep));
+					if (!addr_external(base)) {
+						OUTTRACE("kill %d", rep->en_vn);
+						rep->en_vn = newvalnum();
+					}
+				}
+				break;
+		}
+	}
+}
+
+STATIC kill_sim()
+{
+	/* A store is done into the ENIGNMASK. */
+
+	register Lindex i;
+
+	OUTTRACE("kill sim", 0);
+	for (i = Lfirst(entities); i != (Lindex) 0; i = Lnext(i, entities)) {
+		register entity_p rep = en_elem(i);
+
+		if (rep->en_kind == ENIGNMASK) {
+			OUTTRACE("kill %d", rep->en_vn);
+			rep->en_vn = newvalnum();
+			return; /* There is only one ignoremask. */
+		}
+	}
+}
+
+kill_direct(enp)
+	entity_p enp;
+{
+	/* A store will be done into enp. We must forget the values of all the
+	 * entities this one may overlap with.
+	 */
+	switch (enp->en_kind) {
+		default:
+			assert(FALSE);
+			break;
+		case ENEXTERNAL:
+			kill_external(enp->en_ext, FALSE);
+			break;
+		case ENLOCAL:
+			kill_local(enp, FALSE);
+			break;
+		case ENIGNMASK:
+			kill_sim();
+			break;
+	}
+}
+
+kill_indir(enp)
+	entity_p enp;
+{
+	/* An indirect store is done, in an ENINDIR,
+	 * an ENOFFSETTED or an ENARRELEM.
+	 */
+	entity_p p;
+
+	/* If we can find the (base) address of this entity, then we can spare
+	 * the entities that are provably not pointed to by the address.
+	 * We will also make use of the MES 3 pseudo's, generated by
+	 * the front-end. When a MES 3 is generated for a local, this local
+	 * will not be referenced indirectly.
+	 */
+	if ((p = find_base(base_valno(enp))) == (entity_p) 0) {
+		kill_much(); /* Kill all entities without registermessage. */
+	} else {
+		switch (p->en_kind) {
+			case ENAEXTERNAL:
+				/* An indirect store into global data. */
+				kill_external(p->en_ext, TRUE);
+				break;
+			case ENALOCAL:
+			case ENALOCBASE:
+			case ENAARGBASE:
+				/* An indirect store into stack data.  */
+				kill_local(p, TRUE);
+				break;
+		}
+	}
+}
+
+kill_much()
+{
+	/* Kills all killable entities,
+	 * except the locals for which a registermessage was generated.
+	 */
+	register Lindex i;
+
+	OUTTRACE("kill much", 0);
+	for (i = Lfirst(entities); i != (Lindex) i; i = Lnext(i, entities)) {
+		register entity_p rep = en_elem(i);
+
+		if (rep->en_static) continue;
+		if (rep->en_kind == ENLOCAL && is_regvar(rep->en_loc)) continue;
+		OUTTRACE("kill %d", rep->en_vn);
+		rep->en_vn = newvalnum();
+	}
+}
+
+STATIC bool bad_procflags(pp)
+	proc_p pp;
+{
+	/* Return whether the flags about the procedure in pp indicate
+	 * that we have little information about it. It might be that
+	 * we haven't seen the text of pp, or that we have seen that pp
+	 * calls a procedure which we haven't seen the text of.
+	 */
+	return !(pp->p_flags1 & PF_BODYSEEN) || (pp->p_flags1 & PF_CALUNKNOWN);
+}
+
+STATIC kill_globset(s)
+	cset s;
+{
+	/* S is a set of global variables that might be changed.
+	 * We act as if a direct store is done into each of them.
+	 */
+	register Cindex i;
+
+	OUTTRACE("kill globset", 0);
+	for (i = Cfirst(s); i != (Cindex) 0; i = Cnext(i,s)) {
+		kill_external(omap[Celem(i)], FALSE);
+	}
+}
+
+kill_call(pp)
+	proc_p pp;
+{
+	/* Kill everything that might be destroyed by calling
+	 * the procedure in pp.
+	 */
+	if (bad_procflags(pp)) {
+		/* We don't know enough about this procedure. */
+		kill_much();
+	} else if (pp->p_change->c_flags & CF_INDIR) {
+		/* The procedure does an indirect store. */
+		kill_much();
+	} else {
+		/* Procedure might affect global data. */
+		kill_globset(pp->p_change->c_ext);
+	}
+}
+
+kill_all()
+{
+	/* Kills all entities. */
+
+	register Lindex i;
+
+	OUTTRACE("kill all entities", 0);
+	for (i = Lfirst(entities); i != (Lindex) i; i = Lnext(i, entities)) {
+		entity_p enp = en_elem(i);
+
+		OUTTRACE("kill %d", enp->en_vn);
+		enp->en_vn = newvalnum();
+	}
+}

util/ego/cs/cs_kill.h

@@ -0,0 +1,24 @@
+extern	kill_call();	/* (proc_p pp)
+			 * Kill all entities that might have an other value
+			 * after execution of the procedure in pp.
+			 */
+
+extern	kill_much();	/* ()
+			 * Kill all killable entities except those for which
+			 * a register message was generated.
+			 * Constants, addresses, etc are not killable.
+			 */
+
+extern	kill_indir();	/* (entity_p enp)
+			 * Kill all entities that might have an other value
+			 * after indirect assignment to the entity in enp.
+			 */
+
+extern	kill_direct();	/* (entity_p enp)
+			 * Kill all entities that might have an other value
+			 * after direct assignment to the entity in enp.
+			 */
+
+extern	kill_all();	/* ()
+			 * Kill all entities.
+			 */

util/ego/cs/cs_profit.h

@@ -0,0 +1,10 @@
+extern		cs_machinit();	/* (FILE *f)
+				 * Read phase-specific information from f.
+				 */
+
+extern bool	desirable();	/* (avail_p avp)
+				 * Return whether it is desirable to eliminate
+				 * the recurrences of the expression in avp.
+				 * At the same time delete the recurrences
+				 * for which it is not allowed.
+				 */

util/ego/cs/cs_stack.c

@@ -0,0 +1,132 @@
+/*
+ * S T A C K   M O D U L E
+ */
+#include "../share/types.h"
+#include "../share/global.h"
+#include "../share/debug.h"
+#include "../share/aux.h"
+#include "cs.h"
+#include "cs_aux.h"
+
+#define STACK_DEPTH	50
+
+STATIC struct token	Stack[STACK_DEPTH];
+STATIC token_p		free_token;
+
+#define Delete_top()	{--free_token; }
+#define Empty_stack()	{free_token = &Stack[0]; }
+#define Stack_empty()	(free_token == &Stack[0])
+#define Top		(free_token - 1)
+
+Push(tkp)
+	token_p tkp;
+{
+	if (tkp->tk_size == UNKNOWN_SIZE) {
+		Empty_stack(); /* The contents of the Stack is useless. */
+	} else {
+		assert(free_token < &Stack[STACK_DEPTH]);
+
+		free_token->tk_vn = tkp->tk_vn;
+		free_token->tk_size = tkp->tk_size;
+		free_token++->tk_lfirst = tkp->tk_lfirst;
+	}
+}
+
+#define WORD_MULTIPLE(n)	((n / ws) * ws + ( n % ws ? ws : 0 ))
+
+Pop(tkp, size)
+	token_p tkp;
+	offset size;
+{
+	/* Pop a token with given size from the valuenumber stack into tkp. */
+
+	/* First simple case. */
+	if (size != UNKNOWN_SIZE && !Stack_empty() && size == Top->tk_size) {
+		tkp->tk_vn = Top->tk_vn;
+		tkp->tk_size = size;
+		tkp->tk_lfirst = Top->tk_lfirst;
+		Delete_top();
+		return;
+	}
+	/* Now we're in trouble: we must pop something that is not there!
+	 * We just put a dummy into tkp and pop tokens until we've
+	 * popped size bytes.
+	 */
+	/* Create dummy. */
+	tkp->tk_vn = newvalnum();
+	tkp->tk_lfirst = (line_p) 0;
+
+	/* Now fiddle with the Stack. */
+	if (Stack_empty()) return;
+	if (size == UNKNOWN_SIZE) {
+		Empty_stack();
+		return;
+	}
+	if (size > Top->tk_size) {
+		while (!Stack_empty() && size >= Top->tk_size) {
+			size -= Top->tk_size;
+			Delete_top();
+		}
+	}
+	/* Now Stack_empty OR size < Top->tk_size. */
+	if (!Stack_empty()) {
+		if (Top->tk_size - size < ws) {
+			Delete_top();
+		} else {
+			Top->tk_vn = newvalnum();
+			Top->tk_size -= WORD_MULTIPLE(size);
+		}
+	}
+}
+
+Dup(lnp)
+	line_p lnp;
+{
+	/* Duplicate top bytes on the Stack. */
+
+	register token_p bottom = Top;
+	register token_p oldtop = Top;
+	register offset	nbytes = off_set(lnp);
+	struct token dummy;
+
+	/* Find the bottom of the bytes to be duplicated.
+	 * It is possible that we cannot find it.
+	 */
+	while (bottom > &Stack[0] && bottom->tk_size < nbytes) {
+		nbytes -= bottom->tk_size;
+		bottom--;
+	}
+
+	if (bottom < &Stack[0]) {
+		/* There was nothing. */
+		dummy.tk_vn = newvalnum();
+		dummy.tk_size = nbytes;
+		dummy.tk_lfirst = lnp;
+		Push(&dummy);
+	} else {
+		if (bottom->tk_size < nbytes) {
+			/* Not enough, bottom == &Stack[0]. */
+			dummy.tk_vn = newvalnum();
+			dummy.tk_size = nbytes - bottom->tk_size;
+			dummy.tk_lfirst = lnp;
+			Push(&dummy);
+		} else if (bottom->tk_size > nbytes) {
+			/* Not integral # tokens. */
+			dummy.tk_vn = newvalnum();
+			dummy.tk_size = nbytes;
+			dummy.tk_lfirst = lnp;
+			Push(&dummy);
+			bottom++;
+		}
+		/* Bottom points to lowest token to be dupped. */
+		while (bottom <= oldtop) {
+			Push(bottom++);
+			Top->tk_lfirst = lnp;
+		}
+	}
+}
+
+clr_stack()
+{
+	free_token = &Stack[0];
+}

util/ego/cs/cs_stack.h

@@ -0,0 +1,18 @@
+extern	Push();		/* (token_p tkp)
+			 * Push the token in tkp on the fake-stack.
+			 */
+
+extern	Pop();		/* (token_p tkp; offset size)
+			 * Pop a token of size bytes from the fake-stack
+			 * into tkp. If such a token is not there
+			 * we put a dummy in tkp and adjust the fake-stack.
+			 */
+
+extern	Dup();		/* (line_p lnp)
+			 * Reflect the changes made by the dup-instruction
+			 * in lnp to the EM-stack into the fake-stack.
+			 */
+
+extern	clr_stack();	/* ()
+			 * Clear the fake-stack.
+			 */

util/ego/cs/cs_vnm.h

@@ -0,0 +1,4 @@
+extern vnm();	/* (bblock_p bp)
+		 * Performs the valuenumbering algorithm on the basic
+		 * block in bp.
+		 */

util/ego/ic/Makefile

@@ -0,0 +1,88 @@
+EMH=../../../h
+EML=../../../lib
+CFLAGS=
+DEBUG=../share
+SHARE=../share
+MALLOC=
+IC=.
+OBJECTS=ic.o ic_aux.o ic_lookup.o ic_io.o ic_lib.o
+MOBJECTS=ic.m ic_aux.m ic_lookup.m ic_io.m ic_lib.m
+SHOBJECTS=$(SHARE)/put.o $(SHARE)/alloc.o $(SHARE)/global.o $(SHARE)/debug.o $(SHARE)/files.o $(SHARE)/map.o $(SHARE)/lset.o $(SHARE)/cset.o $(SHARE)/aux.o
+MSHOBJECTS=$(SHARE)/put.m $(SHARE)/alloc.m $(SHARE)/global.m $(SHARE)/debug.m $(SHARE)/files.m $(SHARE)/map.m $(SHARE)/lset.m $(SHARE)/cset.m
+SRC=ic.h ic_aux.h ic_lib.h ic_lookup.h ic_io.h ic.c ic_aux.c ic_lib.c ic_lookup.c ic_io.c
+.SUFFIXES: .m
+.c.m:
+	ack -O -L -c.m $(CFLAGS) $<
+.c.o:
+	cc $(CFLAGS) -c $<
+all:	$(OBJECTS)
+ic: \
+	$(OBJECTS) $(SHOBJECTS)
+	 cc -i -o ic $(OBJECTS) $(SHOBJECTS) $(EML)/em_data.a $(MALLOC)
+optim:	$(MOBJECTS) $(MSHOBJECTS) 
+	 ego IC CF $(F) CA $(MOBJECTS) $(MSHOBJECTS)
+	 ack -O -o ic.ego -.c lfile.m $(EML)/em_data.a
+	 
+lpr:
+	pr $(SRC) | lpr
+dumpflop:
+	tar -uf /mnt/ego/ic/ic.tarf $(SRC) Makefile
+# the next lines are generated automatically
+# AUTOAUTOAUTOAUTOAUTOAUTO
+ic.o:	../../../h/em_flag.h
+ic.o:	../../../h/em_mes.h
+ic.o:	../../../h/em_pseu.h
+ic.o:	../../../h/em_spec.h
+ic.o:	../share/alloc.h
+ic.o:	../share/aux.h
+ic.o:	../share/debug.h
+ic.o:	../share/def.h
+ic.o:	../share/files.h
+ic.o:	../share/global.h
+ic.o:	../share/map.h
+ic.o:	../share/put.h
+ic.o:	../share/types.h
+ic.o:	ic.h
+ic.o:	ic_aux.h
+ic.o:	ic_io.h
+ic.o:	ic_lib.h
+ic.o:	ic_lookup.h
+ic_aux.o:	../../../h/em_mnem.h
+ic_aux.o:	../../../h/em_pseu.h
+ic_aux.o:	../../../h/em_spec.h
+ic_aux.o:	../share/alloc.h
+ic_aux.o:	../share/aux.h
+ic_aux.o:	../share/debug.h
+ic_aux.o:	../share/def.h
+ic_aux.o:	../share/global.h
+ic_aux.o:	../share/types.h
+ic_aux.o:	ic.h
+ic_aux.o:	ic_aux.h
+ic_aux.o:	ic_io.h
+ic_aux.o:	ic_lookup.h
+ic_io.o:	../../../h/em_pseu.h
+ic_io.o:	../../../h/em_spec.h
+ic_io.o:	../share/alloc.h
+ic_io.o:	../share/debug.h
+ic_io.o:	../share/types.h
+ic_io.o:	ic.h
+ic_io.o:	ic_io.h
+ic_io.o:	ic_lookup.h
+ic_lib.o:	../../../h/em_mes.h
+ic_lib.o:	../../../h/em_pseu.h
+ic_lib.o:	../../../h/em_spec.h
+ic_lib.o:	../share/debug.h
+ic_lib.o:	../share/files.h
+ic_lib.o:	../share/global.h
+ic_lib.o:	../share/types.h
+ic_lib.o:	ic.h
+ic_lib.o:	ic_io.h
+ic_lib.o:	ic_lib.h
+ic_lib.o:	ic_lookup.h
+ic_lookup.o:	../../../h/em_spec.h
+ic_lookup.o:	../share/alloc.h
+ic_lookup.o:	../share/debug.h
+ic_lookup.o:	../share/map.h
+ic_lookup.o:	../share/types.h
+ic_lookup.o:	ic.h
+ic_lookup.o:	ic_lookup.h

util/ego/ic/ic.c

@@ -0,0 +1,520 @@
+/* I N T E R M E D I A T E   C O D E
+ *
+ * I C . C
+ */
+
+#include <stdio.h>
+#include "../share/types.h"
+#include "../share/debug.h"
+#include "../share/def.h"
+#include "../share/map.h"
+#include "../../../h/em_spec.h"
+#include "../../../h/em_pseu.h"
+#include "../../../h/em_flag.h"
+#include "../../../h/em_mes.h"
+#include "ic_lookup.h"
+#include "ic.h"
+#include "ic_aux.h"
+#include "ic_io.h"
+#include "ic_lib.h"
+#include "../share/alloc.h"
+#include "../share/global.h"
+#include "../share/files.h"
+#include "../share/put.h"
+#include "../share/aux.h"
+
+
+/* Global variables */
+
+
+dblock_p	db;
+dblock_p	curhol = (dblock_p) 0;	/* hol block in current scope */
+dblock_p	ldblock;	/* last dblock  */
+proc_p		lproc;		/* last proc    */
+short		tabval;		/* used by table1, table2 and table3 */
+offset		tabval2;
+char		string[IDL+1];
+line_p		firstline;	/* first line of current procedure */
+line_p		lastline;	/* last line read */
+int		labelcount;	/* # labels in current procedure */
+short		fragm_type = DUNKNOWN; /* fragm. type: DCON, DROM or DUNKNOWN */
+short		fragm_nr = 0;	/* fragment number */
+obj_id		lastoid = 0;
+proc_id		lastpid = 0;
+dblock_id	lastdid = 0;
+lab_id		lastlid = 0;
+
+offset 		mespar = UNKNOWN_SIZE;
+		/* argumument of ps_par message of current procedure */
+
+
+extern		process_lines();
+extern int	readline();
+extern line_p	readoperand();
+extern line_p	inpseudo();
+
+
+main(argc,argv)
+	int argc;
+	char *argv[];
+{
+	/* The input files must be legal EM Compact
+	 * Assembly Language files, as produced by the EM Peephole
+	 * Optimizer.
+	 * Their file names are passed as arguments.
+	 * The output consists of the files:
+	 *  - lfile: the EM code in Intermediate Code format
+	 *  - dfile: the data block table file
+	 *  - pfile: the proc table file
+	 *  - pdump: the names of all procedures
+	 *  - ddump: the names of all data blocks
+	 */
+
+	FILE  *lfile, *dfile, *pfile, *pdump, *ddump;
+
+	lfile = openfile(lname2,"w");
+	pdump = openfile(argv[1],"w");
+	ddump = openfile(argv[2],"w");
+	while (next_file(argc,argv) != NULL) {
+		/* Read all EM input files, process the code
+		 * and concatenate all output.
+		 */
+		process_lines(lfile);
+		dump_procnames(prochash,NPROCHASH,pdump);
+		dump_dblocknames(symhash,NSYMHASH,ddump);
+		/* Save the names of all procedures that were
+		 * first come accross in this file.
+		 */
+		cleanprocs(prochash,NPROCHASH,PF_EXTERNAL);
+		cleandblocks(symhash,NSYMHASH,DF_EXTERNAL);
+		/* Make all procedure names that were internal
+		 * in this input file invisible.
+		 */
+	}
+	fclose(lfile);
+	fclose(pdump);
+	fclose(ddump);
+
+
+	/* remove the remainder of the hashing tables */
+	cleanprocs(prochash,NPROCHASH,0);
+	cleandblocks(symhash,NSYMHASH,0);
+	/* Now write the datablock table and the proctable */
+	dfile = openfile(dname2,"w");
+	putdtable(fdblock, dfile);
+	pfile = openfile(pname2,"w");
+	putptable(fproc, pfile,FALSE);
+}
+
+
+
+/* Value returned by readline */
+
+#define NORMAL		0
+#define WITH_OPERAND	1
+#define EOFILE		2
+#define PRO_INSTR	3
+#define END_INSTR	4
+#define DELETED_INSTR	5
+
+
+STATIC add_end()
+{
+	/* Add an end-pseudo to the current instruction list */
+
+	lastline->l_next = newline(OPNO);
+	lastline = lastline->l_next;
+	lastline->l_instr = ps_end;
+}
+
+
+process_lines(fout)
+	FILE *fout;
+{
+	line_p lnp;
+	short   instr;
+	bool   eof;
+
+	/* Read and process the code contained in the current file,
+	 * on a per procedure basis.
+	 * On the fly, fragments are formed. Recall that two
+	 * successive CON pseudos are allocated consecutively
+	 * in a single fragment, unless these CON pseudos are
+	 * separated in the assembly language program by one
+	 * of: ROM, BSS, HOL and END (and of course EndOfFile).
+	 * The same is true for ROM pseudos.
+	 * We keep track of a fragment type (DROM after a ROM
+	 * pseudo, DCON after a CON and DUNKNOWN after a HOL,
+	 * BSS, END or EndOfFile) and a fragment number (which
+	 * is incremented every time we enter a new fragment).
+	 * Every data block is assigned such a number
+	 * when we come accross its defining occurrence.
+	 */
+
+	eof = FALSE;
+	firstline = (line_p) 0;
+	lastline = (line_p) 0;
+	while (!eof) {
+		linecount++;	/* for error messages */
+		switch(readline(&instr, &lnp)) {
+			/* read one line, see what kind it is */
+			case WITH_OPERAND:
+				/* instruction with operand, e.g. LOL 10 */
+				lnp = readoperand(instr);
+				lnp->l_instr = instr;
+				/* Fall through! */
+			case NORMAL:
+				VL(lnp);
+				if (lastline != (line_p) 0) {
+					lastline->l_next = lnp;
+				}
+				lastline = lnp;
+				break;
+			case EOFILE:
+				eof = TRUE;
+				fragm_type = DUNKNOWN;
+				if (firstline != (line_p) 0) {
+					add_end();
+					putlines(firstline,fout);
+					firstline = (line_p) 0;
+				}
+				break;
+			case PRO_INSTR:
+				VL(lnp);
+				labelcount = 0;
+				if (firstline != lnp) {
+					/* If PRO is not the first
+					 * instruction:
+					 */
+					add_end();
+					putlines(firstline,fout);
+					firstline = lnp;
+				}
+				lastline = lnp;
+				break;
+			case END_INSTR:
+				curproc->p_nrformals = mespar;
+				mespar = UNKNOWN_SIZE;
+				assert(lastline != (line_p) 0);
+				lastline->l_next = lnp;
+				putlines(firstline,fout);
+				/* write and delete code */
+				firstline = (line_p) 0;
+				lastline = (line_p) 0;
+				cleaninstrlabs();
+				/* scope of instruction labels ends here,
+				 * so forget about them.
+				 */
+				fragm_type = DUNKNOWN;
+				break;
+			case DELETED_INSTR:
+				/* EXP, INA etc. are deleted */
+				break;
+			default:
+				error("illegal readline");
+		}
+	}
+}
+
+
+
+int readline(instr_out, lnp_out)
+	short  *instr_out;
+	line_p *lnp_out;
+{
+	register line_p lnp;
+	short n;
+
+	/* Read one line. If it is a normal EM instruction without
+	 * operand, we can allocate a line struct for it here.
+	 * If so, return a pointer to it via lnp_out, else just
+	 * return the instruction code via instr_out.
+	 */
+
+	VA((short *) instr_out);
+	VA((short *) lnp_out);
+	switch(table1()) {
+		/* table1 sets string, tabval or tabval2 and
+		 * returns an indication of what was read.
+		 */
+		case ATEOF:
+			return EOFILE;
+		case INST:
+			*instr_out = tabval; /* instruction code */
+			return WITH_OPERAND;
+		case DLBX:
+			/* data label defining occurrence, precedes
+			 * a data block.
+			 */
+			db = block_of_lab(string);
+			/* global variable, used by inpseudo */
+			lnp = newline(OPSHORT);
+			SHORT(lnp) = (short) db->d_id;
+			lnp->l_instr = ps_sym;
+			*lnp_out = lnp;
+			if (firstline == (line_p) 0) {
+				firstline = lnp;
+				/* only a pseudo (e.g. PRO) or data label
+				 * can be the first instruction.
+				 */
+			}
+			return NORMAL;
+		case ILBX:
+			/* instruction label defining occurrence */
+			labelcount++;
+			lnp = newline(OPINSTRLAB);
+			lnp->l_instr = op_lab;
+			INSTRLAB(lnp) = instr_lab(tabval);
+			*lnp_out = lnp;
+			return NORMAL;
+		case PSEU:
+			n = tabval;
+			lnp = inpseudo(n); /* read a pseudo */
+			if (lnp == (line_p) 0)  return DELETED_INSTR;
+			*lnp_out = lnp;
+			lnp->l_instr = n;
+			if (firstline == (line_p) 0) {
+				firstline = lnp;
+				/* only a pseudo (e.g. PRO) or data label
+				 * can be the first instruction.
+				 */
+			}
+			if (n == ps_end)  return END_INSTR;
+			if (n == ps_pro)  return PRO_INSTR;
+			return NORMAL;
+	}
+	/* NOTREACHED */
+}
+
+
+line_p readoperand(instr)
+	short instr;
+{
+	/* Read the operand of the given instruction.
+	 * Create a line struct and return a pointer to it.
+	 */
+
+
+	register line_p lnp;
+	short flag;
+
+	VI(instr);
+	flag = em_flag[ instr - sp_fmnem] & EM_PAR;
+	if (flag == PAR_NO) {
+		return (newline(OPNO));
+	}
+	switch(table2()) {
+		case sp_cend:
+			return(newline(OPNO));
+		case CSTX1:
+			/* constant */
+			/* If the instruction has the address
+			 * of an external variable as argument,
+			 * the constant must be regarded as an
+			 * offset in the current hol block,
+			 * so an object must be created.
+			 * Similarly, the instruction may have
+			 * an instruction label as argument.
+			 */
+			switch(flag) {
+			   case PAR_G:
+				lnp = newline(OPOBJECT);
+				OBJ(lnp) =
+				  object((char *) 0,(offset) tabval,
+					 opr_size(instr));
+				break;
+			   case PAR_B:
+				lnp = newline(OPINSTRLAB);
+				INSTRLAB(lnp) = instr_lab(tabval);
+				break;
+			   default:
+				lnp = newline(OPSHORT);
+				SHORT(lnp) = tabval;
+				break;
+			}
+			break;
+#ifdef LONGOFF
+		case CSTX2:
+			/* double constant */
+			lnp = newline(OPOFFSET);
+			OFFSET(lnp) = tabval2;
+			break;
+#endif
+		case ILBX:
+			/* applied occurrence instruction label */
+			lnp = newline(OPINSTRLAB);
+			INSTRLAB(lnp) = instr_lab(tabval);
+			break;
+		case DLBX:
+			/* applied occurrence data label */
+			lnp = newline(OPOBJECT);
+			OBJ(lnp) = object(string, (offset) 0,
+					opr_size(instr) );
+			break;
+		case VALX1:
+			lnp = newline(OPOBJECT);
+			OBJ(lnp) = object(string, (offset) tabval,
+					opr_size(instr) );
+			break;
+#ifdef LONGOFF
+		case VALX2:
+			lnp = newline(OPOBJECT);
+			OBJ(lnp) = object(string,tabval2,
+					opr_size(instr) );
+			break;
+#endif
+		case sp_pnam:
+			lnp = newline(OPPROC);
+			PROC(lnp) = proclookup(string,OCCURRING);
+			VP(PROC(lnp));
+			break;
+		default:
+			assert(FALSE);
+	}
+	return lnp;
+}
+
+
+
+line_p inpseudo(n)
+	short n;
+{
+	int m;
+	line_p lnp;
+	byte pseu;
+	short nlast;
+
+	/* Read the (remainder of) a pseudo instruction, the instruction
+	 * code of which is n. The END pseudo may be deleted (return 0).
+	 * The pseudos INA, EXA, INP and EXP (visibility pseudos) must
+	 * also be deleted, although the effects they have on the
+	 * visibility of global names and procedure names must first
+	 * be recorded in the datablock or procedure table.
+	 */
+
+
+	switch(n) {
+		case ps_hol:
+		case ps_bss:
+		case ps_rom:
+		case ps_con:
+			if (lastline == (line_p) 0 || !is_datalabel(lastline)) {
+				if (n == ps_hol) {
+				   /* A HOL need not be preceded
+				   * by a label.
+				   */
+				   curhol = db = block_of_lab((char *) 0);
+				} else {
+				   assert(lastline != (line_p) 0);
+				   nlast = INSTR(lastline);
+				   if (n == nlast &&
+					(n == ps_rom || n == ps_con)) {
+					/* Two successive roms/cons are
+					 * combined into one data block
+					 * if the second is not preceded by
+					 * a data label.
+					 */
+					lnp = arglist(0);
+					pseu = (byte) (n == ps_rom?DROM:DCON);
+					combine(db,lastline,lnp,pseu);
+					oldline(lnp);
+					return (line_p) 0;
+				   } else {
+				   	error("datablock without label");
+				   }
+				}
+			}
+			VD(db);
+			m = (n == ps_hol || n == ps_bss ? 3 : 0);
+			lnp = arglist(m);
+			/* Read the arguments, 3 for hol or bss and a list
+			 * of undetermined length for rom and con.
+			 */
+			dblockdef(db,n,lnp);
+			/* Fill in d_pseudo, d_size and d_values fields of db */
+			if (fragm_type != db->d_pseudo & BMASK) {
+				/* Keep track of fragment numbers,
+				 * enter a new fragment.
+				 */
+				fragm_nr++;
+				switch(db->d_pseudo) {
+					case DCON:
+					case DROM:
+						fragm_type = db->d_pseudo;
+						break;
+					default:
+						fragm_type = DUNKNOWN;
+						break;
+				}
+			}
+			db->d_fragmnr = fragm_nr;
+			return lnp;
+		case ps_ina:
+			getsym(DEFINING);
+			/* Read and lookup a symbol. As this must be
+			 * the first occurrence of the symbol and we
+			 * say it's a defining occurrence, getsym will
+			 * automatically make it internal (according to
+			 * the EM visibility rules).
+			 * The result (a dblock pointer) is voided.
+			 */
+			return (line_p) 0;
+		case ps_inp:
+			getproc(DEFINING);  /* same idea */
+			return (line_p) 0;
+		case ps_exa:
+			getsym(OCCURRING);
+			return (line_p) 0;
+		case ps_exp:
+			getproc(OCCURRING);
+			return (line_p) 0;
+		case ps_pro:
+			curproc = getproc(DEFINING);
+			/* This is a real defining occurrence of a proc */
+			curproc->p_localbytes = get_off();
+			curproc->p_flags1 |= PF_BODYSEEN;
+			/* Record the fact that we came accross
+			 * the body of this procedure.
+			 */
+			lnp = newline(OPPROC);
+			PROC(lnp) = curproc;
+			lnp->l_instr = (byte) ps_pro;
+			return lnp;
+		case ps_end:
+			curproc->p_nrlabels = labelcount;
+			lnp = newline(OPNO);
+			get_off();
+			/* Void # localbytes, which we already know
+			 * from the PRO instruction.
+			 */
+			return lnp;
+		case ps_mes:
+			lnp = arglist(0);
+			switch((int) aoff(ARG(lnp),0)) {
+			case ms_err:
+				error("ms_err encountered");
+			case ms_opt:
+				error("ms_opt encountered");
+			case ms_emx:
+				ws = aoff(ARG(lnp),1);
+				ps = aoff(ARG(lnp),2);
+				break;
+			case ms_ext:
+				/* this message was already processed
+				 * by the lib package
+				 */
+			case ms_src:
+				/* Don't bother about linecounts */
+				oldline(lnp);
+				return (line_p) 0;
+			case ms_par:
+				mespar = aoff(ARG(lnp),1);
+				/* #bytes of parameters of current proc */
+				break;
+			}
+			return lnp;
+		default:
+			assert(FALSE);
+	}
+	/* NOTREACHED */
+}

util/ego/ic/ic.h

@@ -0,0 +1,42 @@
+/*  I N T E R M E D I A T E   C O D E
+ *
+ *  G L O B A L   C O N S T A N T S  &  V A R I A B L E S
+ */
+
+/* macros used by ic_lib.c and ic_io.c: */
+
+#define ARCHIVE	0
+#define NO_ARCHIVE 1
+
+
+/*
+ * The next constants are close to sp_cend for fast switches
+ */
+#define INST	256	/* instruction:		number in tabval */
+#define PSEU	257	/* pseudo:		number in tabval */
+#define ILBX	258	/* label:		number in tabval */
+#define DLBX	259	/* symbol:		name in string[] */
+#define CSTX1	260	/* short constant:	stored in tabval */
+#define CSTX2	261	/* offset:		value in tabval2 */
+#define VALX1	262	/* symbol+short:	in string[] and tabval */
+#define VALX2	263	/* symbol+offset:	in string[] and tabval2 */
+#define ATEOF	264	/* bumped into end of file */
+
+/* Global variables */
+
+extern dblock_p	db;
+extern dblock_p	curhol;		/* hol block in current scope */
+extern dblock_p		ldblock;	/* last dblock processed so  far   */
+extern proc_p		lproc;		/* last proc processed so far  */
+extern short		tabval;		/* used by table1, table2 and table3 */
+extern offset		tabval2;
+extern char		string[];
+extern line_p		lastline;	/* last line read */
+extern int		labelcount;	/* # labels in current procedure */
+extern obj_id		lastoid;	/* last object identifier used	*/
+extern proc_id		lastpid;	/* last proc   identifier used  */
+extern lab_id		lastlid;	/* last label  identifier used	*/
+extern dblock_id	lastdid;	/* last dblock identifier used	*/
+
+extern byte em_flag[];
+

util/ego/ic/ic_aux.c

@@ -0,0 +1,459 @@
+/*  I N T E R M E D I A T E   C O D E
+ *
+ *  I C _ A U X . C
+ */
+
+
+
+#include "../share/types.h"
+#include "../share/global.h"
+#include "../share/debug.h"
+#include "../share/def.h"
+#include "../share/aux.h"
+#include "../../../h/em_pseu.h"
+#include "../../../h/em_spec.h"
+#include "../../../h/em_mnem.h"
+#include "ic.h"
+#include "ic_io.h"
+#include "ic_lookup.h"
+#include "../share/alloc.h"
+#include "ic_aux.h"
+
+
+
+/* opr_size */
+
+offset opr_size(instr)
+	short instr;
+{
+	switch(instr) {
+		case op_loe:
+		case op_ste:
+		case op_ine:
+		case op_dee:
+		case op_zre:
+			return (offset) ws;
+		case op_lde:
+		case op_sde:
+			return (offset) 2*ws;
+		case op_lae:
+		case op_fil:
+			return (offset) UNKNOWN_SIZE;
+		default:
+			error("illegal operand of opr_size: %d", instr);
+	}
+	/* NOTREACHED */
+}
+
+
+
+/* dblockdef */
+
+STATIC offset argsize(arg)
+	arg_p arg;
+{
+	/* Compute the size (in bytes) that the given initializer
+	 * will occupy.
+	 */
+
+	offset s;
+	argb_p argb;
+
+	switch(arg->a_type) {
+		case ARGOFF:
+			/* See if value fits in a short */
+			if ((short) arg->a_a.a_offset == arg->a_a.a_offset) {
+				return ws;
+			} else {
+				return 2*ws;
+			}
+		case ARGINSTRLAB:
+		case ARGOBJECT:
+		case ARGPROC:
+			return ps;  /* pointer size */
+		case ARGSTRING:
+			/* strings are partitioned into pieces */
+			s = 0;
+			for (argb = &arg->a_a.a_string; argb != (argb_p) 0;
+			   argb = argb->ab_next) {
+				s += argb->ab_index;
+			}
+			return s;
+		case ARGICN:
+		case ARGUCN:
+		case ARGFCN:
+			return arg->a_a.a_con.ac_length;
+		default:
+			assert(FALSE);
+		}
+		/* NOTREACHED */
+}
+
+
+STATIC offset blocksize(pseudo,args)
+	byte  pseudo;
+	arg_p args;
+{
+	/* Determine the number of bytes of a datablock */
+
+	arg_p	arg;
+	offset	sum;
+
+	switch(pseudo) {
+	   case DHOL:
+	   case DBSS:
+		if (args->a_type != ARGOFF) {
+			error("offset expected");
+		}
+		return args->a_a.a_offset;
+	   case DCON:
+	   case DROM:
+		sum = 0;
+		for (arg = args; arg != (arg_p) 0; arg = arg->a_next) {
+			/* Add the sizes of all initializers */
+			sum += argsize(arg);
+		}
+		return sum;
+	   default:
+		assert(FALSE);
+	}
+	/* NOTREACHED */
+}
+
+
+STATIC arg_p copy_arg(arg)
+	arg_p arg;
+{
+	/* Copy one argument */
+
+	arg_p new;
+
+	assert(arg->a_type == ARGOFF);
+	new = newarg(ARGOFF);
+	new->a_a.a_offset = arg->a_a.a_offset;
+	return new;
+}
+
+
+
+STATIC arg_p copy_rom(args)
+	arg_p args;
+{
+	/* Make a copy of the values of a rom,
+	 * provided that the rom contains only integer values,
+	 */
+
+	arg_p arg, arg2, argh;
+
+	for (arg = args; arg != (arg_p) 0; arg = arg->a_next) {
+		if (arg->a_type != ARGOFF) {
+			return (arg_p) 0;
+		}
+	}
+	/* Now make the copy */
+	arg2 = argh = copy_arg(args);
+	for (arg = args->a_next; arg != (arg_p) 0; arg = arg->a_next) {
+		arg2->a_next = copy_arg(arg);
+		arg2 = arg2->a_next;
+	}
+	return argh;
+}
+
+
+
+dblockdef(db,n,lnp)
+	dblock_p db;
+	int	 n;
+	line_p	 lnp;
+{
+	/* Process a data block defining occurrence */
+
+	byte m;
+
+	switch(n) {
+		case ps_hol:
+			m = DHOL;
+			break;
+		case ps_bss:
+			m = DBSS;
+			break;
+		case ps_con:
+			m = DCON;
+			break;
+		case ps_rom:
+			m = DROM;
+			break;
+		default:
+			assert(FALSE);
+	}
+	db->d_pseudo = m;
+	db->d_size = blocksize(m, ARG(lnp));
+	if (m == DROM) {
+		/* We keep the values of a rom block in the data block
+		 * table if the values consist of integers only.
+		 */
+		db->d_values = copy_rom(ARG(lnp));
+	}
+}
+
+
+
+/* combine */
+
+combine(db,l1,l2,pseu)
+	dblock_p db;
+	line_p   l1,l2;
+	byte pseu;
+{
+	/* Combine two successive ROMs/CONs (without a data label
+	 * in between into a single ROM. E.g.:
+	 *    xyz
+	 *     rom 3,6,9,12
+	 *     rom 7,0,2
+	 * is changed into:
+	 *    xyz
+	 *     rom 3,6,9,12,7,0,2
+	 */
+
+	arg_p v;
+
+	db->d_size += blocksize(pseu,ARG(l2));
+	/* db is the data block that was already assigned to the
+	 * first rom/con. The second one is not assigned a new
+	 * data block of course, as the two are combined into
+	 * one instruction.
+	 */
+	if (pseu == DROM && db->d_values != (arg_p) 0) {
+		/* The values contained in a ROM are only copied
+		 * to the data block if they may be useful to us
+		 * (e.g. they certainly may not be strings). In our
+		 * case it means that both ROMs must have useful
+		 * arguments.
+		 */
+		for (v = db->d_values; v->a_next != (arg_p) 0; v = v->a_next);
+		/* The first rom contained useful arguments. v now points to
+		 * its last argument. Append the arguments of the second
+		 * rom to this list. If the second rom has arguments that are
+		 * not useful, throw away the entire list (we want to copy
+		 * everything or nothing).
+		 */
+		if ((v->a_next = copy_rom(ARG(l2))) == (arg_p) 0) {
+			oldargs(db->d_values);
+			db->d_values = (arg_p) 0;
+		}
+	}
+	for (v = ARG(l1); v->a_next != (arg_p) 0; v = v->a_next);
+	/* combine the arguments of both instructions. */
+	v->a_next = ARG(l2);
+	ARG(l2) = (arg_p) 0;
+}
+
+
+
+/* arglist */
+
+STATIC arg_string(length,abp)
+	offset  length;
+	register argb_p abp;
+{
+
+	while (length--) {
+		if (abp->ab_index == NARGBYTES)
+			abp = abp->ab_next = newargb();
+		abp->ab_contents[abp->ab_index++] = readchar();
+	}
+}
+
+
+line_p arglist(n)
+	int n;
+{
+	line_p	lnp;
+	register arg_p ap,*app;
+	bool moretocome;
+	offset length;
+
+
+	/*
+	 * creates an arglist with n elements
+	 * if n == 0 the arglist is variable and terminated by sp_cend
+	 */
+
+	lnp = newline(OPLIST);
+	app = &ARG(lnp);
+	moretocome = TRUE;
+	do {
+		switch(table2()) {
+		default:
+			error("unknown byte in arglist");
+		case CSTX1:
+			tabval2 = (offset) tabval;
+		case CSTX2:
+			*app = ap = newarg(ARGOFF);
+			ap->a_a.a_offset = tabval2;
+			app = &ap->a_next;
+			break;
+		case ILBX:
+			*app = ap = newarg(ARGINSTRLAB);
+			ap->a_a.a_instrlab = instr_lab((short) tabval);
+			app = &ap->a_next;
+			break;
+		case DLBX:
+			*app = ap = newarg(ARGOBJECT);
+			ap->a_a.a_obj = object(string,(offset) 0, (offset) 0);
+			/* The size of the object is unknown */
+			app = &ap->a_next;
+			break;
+		case sp_pnam:
+			*app = ap = newarg(ARGPROC);
+			ap->a_a.a_proc = proclookup(string,OCCURRING);
+			app = &ap->a_next;
+			break;
+		case VALX1:
+			tabval2 = (offset) tabval;
+		case VALX2:
+			*app = ap = newarg(ARGOBJECT);
+			ap->a_a.a_obj = object(string, tabval2, (offset) 0);
+			app = &ap->a_next;
+			break;
+		case sp_scon:
+			*app = ap = newarg(ARGSTRING);
+			length = get_off();
+			arg_string(length,&ap->a_a.a_string);
+			app = &ap->a_next;
+			break;
+		case sp_icon:
+			*app = ap = newarg(ARGICN);
+			goto casecon;
+		case sp_ucon:
+			*app = ap = newarg(ARGUCN);
+			goto casecon;
+		case sp_fcon:
+			*app = ap = newarg(ARGFCN);
+		casecon:
+			length = get_int();
+			ap->a_a.a_con.ac_length = (short) length;
+			arg_string(get_off(),&ap->a_a.a_con.ac_con);
+			app = &ap->a_next;
+			break;
+		case sp_cend:
+			moretocome = FALSE;
+		}
+		if (n && (--n) == 0)
+			moretocome = FALSE;
+	} while (moretocome);
+	return(lnp);
+}
+
+
+
+/* is_datalabel */
+
+bool is_datalabel(l)
+	line_p l;
+{
+	VL(l);
+	return (l->l_instr == (byte) ps_sym);
+}
+
+
+
+/* block_of_lab */
+
+dblock_p block_of_lab(ident)
+	char *ident;
+{
+	dblock_p dbl;
+
+	/* Find the datablock with the given name.
+	 * Used for defining occurrences.
+	 */
+
+	dbl = symlookup(ident,DEFINING);
+	VD(dbl);
+	if (dbl->d_pseudo != DUNKNOWN) {
+		error("identifier redeclared");
+	}
+	return dbl;
+}
+
+
+
+/* object */
+
+STATIC obj_p make_object(dbl,off,size)
+	dblock_p dbl;
+	offset   off;
+	offset   size;
+{
+	/* Allocate an obj struct with the given attributes
+	 * (if it did not exist already).
+	 * Return a pointer to the found or newly created object struct.
+	 */
+
+	obj_p obj, prev, new;
+
+	/* See if the object was already present in the object list
+	 *  of the given datablock. If it is not yet present, find
+	 * the right place to insert the new object. Note that
+	 * the objects are sorted by offset.
+	 */
+	prev = (obj_p) 0;
+	for (obj = dbl->d_objlist; obj != (obj_p) 0; obj = obj->o_next) {
+		if (obj->o_off >= off) {
+			break;
+		}
+		prev = obj;
+	}
+	/* Note that the data block may contain several objects
+	 * with the required offset; we also want the size to
+	 * be the right one.
+	 */
+	while (obj != (obj_p) 0 && obj->o_off == off) {
+		if (obj->o_size == UNKNOWN_SIZE) {
+			obj->o_size = size;
+			return obj;
+		} else {
+			if (size == UNKNOWN_SIZE || obj->o_size == size) {
+				return obj;
+				/* This is the right one */
+			} else {
+				prev = obj;
+				obj = obj->o_next;
+			}
+		}
+	}
+	/* Allocate a new object */
+	new = newobject();
+	new->o_id     = ++lastoid;	/* create a unique object id */
+	new->o_off    = off;
+	new->o_size   = size;
+	new->o_dblock = dbl;
+	/* Insert the new object */
+	if (prev == (obj_p) 0) {
+		dbl->d_objlist = new;
+	} else {
+		prev->o_next = new;
+	}
+	new->o_next = obj;
+	return new;
+}
+
+
+
+obj_p object(ident,off,size)
+	char *ident;
+	offset off;
+	offset size;
+{
+	dblock_p dbl;
+
+	/* Create an object struct (if it did not yet exist)
+	 * for the object with the given size and offset
+	 * within the datablock of the given name.
+	 */
+
+	dbl = (ident == (char *) 0 ? curhol : symlookup(ident, OCCURRING));
+	VD(dbl);
+	return(make_object(dbl,off,size));
+}

util/ego/ic/ic_aux.h

@@ -0,0 +1,39 @@
+/*  I N T E R M E D I A T E   C O D E
+ *
+ *  A U X I L I A R Y   R O U T I N E S
+ */
+
+
+
+extern offset	opr_size();		/* ( short instr )
+					 * size of operand of given instruction.
+					 * The operand is an object , so the
+					 * instruction can be loe, zre etc..
+					 */
+extern		dblockdef();		/* (dblock_p db, int n, line_p lnp)
+					 * Fill in d_pseudo, d_size and
+					 * d_values fields of db.
+					 */
+extern		combine();		/* (dblock_p db;line_p l1,l2;byte pseu)
+					 * Combine two successive ROMs or CONs
+					 * (with no data label in between)
+					 * into one ROM or CON.
+					 */
+extern line_p	arglist();		/* ( int m)
+					 * Read a list of m arguments. If m
+					 * is 0, then the list is of
+					 * undetermined length; it is
+					 * then terminated by a cend symbol.
+					 */
+extern bool	is_datalabel();		/* ( line_p l)
+					 * TRUE if l is a data label defining
+					 * occurrence (i.e. its l_instr
+					 * field is ps_sym).
+					 */
+extern dblock_p	block_of_lab();		/* (char *ident)
+					 * Find the datablock with
+					 * the given name.
+					 */
+extern obj_p	object();		/* (char *ident,offset off,short size)
+					 * Create an object struct.
+					 */

util/ego/ic/ic_io.c

@@ -0,0 +1,204 @@
+/*  I N T E R M E D I A T E   C O D E
+ *
+ *  I C _ I O . C
+ */
+
+
+
+#include <stdio.h>
+#include "../share/types.h"
+#include "../share/debug.h"
+#include "../../../h/em_pseu.h"
+#include "../../../h/em_spec.h"
+#include "../../../h/arch.h"
+#include "ic.h"
+#include "ic_lookup.h"
+#include "../share/alloc.h"
+#include "ic_io.h"
+
+
+STATIC short libstate;
+STATIC long  bytecnt;
+
+STATIC FILE *infile;  /* The current EM input file */
+
+STATIC int readbyte()
+{
+	if (libstate == ARCHIVE && bytecnt-- == 0L) {
+		/* If we're reading from an archive file, we'll
+		 * have to count the number of characters read,
+		 * to know where the current module ends.
+		 */
+		return EOF;
+	}
+	return getc(infile);
+}
+
+
+
+
+short readshort() {
+	register int l_byte, h_byte;
+
+	l_byte = readbyte();
+	h_byte = readbyte();
+	if ( h_byte>=128 ) h_byte -= 256 ;
+	return l_byte | (h_byte*256) ;
+}
+
+#ifdef LONGOFF
+offset readoffset() {
+	register long l;
+	register int h_byte;
+
+	l = readbyte();
+	l |= ((unsigned) readbyte())*256 ;
+	l |= readbyte()*256L*256L ;
+	h_byte = readbyte() ;
+	if ( h_byte>=128 ) h_byte -= 256 ;
+	return l | (h_byte*256L*256*256L) ;
+}
+#endif
+
+
+short get_int() {
+
+	switch(table2()) {
+	default: error("int expected");
+	case CSTX1:
+		return(tabval);
+	}
+}
+
+char readchar()
+{
+	return(readbyte());
+}
+
+
+
+offset get_off() {
+
+	switch (table2()) {
+	default: error("offset expected");
+	case CSTX1:
+		return((offset) tabval);
+#ifdef LONGOFF
+	case CSTX2:
+		return(tabval2);
+#endif
+	}
+}
+
+STATIC make_string(n) int n; {
+	register char *s;
+	extern char *sprintf();
+	
+	s=sprintf(string,".%u",n);
+	assert(s == string);
+}
+
+STATIC inident() {
+	register n;
+	register char *p = string;
+	register c;
+
+	n = get_int();
+	while (n--) {
+		c = readbyte();
+		if (p<&string[IDL])
+			*p++ = c;
+	}
+	*p++ = 0;
+}
+
+int table3(n) int n; {
+
+	switch (n) {
+	case sp_ilb1:	tabval = readbyte(); return(ILBX);
+	case sp_ilb2:	tabval = readshort(); return(ILBX);
+	case sp_dlb1:	make_string(readbyte()); return(DLBX);
+	case sp_dlb2:	make_string(readshort()); return(DLBX);
+	case sp_dnam:	inident(); return(DLBX);
+	case sp_pnam:	inident(); return(n);
+	case sp_cst2:	tabval = readshort(); return(CSTX1);
+#ifdef LONGOFF
+	case sp_cst4:	tabval2 = readoffset(); return(CSTX2);
+#endif
+	case sp_doff:	if (table2()!=DLBX) error("symbol expected");
+			switch(table2()) {
+			default:	error("offset expected");
+			case CSTX1:		return(VALX1);
+#ifdef LONGOFF
+			case CSTX2:		return(VALX2);
+#endif
+			}
+	default:	return(n);
+	}
+}
+
+int table1() {
+	register n;
+
+	n = readbyte();
+	if (n == EOF)
+		return(ATEOF);
+	if ((n <= sp_lmnem) && (n >= sp_fmnem)) {
+		tabval = n;
+		return(INST);
+	}
+	if ((n <= sp_lpseu) && (n >= sp_fpseu)) {
+		tabval = n;
+		return(PSEU);
+	}
+	if ((n < sp_filb0 + sp_nilb0) && (n >= sp_filb0)) {
+		tabval = n - sp_filb0;
+		return(ILBX);
+	}
+	return(table3(n));
+}
+
+int table2() {
+	register n;
+
+	n = readbyte();
+	if ((n < sp_fcst0 + sp_ncst0) && (n >= sp_fcst0)) {
+		tabval = n - sp_zcst0;
+		return(CSTX1);
+	}
+	return(table3(n));
+}
+
+
+
+
+file_init(f,state,length)
+	FILE *f;
+	short state;
+	long  length;
+{
+	short n;
+
+	infile = f;
+	libstate = state;
+	bytecnt = length;
+	linecount = 0;
+	n = readshort();
+	if (n != (short) sp_magic) {
+		error("wrong magic number: %d", n);
+	}
+}
+
+
+
+arch_init(arch)
+	FILE *arch;
+{
+	short n;
+
+	infile = arch;
+	n = readshort();
+	if (n != ARMAG) {
+		error("wrong archive magic number: %d",n);
+	}
+}

util/ego/ic/ic_io.h

@@ -0,0 +1,34 @@
+/*   I N T E R M E D I A T E   C O D E
+ *
+ *    L O W   L E V E L   I / O   R O U T I N E S
+ */
+
+
+extern int	table1();		/* (  )
+					 * Read an instruction from the
+					 * Compact Assembly Language input
+					 * file (in 'neutral state').
+					 */
+extern int	table2();		/* ( )
+					 * Read an instruction argument.
+					 */
+extern int	table3();		/* ( int )
+					 * Read 'Common Table' item.
+					 */
+extern short	get_int();		/* ( )				*/
+extern offset	get_off();		/* ( )				*/
+extern char	readchar();		/* ( )				*/
+extern		file_init();		/* (FILE *f, short state, long length)
+					 * Input file initialization. All
+					 * following read operations will read
+					 * from the given file f. Also checks
+					 * the magic number and sets global
+					 * variable 'linecount' to 0.
+					 * If the state is ARCHIVE, length
+					 * specifies the length of the module.
+					 */
+extern		arch_init();		/* (FILE *arch)
+					 * Same as file_init,but opens an
+					 * archive file. So it checks the
+					 * magic number for archives.
+					 */

util/ego/ic/ic_lib.c

@@ -0,0 +1,274 @@
+/*  I N T E R M E D I A T E   C O D E
+ *
+ *  I C _ L I B . C
+ */
+
+
+#include <stdio.h>
+#include "../share/types.h"
+#include "../share/debug.h"
+#include "../../../h/em_spec.h"
+#include "../../../h/em_pseu.h"
+#include "../../../h/em_mes.h"
+#include "../../../h/arch.h"
+#include "ic_lookup.h"
+#include "ic.h"
+#include "ic_io.h"
+#include "../share/global.h"
+#include "../share/files.h"
+#include "ic_lib.h"
+
+
+STATIC skip_string(n)
+	offset n;
+{
+	/* Read a string of length n and void it */
+
+	while (n--) {
+		readchar();
+	}
+}
+
+
+STATIC skip_arguments()
+{
+	/* Skip the arguments of a MES pseudo. The argument
+	 * list is terminated by a sp_cend byte.
+	 */
+
+	for (;;) {
+		switch(table2()) {
+			case sp_scon:
+				get_off(); /* void */
+				/* fall through !!! */
+			case sp_icon:
+			case sp_ucon:
+			case sp_fcon:
+				get_int(); /* void */
+				skip_string(get_off());
+				break;
+			case sp_cend:
+				return;
+			default:
+				break;
+		}
+	}
+}
+
+
+
+STATIC bool proc_wanted(name)
+	char *name;
+{
+	/* See if 'name' is the name of an external procedure
+	 * that has been used before, but for which no body
+	 * has been given so far.
+	 */
+
+	proc_p p;
+
+	if (( p = proclookup(name,IMPORTING)) != (proc_p) 0 &&
+	   !(p->p_flags1 & PF_BODYSEEN)) {
+		return TRUE;
+	} else {
+		return FALSE;
+	}
+}
+
+
+
+STATIC bool data_wanted(name)
+	char *name;
+{
+	/* See if 'name' is the name of an externally visible
+	 * data block that has been used before, but for which
+	 * no defining occurrence has been given yet.
+	 */
+
+	dblock_p db;
+
+	if ((db = symlookup(name,IMPORTING)) != (dblock_p) 0 &&
+	   db->d_pseudo == DUNKNOWN) {
+		return TRUE;
+	} else {
+		return FALSE;
+	}
+}
+
+
+
+STATIC bool wanted_names()
+{
+	/* Read the names of procedures and data labels,
+	 * appearing in a 'MES ms_ext' pseudo. Those are
+	 * the names of entities that are imported by
+	 * a library module.
+	 * If any of them is wanted, return TRUE.
+	 * A name is wanted if it is the name of a procedure
+	 * or data block for which applied occurrences but
+	 * no defining occurrence has been met.
+	 */
+
+	for (;;) {
+		switch(table2()) {
+			case DLBX:
+				if (data_wanted(string)) {
+					return TRUE;
+				}
+				/* A data entity with the name
+				 * string is available.
+				 */
+				break;
+			case sp_pnam:
+				if (proc_wanted(string)) {
+					return TRUE;
+				}
+				break;
+			case sp_cend:
+				return FALSE;
+			default:
+				error("wrong argument of MES %d", ms_ext);
+		}
+	}
+}
+
+
+
+STATIC FILE *curfile = NULL;
+STATIC bool useful()
+{
+	/* Determine if any entity imported by the current
+	 * compact EM assembly file  (which will usually be
+	 * part of an archive file) is useful to us.
+	 * The file must contain (before any other non-MES line)
+	 * a 'MES ms_ext' pseudo that has as arguments the names
+	 * of the entities imported.
+	 */
+
+	for (;;) {
+		if (table1() != PSEU || tabval != ps_mes) {
+			error("cannot find MES %d in library file",ms_ext);
+		}
+		if (table2() != CSTX1) {
+			error("message number expected");
+		}
+		if (tabval == ms_ext) {
+			/* This is the one we searched */
+			return wanted_names();
+			/* Read the names of the imported entities
+			 * and check if any of them is wanted.
+			 */
+		} else {
+			skip_arguments(); /* skip remainder of this MES */
+		}
+	}
+}
+
+
+
+STATIC bool is_archive(name)
+	char *name;
+{
+	/* See if 'name' is the name of an archive file, i.e. it
+	 * should end on ".a" and should at least be three characters
+	 * long (i.e. the name ".a" is not accepted as an archive name!).
+	 */
+
+	register char *p;
+
+	for (p = name; *p; p++);
+	return (p > name+2) && (*--p == 'a') && (*--p == '.');
+}
+
+
+
+STATIC struct ar_hdr hdr;
+
+STATIC bool read_hdr()
+{
+	/* Read the header of an archive module */
+
+
+	fread(&hdr, sizeof(hdr), 1, curfile);
+	return !feof(curfile);
+}
+
+
+
+STATIC int argcnt = ARGSTART - 1;
+STATIC short arstate = NO_ARCHIVE;
+
+
+FILE *next_file(argc,argv)
+	int argc;
+	char *argv[];
+{
+	/* See if there are more EM input files. The file names
+	 * are given via argv. If a file is an archive file
+	 * it is supposed to be a library of EM compact assembly
+	 * files. A module (file) contained in this archive file
+	 * is only used if it imports at least one procedure or
+	 * datalabel for which we have not yet seen a defining
+	 * occurrence, although we have seen a used occurrence.
+	 */
+
+	 long ptr;
+
+	 for (;;) {
+		/* This loop is only exited via a return */
+		if (arstate == ARCHIVE) {
+			/* We were reading an archive file */
+			if (ftell(curfile) & 1) {
+				/* modules in an archive file always
+				 * begin on a word boundary, i.e. at
+				 * an even address.
+				 */
+				fseek(curfile,1L,1);
+			}
+			if (read_hdr()) { /* read header of next module */
+				ptr = ftell(curfile); /* file position */
+				file_init(curfile,ARCHIVE,hdr.ar_size);
+				/* tell i/o package that we're reading
+				 * an archive module of given length.
+				 */
+				if (useful()) {
+					/* re-initialize file, because 'useful'
+					 * has read some bytes too.
+					 */
+					fseek(curfile,ptr,0); /* start module */
+					file_init(curfile,ARCHIVE,hdr.ar_size);
+					return curfile;
+				} else {
+					/* skip this module */
+					fseek(curfile,
+					  ptr+hdr.ar_size,0);
+				}
+			} else {
+				/* done with this archive */
+				arstate = NO_ARCHIVE;
+			}
+		} else {
+			/* open next file, close old */
+			if (curfile != NULL) {
+				fclose(curfile);
+			}
+			argcnt++;
+			if (argcnt >= argc) {
+				/* done with all arguments */
+				return NULL;
+			}
+			filename = argv[argcnt];
+			if ((curfile = fopen(filename,"r")) == NULL) {
+				error("cannot open %s",filename);
+			}
+			if (is_archive(filename)) {
+				/* ends on '.a' */
+				arstate = ARCHIVE;
+				arch_init(curfile); /* read magic ar number */
+			} else {
+				file_init(curfile,NO_ARCHIVE,0L);
+				return curfile;
+			}
+		}
+	}
+}

util/ego/ic/ic_lib.h

@@ -0,0 +1,14 @@
+/*  I N T E R M E D I A T E   C O D E
+ *
+ *  L I B R A R Y   M A N A G E R
+ */
+
+
+extern	FILE	*next_file();	/* (int argc, char *argv[])
+				 * See if there are any more EM input files.
+				 * 'argv' contains the names of the files
+				 * that are passed as arguments to ic.
+				 * If an argument is a library (archive
+				 * file) only those modules that are useful
+				 * are used.
+				 */

util/ego/ic/ic_lookup.c

@@ -0,0 +1,405 @@
+/*  I N T E R M E D I A T E   C O D E
+ *
+ *  I C _ L O O K U P . C
+ */
+
+
+#include <stdio.h>
+#include "../share/types.h"
+#include "../share/debug.h"
+#include "../share/map.h"
+#include "../../../h/em_spec.h"
+#include "ic.h"
+#include "ic_lookup.h"
+#include "../share/alloc.h"
+
+
+sym_p symhash[NSYMHASH];
+prc_p prochash[NPROCHASH];
+num_p numhash[NNUMHASH];
+
+
+
+/* instr_lab */
+
+
+
+
+
+lab_id instr_lab(number)
+	short number;
+{
+	register num_p *npp, np;
+
+	/* In EM assembly language, a label is an unsigned number,
+	 * e.g. 120 in 'BRA *120'. In IC the labels of a procedure
+	 * are represented by consecutive integer numbers, called
+	 * lab_id. The mapping takes place here.
+	 */
+
+
+	npp = &numhash[number%NNUMHASH];
+	while (*npp != (num_p) 0) {
+		if ((*npp)->n_number == number) {
+			return(*npp)->n_labid;
+		} else {
+			npp = &(*npp)->n_next;
+		}
+	}
+
+	/* The label was not found in the hashtable, so
+	 * create a new entry for it.
+	 */
+
+	*npp = np = newnum();
+	np->n_number = number;
+	np->n_labid = ++lastlid;
+	/* Assign a new label identifier to the num struct.
+	 * lastlid is reset to 0 at the beginning of
+	 * every new EM procedure (by cleaninstrlabs).
+	 */
+	return (np->n_labid);
+}
+
+
+
+/*  symlookup */
+
+STATIC unsigned hash(string) char *string; {
+	register char *p;
+	register unsigned i,sum;
+
+	for (sum=i=0,p=string;*p;i += 3)
+		sum ^= (*p++)<<(i&07);
+	return(sum);
+}
+
+dblock_p symlookup(name, status)
+	char *name;
+	int  status;
+{
+	/* Look up the name of a data block. The name can appear
+	 * in either a defining or applied occurrence (status is
+	 * DEFINING, OCCURRING resp.), or in a MES ms_ext instruction
+	 * as the name of a data block imported by a library module
+	 * (status is IMPORTING). Things get complicated,
+	 * because a HOL pseudo need not be preceded by a
+	 * data label, i.e. a hol block need not have a name.
+	 */
+
+
+	register sym_p *spp,  sp;
+	register dblock_p dp;
+
+	if (name == (char *) 0) {
+		assert(status == DEFINING);
+		dp = newdblock();
+	} else {
+		spp = &symhash[hash(name)%NSYMHASH];
+		while (*spp != (sym_p) 0) {
+			/* Every hashtable entry points to a list
+			 * of synonyms (i.e. names with the same
+			 * hash values). Try to find 'name' in its
+			 * list.
+			 */
+			if (strncmp((*spp)->sy_name, name, IDL) == 0) {
+				/* found */
+				return ((*spp)->sy_dblock);
+			} else {
+				spp = &(*spp)->sy_next;
+			}
+		}
+		/* The name is not found, so create a new entry for it.
+		 * However, if the status is IMPORTING, we just return 0,
+		 * indicating that we don't need this name.
+		 */
+		if (status == IMPORTING) return (dblock_p) 0;
+		*spp = sp = newsym();
+		strncpy(sp->sy_name, name, IDL);
+		dp = sp->sy_dblock = newdblock();
+	}
+	if (fdblock == (dblock_p) 0) {
+		fdblock = dp;
+		/* first data block */
+	} else {
+		ldblock->d_next = dp; /* link to last dblock */
+	}
+	ldblock = dp;
+	dp->d_pseudo	= DUNKNOWN;	/* clear all fields */
+	dp->d_id	= ++lastdid;
+	dp->d_size	= 0;
+	dp->d_objlist	= (obj_p) 0;
+	dp->d_values	= (arg_p) 0;
+	dp->d_next	= (dblock_p) 0;
+	dp->d_flags1	= 0;
+	dp->d_flags2	= 0;
+	if (status == OCCURRING) {
+		/* This is the first occurrence of the identifier,
+		 * so if it is a used occurrence make the
+		 * identifier externally visible, else make it
+		 * internal.
+		 */
+		dp->d_flags1 |= DF_EXTERNAL;
+	}
+	return dp;
+}
+
+
+
+/* getsym */
+
+dblock_p getsym(status)
+	int status;
+{
+	if (table2() != DLBX) {
+		error("symbol expected");
+	}
+	return(symlookup(string,status));
+}
+
+
+
+/* getproc */
+
+proc_p getproc(status)
+	int status;
+{
+	if (table2() != sp_pnam) {
+		error("proc name expected");
+	}
+	return(proclookup(string,status));
+}
+
+
+
+/* proclookup */
+
+proc_p proclookup(name, status)
+	char *name;
+	int  status;
+{
+	register prc_p *ppp,  pp;
+	register proc_p dp;
+
+	ppp = &prochash[hash(name)%NPROCHASH];
+	while (*ppp != (prc_p) 0) {
+		/* Every hashtable entry points to a list
+		 * of synonyms (i.e. names with the same
+		 * hash values). Try to find 'name' in its
+		 * list.
+		 */
+		if (strncmp((*ppp)->pr_name, name, IDL) == 0) {
+			/* found */
+			return ((*ppp)->pr_proc);
+		} else {
+			ppp = &(*ppp)->pr_next;
+		}
+	}
+	/* The name is not found, so create a new entry for it,
+	 * unless the status is IMPORTING, in which case we
+	 * return 0, indicating we don't want this proc.
+	 */
+	if (status == IMPORTING) return (proc_p) 0;
+	*ppp = pp = newprc();
+	strncpy(pp->pr_name, name, IDL);
+	dp = pp->pr_proc = newproc();
+	if (fproc == (proc_p) 0) {
+		fproc = dp;  /* first proc */
+	} else {
+		lproc->p_next = dp;
+	}
+	lproc = dp;
+	dp->p_id	= ++lastpid;	/* create a unique proc_id */
+	dp->p_next	= (proc_p) 0;
+	dp->p_flags1	= 0;
+	dp->p_flags2	= 0;
+	if (status == OCCURRING) {
+		/* This is the first occurrence of the identifier,
+		 * so if it is a used occurrence the make the
+		 * identifier externally visible, else make it
+		 * internal.
+		 */
+		dp->p_flags1 |= PF_EXTERNAL;
+	}
+	return dp;
+}
+
+
+
+/* cleaninstrlabs */
+
+cleaninstrlabs()
+{
+	register num_p *npp, np, next;
+
+	for (npp = numhash; npp < &numhash[NNUMHASH]; npp++) {
+		for  (np = *npp; np != (num_p) 0; np = next) {
+			next = np->n_next;
+			oldnum(np);
+		}
+		*npp = (num_p) 0;
+	}
+	/* Reset last label id (used by instr_lab). */
+	lastlid = (lab_id) 0;
+}
+
+
+
+/* dump_procnames */
+
+dump_procnames(hash,n,f)
+	prc_p  hash[];
+	int    n;
+	FILE   *f;
+{
+	/* Save the names of the EM procedures in file f.
+	 * Note that the Optimizer Intermediate Code does not
+	 * use identifiers but proc_ids, object_ids etc.
+	 * The names, however, can be used after optimization
+	 * is completed, to reconstruct Compact Assembly Language.
+	 * The output consists of tuples (proc_id, name).
+	 * This routine is called once for every input file.
+	 * To prevent names of external procedures being written
+	 * more than once, the PF_WRITTEN flag is used.
+	 */
+
+	register prc_p *pp, ph;
+	proc_p p;
+	char str[IDL+1];
+	register int i;
+
+#define PF_WRITTEN 01
+
+
+	for (pp = &hash[0]; pp < &hash[n]; pp++) {
+		/* Traverse the entire hash table */
+		for (ph = *pp; ph != (prc_p) 0; ph = ph->pr_next) {
+			/* Traverse the list of synonyms */
+			p = ph->pr_proc;
+			if ((p->p_flags2 & PF_WRITTEN) == 0) {
+				/* not been written yet */
+				for(i = 0; i < IDL; i++) {
+					str[i] = ph->pr_name[i];
+				}
+				str[IDL] = '\0';
+				fprintf(f,"%d	%s\n",p->p_id, str);
+				p->p_flags2 |= PF_WRITTEN;
+			}
+		}
+	}
+}
+
+
+
+/* cleanprocs */
+
+cleanprocs(hash,n,mask)
+	prc_p hash[];
+	int   n,mask;
+{
+	/* After an EM input file has been processed, the names
+	 * of those procedures that are internal (i.e. not visible
+	 * outside the file they are defined in) must be removed
+	 * from the procedure hash table. This is accomplished
+	 * by removing the 'prc struct' from its synonym list.
+	 * After the final input file has been processed, all
+	 * remaining prc structs are also removed.
+	 */
+
+	register prc_p *pp, ph, x, next;
+
+	for (pp = &hash[0]; pp < &hash[n]; pp++) {
+		/* Traverse the hash table */
+		x = (prc_p) 0;
+		for (ph = *pp; ph != (prc_p) 0; ph = next) {
+			/* Traverse the synonym list.
+			 * x points to the prc struct just before ph,
+			 * or is 0 if ph is the first struct of
+			 * the list.
+			 */
+			next = ph->pr_next;
+			if ((ph->pr_proc->p_flags1 & mask) == 0) {
+				if (x == (prc_p) 0) {
+					*pp = next;
+				} else {
+					x->pr_next = next;
+				}
+				oldprc(ph); /* delete the struct */
+			} else {
+				x = ph;
+			}
+		}
+	}
+}
+
+
+
+/* dump_dblocknames */
+
+dump_dblocknames(hash,n,f)
+	sym_p  hash[];
+	int    n;
+	FILE   *f;
+{
+	/* Save the names of the EM data blocks in file f.
+	 * The output consists of tuples (dblock_id, name).
+	 * This routine is called once for every input file.
+	 */
+
+	register sym_p *sp, sh;
+	dblock_p d;
+	char str[IDL+1];
+	register int i;
+
+#define DF_WRITTEN 01
+
+
+	for (sp = &hash[0]; sp < &hash[n]; sp++) {
+		/* Traverse the entire hash table */
+		for (sh = *sp; sh != (sym_p) 0; sh = sh->sy_next) {
+			/* Traverse the list of synonyms */
+			d = sh->sy_dblock;
+			if ((d->d_flags2 & DF_WRITTEN) == 0) {
+				/* not been written yet */
+				for (i = 0; i < IDL; i++) {
+					str[i] = sh->sy_name[i];
+					str[IDL] = '\0';
+				}
+				fprintf(f,"%d	%s\n",d->d_id, str);
+				d->d_flags2 |= DF_WRITTEN;
+			}
+		}
+	}
+}
+
+
+
+/* cleandblocks */
+
+cleandblocks(hash,n,mask)
+	sym_p hash[];
+	int   n,mask;
+{
+	/* After an EM input file has been processed, the names
+	 * of those data blocks that are internal must be removed.
+	 */
+
+	register sym_p *sp, sh, x, next;
+
+	for (sp = &hash[0]; sp < &hash[n]; sp++) {
+		x = (sym_p) 0;
+		for (sh = *sp; sh != (sym_p) 0; sh = next) {
+			next = sh->sy_next;
+			if ((sh->sy_dblock->d_flags1 & mask) == 0) {
+				if (x == (sym_p) 0) {
+					*sp = next;
+				} else {
+					x->sy_next = next;
+				}
+				oldsym(sh); /* delete the struct */
+			} else {
+				x = sh;
+			}
+		}
+	}
+}

util/ego/ic/ic_lookup.h

@@ -0,0 +1,71 @@
+/*  I N T E R M E D I A T E   C O D E
+ *
+ *  L O O K - U P   R O U T I N E S
+ */
+
+/* During Intermediate Code generation data label names ('symbols'),
+ * procedure names and instruction labels (numbers) are translated
+ * to resp. a data block pointer, a proc pointer and a label identifier.
+ * We use three hash tables for this purpose (symhash, prochash, numhash).
+ * Every name/number is hashed to an index in a specific table. A table
+ * entry contains a list of structs (sym, prc, num), each one representing
+ * a 'synonym'. (Synonyms are names/numbers having the same hash value).
+ */
+
+
+/* status passed as argument to look_up routines:
+ * resp. used occurrence, defining occurrence, occurrence in
+ * a MES ms_ext pseudo.
+ */
+
+#define OCCURRING	0
+#define DEFINING	1
+#define IMPORTING	2
+
+#define NSYMHASH 127
+#define NPROCHASH 127
+#define NNUMHASH  37
+
+extern sym_p symhash[];
+extern prc_p prochash[];
+extern num_p numhash[];
+
+extern lab_id	instr_lab();		/* ( short number)
+					 * Maps EM labels to sequential
+					 * integers.
+					 */
+extern dblock_p	symlookup();		/* (char *ident, int status)
+					 * Look up the data block with
+					 * the given name.
+					 */
+extern dblock_p	getsym();		/* ( int status)
+					 * Read and look up a symbol.
+					 * If this is the first occurrence
+					 * of it, then make it external
+					 * (if status=OCCURRING) or
+					 * internal (if DEFINING).
+					 */
+extern proc_p	getproc();		/* (int status)
+					 * Same as getsym, but for procedure
+					 * names.
+					 */
+extern proc_p	proclookup();		/* ( char *ident, int status)
+					 * Find (in the hashtable) the
+					 * procedure with the given name.
+					 */
+extern		cleaninstrlabs();	/* ( )
+					 * Forget about all instruction labels.
+					 */
+extern		dump_procnames();	/* (prc_p hash[], int n, FILE *f)
+					 * Save the names of the procedures
+					 * in file f; hash is the hashtable
+					 * used and n is its length.
+					 */
+extern		cleanprocs();		/* (prc_p hash[], int n,mask)
+					 * Make the names of all procedures
+					 * for which p_flags1&mask = 0 invisible
+					 */
+extern		cleandblocks();		/* (sym_p hash[], int n)
+					 * Make the names of all data blocks
+					 * for which d_flags1&mask = 0 invisible
+					 */