WebSVN – tendra.SVN – Blame – /branches/tendra5-amd64/src/installers/common/construct/const.c

Rev	Author	Line No.	Line
2	7u83	1	`/*`
6	7u83	2	`* Copyright (c) 2002-2006 The TenDRA Project <http://www.tendra.org/>.`
		3	`* All rights reserved.`
		4	`*`
		5	`* Redistribution and use in source and binary forms, with or without`
		6	`* modification, are permitted provided that the following conditions are met:`
		7	`*`
		8	`* 1. Redistributions of source code must retain the above copyright notice,`
		9	`* this list of conditions and the following disclaimer.`
		10	`* 2. Redistributions in binary form must reproduce the above copyright notice,`
		11	`* this list of conditions and the following disclaimer in the documentation`
		12	`* and/or other materials provided with the distribution.`
		13	`* 3. Neither the name of The TenDRA Project nor the names of its contributors`
		14	`* may be used to endorse or promote products derived from this software`
		15	`* without specific, prior written permission.`
		16	`*`
		17	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
		18	`* IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,`
		19	`* THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR`
		20	`* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR`
		21	`* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,`
		22	`* EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,`
		23	`* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;`
		24	`* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,`
		25	`* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR`
		26	`* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF`
		27	`* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.`
		28	`*`
		29	`* $Id$`
		30	`*/`
		31	`/*`
2	7u83	32	`Crown Copyright (c) 1997`
		33
		34	`This TenDRA(r) Computer Program is subject to Copyright`
		35	`owned by the United Kingdom Secretary of State for Defence`
		36	`acting through the Defence Evaluation and Research Agency`
		37	`(DERA). It is made available to Recipients with a`
		38	`royalty-free licence for its use, reproduction, transfer`
		39	`to other parties and amendment for any purpose not excluding`
		40	`product development provided that any such use et cetera`
		41	`shall be deemed to be acceptance of the following conditions:-`
		42
		43	`(1) Its Recipients shall ensure that this Notice is`
		44	`reproduced upon any copies or amended versions of it;`
		45
		46	`(2) Any amended version of it shall be clearly marked to`
		47	`show both the nature of and the organisation responsible`
		48	`for the relevant amendment or amendments;`
		49
		50	`(3) Its onward transfer from a recipient to another`
		51	`party shall be deemed to be that party's acceptance of`
		52	`these conditions;`
		53
		54	`(4) DERA gives no warranty or assurance as to its`
		55	`quality or suitability for any purpose and DERA accepts`
		56	`no liability whatsoever in relation to any use to which`
		57	`it may be put.`
		58	`*/`
		59
		60
		61	`/**********************************************************************`
		62	$Author: pwe $
		63	$Date: 1998/03/11 11:03:21 $
		64	$Revision: 1.3 $
		65	$Log: const.c,v $
		66	`* Revision 1.3 1998/03/11 11:03:21 pwe`
		67	`* DWARF optimisation info`
		68	`*`
		69	`* Revision 1.2 1998/01/29 16:59:07 pwe`
		70	`* hold2`
		71	`*`
		72	`* Revision 1.1.1.1 1998/01/17 15:55:46 release`
		73	`* First version to be checked into rolling release.`
		74	`*`
		75	`* Revision 1.5 1998/01/09 09:28:40 pwe`
		76	`* prep restructure`
		77	`*`
		78	`* Revision 1.4 1997/10/10 18:15:21 pwe`
		79	`* prep ANDF-DE revision`
		80	`*`
		81	`* Revision 1.3 1996/11/04 15:15:13 currie`
		82	`* no err-jumps in const extraction`
		83	`*`
		84	`Revision 1.2 1995/08/15 08:25:29 currie`
		85	`Shift left + trap_tag`
		86
		87	`* Revision 1.1 1995/04/06 10:44:05 currie`
		88	`* Initial revision`
		89	`*`
		90	`***********************************************************************/`
		91
		92
		93
		94
		95	`/************************************************************************`
		96	`* const.c`
		97	`* This file defines the routines which implement the TDF-to-TDF`
		98	`* optimising transformation which removes constant expressions from`
		99	`* program fragments (typically loops).`
		100	`*`
		101	`* The type maxconst returns information about the expression under`
		102	`* consideration. The field self is true if the expression as a whole is`
		103	`* constant within the program fragment under consideration. If the`
		104	`* entire expression is not constant (self is false) then the field cont`
		105	`* is a list of the sub-expressions which are constant within the`
		106	`* specified region.`
		107	`*`
		108	`* The type maxconst is defined in consttypes.h`
		109	`*`
		110	`* The principal procedures defined here are mc_list, repeat_consts and`
		111	`* return_repeats. They are described below.`
		112	`*`
		113	`* Also used externally is intnl_to.`
		114	`*`
		115	`************************************************************************/`
		116
		117	`#include "config.h"`
		118	`#include "common_types.h"`
		119	`#include "consttypes.h"`
		120	`#include "constmacs.h"`
		121	`#include "tags.h"`
		122	`#include "expmacs.h"`
		123	`#include "exp.h"`
		124	`#include "check.h"`
		125	`#include "install_fns.h"`
		126	`#include "shapemacs.h"`
		127	`#include "check_id.h"`
		128	`#include "flags.h"`
		129	`#include "externs.h"`
		130	`#include "installglob.h"`
		131	`#include "is_worth.h"`
		132	`#include "flpt.h"`
		133	`#include "flpttypes.h"`
		134	`#include "xalloc.h"`
		135	`#include "messages_c.h"`
		136	`#include "basicread.h"`
		137	`#include "me_fns.h"`
		138	`#ifdef NEWDIAGS`
		139	`#include "dg_aux.h"`
		140	`#endif`
		141
		142	`#include "const.h"`
		143
		144	`/* MACROS */`
		145
		146	`#define false 0`
		147	`#define true 1`
		148	`#define MAXUSE 16`
		149	`#define VERYBIGUSAGE 100`
		150	`#define MEMINC 64`
6	7u83	151	`#define nilmem ((memlist *)0)`
2	7u83	152
		153	`/* IDENTITIES */`
		154
		155	`static maxconst self_const = {`
		156	`true, nilexp`
		157	`},`
		158	`/* the entire expression is constant */`
		159	`no_consts = {`
		160	`false, nilexp`
		161	`};`
		162	`/* no part of the expression is constant */`
		163
		164	`/* VARIABLES */`
		165	`/* All variables initialised */`
		166
		167	`typedef struct _memlist {`
		168	`exp dec;`
		169	`int res;`
		170	`struct _memlist *next;`
		171	`} memlist;`
		172
		173	`/* no need to init mem and fmem */`
		174	`static memlist mem = nilmem, / current list of frequent identifiers */`
		175	`fmem = nilmem; / list of free cells */`
		176
		177	`static prop cond_flag = 0; /* pushed value */`
		178	`/* 1 => inside cond(..); 2 => after test() in cond() */`
		179
		180	`static int arg_is_reff; /* no init needed */`
		181	`/* arg is reffield, so contents doesn't need guarding */`
		182
		183	`#define globmax 100`
		184	`static int glob_index;`
		185	`static exp glob_dest[globmax];`
		186
		187	`static int has_lj_dest;`
		188
		189
		190	`/* PROCEDURES */`
		191
6	7u83	192	`exp get_repeats(void);`
2	7u83	193
6	7u83	194	`static int`
		195	`find_glob(exp e)`
2	7u83	196	`{`
		197	`int i;`
6	7u83	198	`for (i = 0; i < glob_index; i++)`
2	7u83	199	`if (glob_dest[i] == e)`
		200	`return 1;`
		201	`return 0;`
		202	`}`
		203
		204	`/************************************************************************`
		205	`* ret_constlist returns the elements of a constants-list`
		206	`************************************************************************/`
6	7u83	207	`static void ret_constlist(exp head);`
2	7u83	208
6	7u83	209	`void`
		210	`ret_constlist(exp head)`
2	7u83	211	`{`
		212	`if (head != nilexp) {`
6	7u83	213	`exp limit = pt(head), t = son(head), n;`
		214	`retcell(head);`
2	7u83	215	`while (t != limit) {`
6	7u83	216	`n = bro(t);`
		217	`retcell(t);`
2	7u83	218	`t = n;`
		219	`}`
6	7u83	220	`retcell(t);`
2	7u83	221	`}`
		222	`return;`
		223	`}`
		224
6	7u83	225	`static maxconst max_const(exp, exp, int);`
2	7u83	226	`/* declaration - max_const and mc_list are mutually recursive */`
		227
		228
		229
		230	`/************************************************************************`
		231	`* mc_list examines a list of expressions, and for each of them`
		232	`* extracts the largest expressions which are constant within the`
		233	`* region of interest.`
		234	`*`
		235	`* Parameters:`
		236	`* whole the program region under consideration`
		237	`* e the first expression in the list. Expressions are`
		238	`* linked via the brother field.`
		239	`* ass_ok all assignments in this region are to simple unaliassed`
		240	`* variables`
		241	`* good if this is true AND all the expressions in the list are`
		242	`* constant then the value self_const is returned.`
		243	`************************************************************************/`
		244
6	7u83	245	`static`
		246	`maxconst mc_list(exp whole, exp e, int ass_ok, int good)`
2	7u83	247	`{`
		248	`exp t = e;`
		249	`int contin = true;`
		250	`maxconst mc, result;`
		251
		252	`result.self = good;`
		253	`result.cont = nilexp;`
		254
		255	`do {`
		256	`/* NB - t may be killed within max_const (offset_mult) */`
		257	`/* so remember next one in list */`
6	7u83	258	`exp next_t = bro(t);`
		259	`if (last(t)) {`
2	7u83	260	`contin = false;`
6	7u83	261	`}`
		262	`mc = max_const(whole, t, ass_ok);`
2	7u83	263
		264	`if (mc.self) {`
		265	`/* the whole of t is constant */`
		266	`/* make a list element */`
6	7u83	267	`exp w = getexp(f_bottom, nilexp, false, t, nilexp, cond_flag,`
2	7u83	268	`0, 0);`
6	7u83	269	`if (result.cont == nilexp) {/* first item - start a list */`
		270	`result.cont = getexp(f_bottom, nilexp, false, w, w, 0, 0, 0);`
		271	`} else { /* add this to list */`
		272	`bro(pt(result.cont)) = w;`
		273	`pt(result.cont) = w;`
2	7u83	274	`}`
		275	`} else {`
		276	`result.self = false; /* some part of e is not constant */`
		277	`if (mc.cont != nilexp) { /* but t has constants in it */`
		278	`if (result.cont != nilexp) { /* add them to list */`
6	7u83	279	`bro(pt(result.cont)) = son(mc.cont);`
		280	`pt(result.cont) = pt(mc.cont);`
		281	`retcell(mc.cont);`
		282	`} else { /* list was empty - start list */`
2	7u83	283	`result.cont = mc.cont;`
6	7u83	284	`}`
2	7u83	285	`}`
		286	`}`
		287
		288	`t = next_t;`
6	7u83	289	`} while (contin);`
2	7u83	290
		291	`if (result.self) {`
6	7u83	292	`ret_constlist(result.cont);`
		293	`return(self_const);`
2	7u83	294	`}`
		295	`return result;`
		296	`}`
		297
		298
		299	`/************************************************************************`
		300	`* intnl_to returns true if part is contained in whole`
		301	`************************************************************************/`
		302
6	7u83	303	`int`
		304	`intnl_to(exp whole, exp part)`
2	7u83	305	`{`
		306	`exp q = part;`
		307
6	7u83	308	`while (q != whole && q != nilexp && name(q) != hold_tag &&`
		309	`name(q) != hold2_tag && (name(q) != ident_tag \|\| !isglob(q))) {`
		310	`q = father(q);`
		311	`}`
2	7u83	312
		313	`return q == whole;`
		314	`}`
		315
		316	`/* heavily used idents are kept in lookup list */`
		317
6	7u83	318	`static int not_assigned_to(exp, exp);`
2	7u83	319
6	7u83	320	`static int`
		321	`not_ass2(exp vardec, exp piece)`
2	7u83	322	`{`
		323	`/*`
		324	`* this replaces used_in with stronger test - see changes in assigns_alias`
		325	`*/`
6	7u83	326	`exp t = pt(vardec);`
2	7u83	327	`exp q;`
		328	`exp upwards = t;`
		329
		330	`do { /* test each use of the identifier */`
		331	`q = t;`
		332	`while (q != nilexp && q != piece && q != vardec &&`
6	7u83	333	`name(q) != rep_tag && (name(q) != ident_tag \|\| !isglob(q))) {`
2	7u83	334	`upwards = q;`
6	7u83	335	`q = bro(q);`
2	7u83	336	`}`
		337
6	7u83	338	`if (q != nilexp && q != piece && name(q) == rep_tag) {`
2	7u83	339	`/* q has got to a repeat, so */`
		340	`/* scan up repeat_list structure for holder of piece */`
6	7u83	341	`exp h = pt(q), hp = pt(piece);`
		342	`while (h != nilexp && h != hp) {`
		343	`h = bro(h);`
		344	`}`
2	7u83	345	`if (h == hp) {`
		346	`/* q was within piece */`
		347	`q = piece;`
6	7u83	348	`upwards = son(q);`
		349	`while (!last(upwards)) {`
		350	`upwards = bro(upwards);`
		351	`}`
		352	`} else {`
2	7u83	353	`q = nilexp;`
6	7u83	354	`}`
2	7u83	355	`}`
		356	`/* ascend from the use until we reach either vardec or piece */`
		357	`if (q == piece && last (upwards)) { /* the use was in piece */`
6	7u83	358	`if (isreallyass(t)) {`
2	7u83	359	`return false;`
6	7u83	360	`}`
		361	`if (!last(t) && last(bro(t)) &&`
		362	`(name(bro(bro(t))) == ass_tag \|\| name(bro(bro(t))) == assvol_tag)) {`
2	7u83	363	`return false; /* the use was an assignment */`
6	7u83	364	`}`
		365	`if (!last(t) && last(bro(t)) && name(bro(bro(t))) == ident_tag) {`
2	7u83	366	`/* use in declaration */`
6	7u83	367	`if (!isvar(bro(bro(t))) && !not_assigned_to(bro(bro(t)), bro(t))) {`
2	7u83	368	`return false;`
		369	`}`
		370	`} else {`
6	7u83	371	`exp dad = father(t);`
		372	`if (name(dad) == addptr_tag && son(dad) == t) {`
2	7u83	373	`/* use in subscript .... */`
6	7u83	374	`if (!last(dad) && last(bro(dad)) &&`
		375	`(name(bro(bro(dad))) == ass_tag \|\|`
		376	`name(bro(bro(dad))) == assvol_tag)) {`
2	7u83	377	`return false; /* the use was an assignment */`
6	7u83	378	`}`
		379	`if (!last(dad) && last(bro(dad)) &&`
		380	`name(bro(bro(dad))) == ident_tag) {`
2	7u83	381	`/* ... which is identified */`
6	7u83	382	`if (!isvar(bro(bro(dad))) &&`
		383	`!not_assigned_to(bro(bro(dad)), bro(dad))) {`
2	7u83	384	`return false;`
		385	`}`
		386	`}`
		387	`}`
		388	`}`
		389	`}`
6	7u83	390	`t = pt(t);`
2	7u83	391	`} while (t != nilexp);`
		392	`return true;`
		393	`}`
		394
		395
6	7u83	396	`static int`
		397	`not_assigned_to(exp vardec, exp body)`
2	7u83	398	`{`
6	7u83	399	`if (no(vardec) > VERYBIGUSAGE) {`
2	7u83	400	`return false;`
6	7u83	401	`}`
2	7u83	402
6	7u83	403	`if (no(vardec) > MAXUSE) {`
2	7u83	404	`/* when a variable is used many times the result from not_ass2 */`
		405	`/* is saved in an ordered list to avoid n-squared run-times */`
		406	`memlist *ptr = mem;`
		407	`/* is this declaration known? */`
		408	`/* NOTE: memory is cleared after each repeat is processed */`
		409	`/* so any in memory refer to the current repeat */`
		410	`while (ptr != nilmem && (ptr->dec) != vardec)`
		411	`ptr = ptr->next;`
		412	`if (ptr == nilmem) {`
		413	`memlist **pp = &mem;`
		414	`/* insert with heavier used decs first */`
6	7u83	415	`while (pp != nilmem && no((pp) ->dec) > no(vardec)) {`
		416	`pp = & ((*pp) ->next);`
		417	`}`
2	7u83	418	`if (fmem == nilmem) {`
		419	`/* add some cells onto the free list */`
		420	`memlist **fpp = &fmem;`
		421	`int i;`
6	7u83	422	`fpp = (memlist )xcalloc(MEMINC, sizeof(memlist));`
2	7u83	423	`for (i = 0; i < MEMINC; ++i) {`
6	7u83	424	`(fpp) ->next = (fpp) + 1;`
		425	`fpp = & ((*fpp) ->next);`
2	7u83	426	`}`
		427	`*fpp = nilmem;`
		428	`}`
		429	`/* get a cell from the free list */`
		430	`ptr = fmem;`
		431	`fmem = ptr->next;`
		432	`/* remember this vardec */`
		433	`ptr->dec = vardec;`
6	7u83	434	`ptr->res = not_ass2(vardec, body);`
2	7u83	435	`/* put cell into mem list */`
		436	`ptr->next = *pp;`
		437	`*pp = ptr;`
		438	`}`
6	7u83	439	`return(ptr->res);`
		440	`} else {`
2	7u83	441	`/* default case - identifier not heavily used */`
6	7u83	442	`return(not_ass2(vardec, body));`
		443	`}`
2	7u83	444	`}`
		445
		446
		447
		448	`/************************************************************************`
		449	`* max_const extracts the largest expressions which are constant within`
		450	`* the region of interest.`
		451	`*`
		452	`* Parameters:`
		453	`* whole the program region under consideration`
		454	`* e the expression under consideration`
		455	`* ass_ok all assignments in this region are to simple unaliassed`
		456	`* variables`
		457	`************************************************************************/`
		458
6	7u83	459	`static maxconst`
		460	`max_const(exp whole, exp e, int ass_ok)`
2	7u83	461	`{`
6	7u83	462	`switch (name(e)) {`
2	7u83	463	`case labst_tag:`
6	7u83	464	`return mc_list(whole, bro(son(e)), ass_ok, false);`
2	7u83	465
		466	`case contvol_tag:`
		467	`case case_tag:`
		468	`case goto_tag:`
		469	`case apply_general_tag:`
		470	`case tail_call_tag:`
		471	`return no_consts;`
		472
		473	`case fdiv_tag: {`
		474	`maxconst mc;`
		475	`maxconst mct;`
		476	`mc = max_const(whole, bro(son(e)), ass_ok);`
6	7u83	477	`mct = mc_list(whole, son(e), ass_ok, optop(e));`
		478	`if (mct.self) {`
2	7u83	479	`return mct;`
6	7u83	480	`}`
2	7u83	481
		482	`if (mc.self && !strict_fl_div && optop(e)) {`
		483	`flpt f = new_flpt();`
		484	`exp funit;`
		485	`exp temp1;`
		486	`exp temp2;`
6	7u83	487	`flt_copy(flptnos[fone_no], &flptnos[f]);`
		488	`funit = getexp(sh(e), nilexp, 0, nilexp, nilexp, 0, f, real_tag);`
2	7u83	489	`temp1 = me_b3(sh(e), funit, bro(son(e)), fdiv_tag);`
		490	`temp2 = me_b3(sh(e), son(e), temp1, fmult_tag);`
		491
		492	`#ifdef NEWDIAGS`
		493	`dgf(temp2) = dgf(e);`
		494	`#endif`
		495	`replace(e, temp2, temp2);`
		496	`return max_const(whole, temp2, ass_ok);`
6	7u83	497	`} else {`
		498	`return mct;`
2	7u83	499	`}`
6	7u83	500	`}`
2	7u83	501
		502
6	7u83	503	`case cond_tag: {`
2	7u83	504	`prop old_cond_flag = cond_flag;`
		505	`maxconst mc;`
6	7u83	506	`if (cond_flag == 0) {`
2	7u83	507	`cond_flag = 1;`
6	7u83	508	`}`
		509	`mc = mc_list(whole, son(e), ass_ok, false);`
2	7u83	510	`cond_flag = old_cond_flag;`
		511	`return mc;`
6	7u83	512	`}`
2	7u83	513
		514	`case test_tag:{`
		515	`maxconst mc;`
6	7u83	516	`mc = mc_list(whole, son(e), ass_ok, false);`
		517	`if (cond_flag == 1) {`
2	7u83	518	`cond_flag = 2;`
6	7u83	519	`}`
2	7u83	520	`return mc;`
6	7u83	521	`}`
2	7u83	522
		523	`case val_tag:`
		524	`case proc_tag:`
		525	`case env_offset_tag:`
		526	`case general_env_offset_tag:`
		527	`return self_const;`
		528
		529	`case name_tag:`
6	7u83	530	`if (intnl_to(whole, son(e))) {`
2	7u83	531	`return no_consts; /* internal const - may change */`
6	7u83	532	`} else {`
2	7u83	533	`return self_const; /* external constant */`
6	7u83	534	`}`
2	7u83	535
		536	`case cont_tag:`
6	7u83	537	`if ((name(son(e)) == name_tag) && isvar(son(son(e)))) {`
2	7u83	538	`/* so e is extracting the contents of a variable */`
6	7u83	539	`exp var = son(son(e));`
2	7u83	540
6	7u83	541	`if (!intnl_to(whole, var) && (not_assigned_to(var, whole))`
2	7u83	542	`&& ass_ok) {`
		543	`/*`
		544	`* variable declared external to whole, and NEVER assigned to in`
		545	`* whole`
		546	`*/`
6	7u83	547	`if (iscaonly(var)) {`
2	7u83	548	`return self_const;`
6	7u83	549	`}`
		550	`if (isglob(var) && !find_glob(var)) {`
2	7u83	551	`return self_const;`
		552	`}`
		553	`return no_consts;`
6	7u83	554	`} else {`
		555	`return no_consts;`
		556	`}`
		557	`} else {`
		558	`return mc_list(whole, son(e), ass_ok, ass_ok);`
		559	`}`
2	7u83	560
		561	`case plus_tag:`
		562	`case and_tag:`
		563	`case or_tag:`
		564	`case xor_tag:`
6	7u83	565	`case mult_tag: {`
2	7u83	566	`maxconst mc;`
		567
6	7u83	568	`mc = mc_list(whole, son(e), ass_ok, optop(e));`
2	7u83	569
6	7u83	570	`if (mc.cont != nilexp && pt(mc.cont) != son(mc.cont) && optop(e)) {`
2	7u83	571	`/* more than 1 item in list */`
6	7u83	572	`exp limit = pt(mc.cont), h = son(mc.cont), arg, this, last_h;`
2	7u83	573	`int arg_count = 0;`
		574	`int tot_args = 1;`
		575	`this = son(e);`
6	7u83	576	`while (!last(this)) {`
2	7u83	577	`this = bro(this);`
		578	`++tot_args;`
6	7u83	579	`}`
2	7u83	580
		581	`/* remember for which operator these are arguments */`
		582	`/* NB - some items may not be args of this operator */`
		583	`while (h != nilexp) {`
6	7u83	584	`this = son(h);`
		585	`arg = son(e);`
		586	`while (arg != nilexp && arg != this) {`
		587	`arg = (last(arg)? nilexp : bro(arg));`
		588	`}`
2	7u83	589	`if (arg != nilexp) {`
		590	`/* it's an argument of this operator */`
		591	`++arg_count;`
6	7u83	592	`pt(h) = e;`
2	7u83	593	`last_h = h;`
		594	`}`
6	7u83	595	`h = (h == limit ? nilexp : bro(h));`
2	7u83	596	`}`
		597	`/* remove reference to operator if only 1 arg is const */`
		598	`if (arg_count != tot_args && arg_count > 0) {`
		599	`SET(last_h);`
6	7u83	600	`pt(last_h) = nilexp;`
		601	`}`
2	7u83	602	`}`
		603	`return mc;`
6	7u83	604	`}`
2	7u83	605
6	7u83	606	`case addptr_tag: {`
		607	`exp p = son(e);`
2	7u83	608	`maxconst mc, mx;`
		609
		610	`/* find the root pointer */`
6	7u83	611	`while (name(p) == addptr_tag) {`
		612	`p = son(p);`
		613	`}`
2	7u83	614
6	7u83	615	`mc = max_const(whole, p, ass_ok);`
		616	`ret_constlist(mc.cont);`
2	7u83	617
		618	`if (mc.self) {`
		619	`/* root pointer is constant in this context */`
		620	`exp c_list = nilexp, v_list = nilexp, x, cph, *list;`
		621
		622	`/* construct list of ALL constant parts */`
		623	`/* initial list element will hold const. ptr */`
6	7u83	624	`cph = getexp(f_bottom, nilexp, false, nilexp, nilexp,`
2	7u83	625	`0, 0, 0);`
		626	`mc.self = false; /* assume, for moment */`
6	7u83	627	`mc.cont = getexp(f_bottom, nilexp, false, cph, cph,`
2	7u83	628	`0, 0, 0);`
		629
		630	`/* return up the chain, testing the offsets */`
		631	`while (p != e) {`
6	7u83	632	`mx = max_const(whole, bro(p), ass_ok);`
		633	`p = bro(p); /* p is now the offset */`
2	7u83	634
		635	`/* add offset to appropriate list */`
6	7u83	636	`list = (mx.self)? &c_list : &v_list;`
		637	`list = getexp(nilexp, list, 0, p, nilexp, 0, 0, 0);`
2	7u83	638
		639	`if (mx.cont != nilexp) {`
		640	`/* the offset is not constant, but PARTS of it are */`
		641
		642	`/* remove any "negate(name(...))" */`
6	7u83	643	`exp lim = pt(mx.cont), h = son(mx.cont);`
2	7u83	644	`while (h != nilexp) {`
6	7u83	645	`if (name(son(h)) == neg_tag && name(son(son(h))) == name_tag) {`
		646	`no(h) = -1; /* set "done" flag */`
		647	`}`
		648	`h = (h == lim ? nilexp : bro(h));`
2	7u83	649	`}`
		650
		651	`/* add constant parts to mc */`
6	7u83	652	`bro(pt(mx.cont)) = son(mc.cont);`
		653	`son(mc.cont) = son(mx.cont);`
		654	`retcell(mx.cont);`
2	7u83	655	`}`
6	7u83	656	`p = bro(p); /* p is now the next higher operation */`
2	7u83	657	`}`
		658
		659	`if (v_list == nilexp) {`
		660	`/* whole addptr expression is constant */`
		661	`/* return c_list elements */`
		662	`while (c_list != nilexp) {`
		663	`x = c_list;`
6	7u83	664	`c_list = bro(c_list);`
		665	`retcell(x);`
2	7u83	666	`}`
		667
6	7u83	668	`ret_constlist(mc.cont);`
2	7u83	669
		670	`return self_const;`
		671	`}`
		672	`/* go down the chain of addptrs, rearranging offsets */`
		673	`/* NB - assumes addptr is strictly diadic, so "last" */`
		674	`/* flags are already correct */`
		675
		676	`/* put non-constant offsets at the higher levels */`
		677	`while (v_list != nilexp) {`
		678	`/* put next offset in 2nd argument position */`
6	7u83	679	`x = son(p);`
		680	`bro(x) = son(v_list);`
		681	`bro(bro(x)) = p;`
2	7u83	682	`p = x; /* point to 1st argument */`
		683	`/* traverse v_list, returning elements */`
		684	`x = v_list;`
6	7u83	685	`v_list = bro(x);`
		686	`retcell(x);`
2	7u83	687	`}`
		688
		689	`/* the rest is constant - add it to mc.cont */`
6	7u83	690	`son(cph) = p;`
2	7u83	691
		692	`/* and put constant offsets at the lower levels */`
		693	`while (c_list != nilexp) {`
		694	`/* put next offset in 2nd argument position */`
6	7u83	695	`x = son(p);`
		696	`bro(x) = son(c_list);`
		697	`bro(bro(x)) = p;`
2	7u83	698	`p = x; /* point to 1st argument */`
		699	`/* traverse c_list, returning elements */`
		700	`x = c_list;`
6	7u83	701	`c_list = bro(x);`
		702	`retcell(x);`
2	7u83	703	`}`
		704
		705	`return mc;`
6	7u83	706	`} else {`
		707	`return mc_list(whole, son(e), ass_ok, true);`
		708	`}`
		709	`}`
2	7u83	710
6	7u83	711	`case offset_mult_tag: {`
		712	`exp arg1 = son(e);`
		713	`exp arg2 = bro(arg1);`
2	7u83	714	`maxconst mc1, mc2;`
6	7u83	715	`shape ofsh = sh(e);`
		716	`mc1 = max_const(whole, arg1, ass_ok);`
		717	`mc2 = max_const(whole, arg2, ass_ok);`
		718	`if (mc1.self && mc2.self) {`
2	7u83	719	`return self_const;`
6	7u83	720	`}`
2	7u83	721	`if (mc2.self && mc1.cont != nilexp) {`
		722	`/**********************************************************`
		723	`* the offset is const, and arg1 has some constant parts`
		724	`* so transform:`
		725	`* offset_mult((a*b),K)`
		726	`* to:`
		727	`* offset_mult(a,offset_mult(b,K))`
		728	`* rearranged so that the constant factors are grouped`
		729	`* with K so that the largest possible structure can be`
		730	`* extracted as constant`
		731	`*********************************************************/`
		732	`exp klist = nilexp, nklist = nilexp;`
		733	`exp *ref;`
		734	`exp m_res;`
		735	`int j;`
6	7u83	736	`ret_constlist(mc1.cont);`
		737	`if (name(arg1) == mult_tag) {`
		738	`exp m_arg = son(arg1);`
2	7u83	739	`/* sort into const and varying args */`
		740	`while (m_arg != nilexp) {`
6	7u83	741	`mc1 = max_const(whole, m_arg, ass_ok);`
2	7u83	742	`if (mc1.self) {`
		743	`/* add to constant operand list */`
6	7u83	744	`klist = getexp(nilexp, klist, false, m_arg, nilexp,`
2	7u83	745	`0, 0, 0);`
		746	`} else {`
		747	`/* add to non-constant operand list */`
6	7u83	748	`nklist = getexp(nilexp, nklist, false, m_arg, nilexp,`
2	7u83	749	`0, 0, 0);`
6	7u83	750	`ret_constlist(mc1.cont);`
2	7u83	751	`}`
6	7u83	752	`if (last(m_arg)) {`
2	7u83	753	`m_arg = nilexp;`
6	7u83	754	`} else {`
		755	`m_arg = bro(m_arg);`
		756	`}`
2	7u83	757	`}`
		758	`/* build offset_mult chain with const parts innermost */`
6	7u83	759	`m_res = copy(arg2);`
2	7u83	760	`for (j = 0; j < 2; ++j) {`
6	7u83	761	`exp *list = (j == 0)? &klist : &nklist;`
2	7u83	762	`/* use klist, and then nklist */`
		763	`while (*list != nilexp) {`
		764	`exp z = *list;`
6	7u83	765	`exp a1 = copy(son(z));`
		766	`exp offmul = getexp(ofsh, nilexp, false, a1, nilexp,`
2	7u83	767	`0, 0, offset_mult_tag);`
6	7u83	768	`setbro(a1, m_res);`
		769	`clearlast(a1);`
		770	`setbro(m_res, offmul);`
		771	`setlast(m_res);`
2	7u83	772	`m_res = hold_check(offmul);`
6	7u83	773	`*list = bro(z);`
		774	`retcell(z);`
2	7u83	775	`}`
		776	`}`
		777	`/* insert m_res - kill left overs */`
6	7u83	778	`ref = refto(father(e), e);`
		779	`if (last(*ref)) {`
		780	`setlast(m_res);`
		781	`} else {`
		782	`clearlast(m_res);`
		783	`}`
		784	`bro(m_res) = bro(*ref);`
2	7u83	785	`*ref = m_res;`
6	7u83	786	`kill_exp(e, e);`
		787	`} else {`
2	7u83	788	`m_res = e;`
6	7u83	789	`}`
		790	`return mc_list(whole, son(m_res), ass_ok, true);`
2	7u83	791	`}`
		792	`/* default action */`
6	7u83	793	`return mc_list(whole, son(e), ass_ok, true);`
		794	`}`
2	7u83	795
		796	`default:`
6	7u83	797	`if (son(e) == nilexp) {`
2	7u83	798	`return self_const;`
6	7u83	799	`} else {`
		800	`return mc_list(whole, son(e), ass_ok, is_a(name(e)) && optop(e));`
		801	`}`
2	7u83	802	`}`
		803	`}`
		804
		805
		806	`/************************************************************************`
		807	`* do_this_k`
		808	`* replaces simple and compound constants in list by uses of a`
		809	`* newly declared constant.`
		810	`* Parameters:`
		811	`* kdec declaration of this new constant`
		812	`* patn pattern to look for`
		813	`* NB where safe_eval has NOT been used,`
		814	`* patn is son(kdec)`
		815	`* list list of constant expresion holders`
		816	`* limit last constant holder in list`
		817	`************************************************************************/`
		818
6	7u83	819	`void do_this_k(exp kdec, exp patn, exp list, exp limit);`
		820
		821	`void`
		822	`do_this_k(exp kdec, exp patn, exp list, exp limit)`
2	7u83	823	`{`
		824	`exp t = list;`
		825	`int scan = true;`
		826	`exp arglist = nilexp, ap;`
		827	`int nargs = 0;`
		828
6	7u83	829	`if (pt(list) != nilexp) {`
2	7u83	830	`/* build required argument list */`
6	7u83	831	`exp p = son(patn);`
2	7u83	832	`while (p != nilexp) {`
6	7u83	833	`exp arg_h = getexp(nilexp, arglist, 0, p, nilexp, 0, 0, 0);`
2	7u83	834	`arglist = arg_h;`
		835	`++nargs;`
6	7u83	836	`p = (last(p)? nilexp : bro(p));`
2	7u83	837	`}`
		838	`}`
		839	`while (scan) {`
6	7u83	840	`if (no(t) == 0) {`
2	7u83	841
6	7u83	842	`if (pt(t) == nilexp && eq_exp(son(t), patn)) {`
2	7u83	843	`/* simple correspondence */`
6	7u83	844	`exp e = son(t);`
		845	`exp f = father(e);`
		846	`exp tagt = getexp(sh(e), bro(e), (int)(last(e)),`
		847	`kdec, pt(kdec), 0, 0, name_tag);`
		848	`pt(kdec) = tagt;`
		849	`++no(kdec);`
2	7u83	850	`#ifdef NEWDIAGS`
6	7u83	851	`if (diagnose) {`
		852	`dg_extracted(tagt, *(refto(f, e)));`
		853	`}`
2	7u83	854	`#endif`
6	7u83	855	`*(refto(f, e)) = tagt;`
		856	`no(t) = -1; /* dealt with */`
		857	`kill_exp(son(t), son(t));`
		858	`} else if (pt(t) != nilexp && name(pt(t)) == name(patn)) {`
2	7u83	859	`/* try for complex match - at least the operator is correct */`
		860	`/* check errtreat ??? */`
		861	`int scan2 = true;`
		862	`int matched = 0;`
6	7u83	863	`exp t2 = t, op = pt(t);`
2	7u83	864
		865
		866	`while (matched >= 0 && scan2) {`
6	7u83	867	`if (no(t2) == 0 && pt(t2) == op) {`
2	7u83	868	`/* find match in argument list */`
		869	`ap = arglist;`
		870
		871	`while (ap != nilexp &&`
6	7u83	872	`(pt(ap) != nilexp \|\| !eq_exp(son(t2), son(ap)))) {`
		873	`ap = bro(ap);`
		874	`}`
2	7u83	875
6	7u83	876	`if (ap == nilexp) {`
2	7u83	877	`matched = -1;`
6	7u83	878	`} else {`
		879	`pt(ap) = t2;`
2	7u83	880	`++matched;`
		881	`}`
		882	`}`
6	7u83	883	`if (t2 == limit) {`
2	7u83	884	`scan2 = false;`
6	7u83	885	`} else {`
		886	`t2 = bro(t2);`
		887	`}`
2	7u83	888	`}`
		889
		890	`if (matched == nargs) {`
6	7u83	891	`exp prev_arg = nilexp, oparg = son(op), cc;`
2	7u83	892	`int last_arg;`
		893
6	7u83	894	`cc = getexp(sh(son(kdec)), op, 1, kdec, pt(kdec), 0,`
2	7u83	895	`0, name_tag);`
6	7u83	896	`pt(kdec) = cc;`
		897	`++no(kdec);`
2	7u83	898
		899	`while (oparg != nilexp) {`
6	7u83	900	`last_arg = (int)last(oparg);`
2	7u83	901	`ap = arglist;`
6	7u83	902	`while (ap != nilexp && son(pt(ap)) != oparg) {`
		903	`ap = bro(ap);`
		904	`}`
2	7u83	905	`if (ap == nilexp) {`
		906	`/* this is one of the other args of op */`
6	7u83	907	`if (prev_arg == nilexp) {`
		908	`son(op) = oparg;`
		909	`} else {`
		910	`bro(prev_arg) = oparg;`
		911	`}`
		912	`clearlast(oparg);`
2	7u83	913	`prev_arg = oparg;`
		914	`}`
6	7u83	915	`oparg = (last_arg ? nilexp : bro(oparg));`
2	7u83	916	`}`
		917
		918	`/* now add combined constant */`
6	7u83	919	`bro(prev_arg) = cc;`
2	7u83	920
		921	`/* mark those dealt with & clear arglist */`
		922	`ap = arglist;`
		923	`while (ap != nilexp) {`
6	7u83	924	`exp deadarg = son(pt(ap));`
		925	`no(pt(ap)) = -1;`
		926	`son(pt(ap)) = nilexp;`
		927	`pt(ap) = nilexp;`
		928	`kill_exp(deadarg, deadarg);`
		929	`ap = bro(ap);`
2	7u83	930	`}`
		931	`}`
		932	`}`
		933	`}`
6	7u83	934	`if (t == limit) {`
2	7u83	935	`scan = false;`
6	7u83	936	`} else {`
		937	`t = bro(t);`
		938	`}`
2	7u83	939	`}`
		940
		941	`/* return arglist */`
		942	`while (arglist != nilexp) {`
6	7u83	943	`ap = bro(arglist);`
		944	`retcell(arglist);`
2	7u83	945	`arglist = ap;`
		946	`}`
		947	`}`
		948
		949	`/************************************************************************`
		950	`* safe_arg`
		951	`*`
		952	`* insert run-time checks on this argument - see safe_eval`
		953	`*`
		954	`* Parameters:`
		955	`* e argument to be tested`
		956	`* esc label: jump to this if e is:`
		957	`* pointer and nil`
		958	`* numeric and zero`
		959	`************************************************************************/`
		960
6	7u83	961	`static exp`
		962	`safe_arg(exp e, exp esc)`
2	7u83	963	`{`
6	7u83	964	`exp decl = getexp(sh(e), nilexp, 0, e, nilexp,`
2	7u83	965	`0, 0, ident_tag);`
		966	`exp v1, v2, z, s, konst, tst;`
		967
		968	`/* make the unsafe value for this shape */`
6	7u83	969	`switch (name(sh(e))) {`
2	7u83	970	`case ptrhd:`
		971	`konst = me_null(sh(e), ptr_null, null_tag);`
		972	`break;`
		973	`case scharhd:`
		974	`case ucharhd:`
		975	`case swordhd:`
		976	`case uwordhd:`
		977	`case slonghd:`
		978	`case ulonghd:`
		979	`case s64hd:`
		980	`case u64hd:`
6	7u83	981	`konst = getexp(sh(e), nilexp, 0, nilexp, nilexp, 0, 0, val_tag);`
2	7u83	982	`break;`
		983	`case shrealhd:`
		984	`case realhd:`
6	7u83	985	`case doublehd: {`
		986	`flpt f = new_flpt();`
2	7u83	987	`int i;`
6	7u83	988	`for (i = 0; i < MANT_SIZE; ++i) {`
2	7u83	989	`(flptnos[f].mant)[i] = 0;`
6	7u83	990	`}`
2	7u83	991	`flptnos[f].exp = 0;`
		992	`flptnos[f].sign = 0;`
6	7u83	993	`konst = getexp(sh(e), nilexp, 0, nilexp, nilexp, 0, f, real_tag);`
2	7u83	994	`break;`
6	7u83	995	`}`
2	7u83	996	`case offsethd:`
6	7u83	997	`konst = f_offset_zero(f_alignment(sh(e)));`
2	7u83	998	`break;`
6	7u83	999	`default:`
2	7u83	1000	`SET(konst);`
6	7u83	1001	`failer(BAD_SHAPE);`
2	7u83	1002	`}`
		1003
6	7u83	1004	`v1 = getexp(sh(e), nilexp, 0, decl, pt(decl), 0, 0, name_tag);`
		1005	`pt(decl) = v1;`
		1006	`++no(decl);`
		1007	`v2 = getexp(sh(e), nilexp, 1, decl, pt(decl), 0, 0, name_tag);`
		1008	`pt(decl) = v2;`
		1009	`++no(decl);`
2	7u83	1010
6	7u83	1011	`tst = getexp(f_top, nilexp, 0, v1, esc, 0,`
2	7u83	1012	`0, test_tag);`
		1013	`settest_number(tst, f_not_equal);`
6	7u83	1014	`++no(son(esc));`
		1015	`setbro(v1, konst);`
		1016	`tst = hc(tst, konst);`
2	7u83	1017
6	7u83	1018	`z = getexp(f_top, v2, 0, tst, nilexp, 0, 0, 0);`
		1019	`setbro(tst, z);`
		1020	`setlast(tst);`
		1021	`s = getexp(sh(e), decl, 1, z, nilexp, 0, 0, seq_tag);`
		1022	`setbro(e, s);`
		1023	`clearlast(e);`
		1024	`s = hc(s, v2);`
2	7u83	1025
6	7u83	1026	`return(hc(decl, s));`
2	7u83	1027	`}`
		1028
		1029
		1030	`/************************************************************************`
		1031	`* safe_eval ensure that the evaluation of e cannot fail`
		1032	`*`
		1033	`* insert run-time checks into the evaluation of this expression - this is`
		1034	`* only used when a constant is extracted from inside a conditional inside`
		1035	`* a loop. Where this happens, the extraction of the constant and its`
		1036	`* unconditional evaluation outside the loop can result in program failure`
		1037	`* when the program would not otherwise have failed.`
		1038	`* This should be called with "escape_route" as nilexp - this marks the`
		1039	`* outermost call of safe_eval, and causes the contruction of a label for`
		1040	`* the code to escape to if a "dangerous" value is encountered during`
		1041	`* evaluation of the constant. If at the end of the outermost call the label`
		1042	`* has been used, then there is a possibility of failure during evaluation`
		1043	`* and code is generated to supply a "safe" value when the label is reached.`
		1044	`*`
		1045	`* dangerous operations are:`
		1046	`* contents of NIL`
		1047	`* reffield of NIL (indirectly, when its contents are taken)`
		1048	`* division by zero (any variety; includes mod and rem)`
		1049	`* Note that checking the result of reffield for NIL is a waste of time`
		1050	`* since any offset from NIL will make the result different from NIL.`
		1051	`*`
		1052	`*`
		1053	`* Parameters:`
		1054	`* e expression being evaluated`
		1055	`* escape_route label: jump to this if evaluation would fail`
		1056	`************************************************************************/`
		1057
6	7u83	1058	`static exp`
		1059	`safe_eval(exp e, exp escape_route)`
2	7u83	1060	`{`
		1061	`exp esc_lab, res;`
		1062
		1063	`if (escape_route == nilexp) {`
		1064	`/* this is outermost call - construct escape label */`
6	7u83	1065	`exp z = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, clear_tag);`
		1066	`esc_lab = getexp(sh(e), nilexp, 0, z, nilexp,`
2	7u83	1067	`0, 0, labst_tag);`
6	7u83	1068	`} else {`
2	7u83	1069	`esc_lab = escape_route;`
6	7u83	1070	`}`
2	7u83	1071
6	7u83	1072	`switch (name(e)) {`
2	7u83	1073	`case ident_tag:`
		1074	`case cond_tag:`
		1075	`case rep_tag:`
		1076	`case solve_tag:`
6	7u83	1077	`case case_tag:`
2	7u83	1078	`SET(res);`
6	7u83	1079	`failer(CONSTC_ERROR);`
2	7u83	1080	`break;`
		1081	`case name_tag:`
		1082	`case env_offset_tag:`
		1083	`case general_env_offset_tag:`
		1084	`case real_tag:`
6	7u83	1085	`res = copy(e);`
2	7u83	1086	`break;`
		1087	`case div0_tag:`
		1088	`case div1_tag:`
		1089	`case div2_tag:`
		1090	`case fdiv_tag:`
		1091	`case mod_tag:`
		1092	`case rem2_tag:`
		1093	`case rem0_tag:`
		1094	`case offset_div_tag:`
6	7u83	1095	`case offset_div_by_int_tag: {`
		1096	`exp arg1 = safe_eval(son(e), esc_lab);`
		1097	`exp arg2 = safe_eval(bro(son(e)), esc_lab);`
		1098	`res = copyexp(e);`
		1099	`setson(res, arg1);`
		1100	`arg2 = safe_arg(arg2, esc_lab);`
		1101	`setbro(arg1, arg2);`
		1102	`clearlast(arg1);`
		1103	`res = hc(res, arg2);`
2	7u83	1104	`break;`
6	7u83	1105	`}`
		1106	`case cont_tag: {`
		1107	`exp arg = son(e);`
		1108	`if (name(arg) == name_tag &&`
		1109	`(isglob(son(arg)) \|\| isvar(son(arg))))`
		1110	`res = copy(e);`
2	7u83	1111	`else {`
6	7u83	1112	`arg = safe_eval(arg, esc_lab);`
2	7u83	1113	`if (!arg_is_reff)`
6	7u83	1114	`arg = safe_arg(arg, esc_lab);`
		1115	`res = copyexp(e);`
		1116	`setson(res, arg);`
		1117	`res = hc(res, arg);`
2	7u83	1118	`}`
		1119	`break;`
6	7u83	1120	`}`
		1121	`case reff_tag: {`
		1122	`exp arg = son(e);`
		1123	`if (name(arg) == name_tag && isglob(son(arg)))`
		1124	`res = copy(e);`
2	7u83	1125	`else {`
6	7u83	1126	`arg = safe_eval(arg, esc_lab);`
2	7u83	1127	`if (!arg_is_reff)`
6	7u83	1128	`arg = safe_arg(arg, esc_lab);`
		1129	`res = copyexp(e);`
		1130	`setson(res, arg);`
		1131	`res = hc(res, arg);`
2	7u83	1132	`}`
		1133	`break;`
6	7u83	1134	`}`
		1135	`default: {`
		1136	`exp k = copyexp(e);`
		1137	`exp arg = son(e);`
2	7u83	1138	`exp p;`
		1139	`if (arg == nilexp) {`
		1140	`res = k;`
		1141	`break;`
		1142	`}`
6	7u83	1143	`p = safe_eval(arg, esc_lab);`
		1144	`setson(k, p);`
		1145	`while (!last(arg)) {`
		1146	`exp safe = safe_eval(bro(arg), esc_lab);`
		1147	`setbro(p, safe);`
		1148	`clearlast(p);`
		1149	`p = bro(p);`
		1150	`arg = bro(arg);`
2	7u83	1151	`}`
6	7u83	1152	`res = hc(k, p);`
2	7u83	1153	`break;`
		1154	`}`
6	7u83	1155	`}`
2	7u83	1156
6	7u83	1157	`arg_is_reff = (name(e) == reff_tag);`
		1158	`if (escape_route != nilexp) {`
2	7u83	1159	`return (res); /* this was an inner call */`
6	7u83	1160	`}`
2	7u83	1161
6	7u83	1162	`if (no(son(esc_lab)) == 0) {`
2	7u83	1163	`/* the escape route is not used - inherently safe */`
6	7u83	1164	`retcell(son(esc_lab));`
		1165	`retcell(esc_lab);`
		1166	`return(res);`
2	7u83	1167	`} else {`
		1168	`/* the escape route was used - construct conditional */`
6	7u83	1169	`exp cond = getexp(sh(e), nilexp, 0, res, nilexp,`
2	7u83	1170	`0, 0, cond_tag);`
		1171	`exp safe;`
6	7u83	1172	`safe = getexp(sh(e), nilexp, 1, nilexp, nilexp,`
2	7u83	1173	`0, 0, clear_tag);`
6	7u83	1174	`setbro(son(esc_lab), safe);`
		1175	`IGNORE hc(esc_lab, safe);`
		1176	`setbro(res, esc_lab);`
		1177	`clearlast(res);`
		1178	`IGNORE hc(cond, esc_lab);`
		1179	`return(cond);`
2	7u83	1180	`}`
		1181	`}`
		1182
		1183
		1184	`/************************************************************************`
		1185	`* extract_consts`
		1186	`*`
		1187	`* Parameters:`
		1188	`* issn loop is son(rf) else bro(rf)`
		1189	`* rf EXP holding loop`
		1190	`* list_head exp containing list of constant expressions`
		1191	`* this must not be empty`
		1192	`************************************************************************/`
		1193
6	7u83	1194	`static void`
		1195	`look_for_caonly(exp e)`
2	7u83	1196	`{`
		1197	`if (name(e) == name_tag) {`
6	7u83	1198	`if (isvar(son(e))) {`
2	7u83	1199	`clearcaonly(son(e));`
6	7u83	1200	`}`
2	7u83	1201	`return;`
		1202	`}`
6	7u83	1203	`if (name(e) == addptr_tag) {`
2	7u83	1204	`look_for_caonly(son(e));`
6	7u83	1205	`}`
		1206	`if (name(e) == seq_tag \|\| name(e) == ident_tag) {`
2	7u83	1207	`look_for_caonly(bro(son(e)));`
6	7u83	1208	`}`
2	7u83	1209	`return;`
		1210	`}`
		1211
6	7u83	1212
		1213	`static int`
		1214	`extract_consts(int issn, exp rf, exp list_head)`
2	7u83	1215	`{`
		1216	`exp val;`
		1217	`int changed = 0; /* result; will be true if we make a change */`
6	7u83	1218	`exp t = son(list_head); /* first in list */`
2	7u83	1219	`exp limit = pt (list_head); /* last in list */`
		1220	`int contin = true;`
		1221
		1222	`do {`
6	7u83	1223	`if (issn) {`
		1224	`val = son(rf);`
		1225	`} else {`
		1226	`val = bro(rf);`
		1227	`}`
		1228	`if (no(t) != 0) {`
		1229	`/* this has been dealt with previously - just * check for end */`
2	7u83	1230	`contin = (t != limit);`
6	7u83	1231	`} else {`
2	7u83	1232	`/* this has not been absorbed by a previous constant */`
		1233
		1234	`exp e;`
		1235	`int force = 0;`
		1236
6	7u83	1237	`if (pt(t) == nilexp) {`
2	7u83	1238	`/* simple constant - no brothers */`
		1239	`exp f;`
6	7u83	1240	`e = son(t);`
		1241	`f = father(e);`
2	7u83	1242
		1243
		1244
		1245	`/* ?????????????????? */`
6	7u83	1246	`if (!last(e) && last(bro(e)) && (name(f) == ident_tag) && !isvar(f)) {`
2	7u83	1247	`/* this is an in-register constant declaration */`
		1248	`/* so remove the force register bit from f so */`
		1249	`/* that it becomes a simple renaming */`
6	7u83	1250	`clearusereg(f);`
2	7u83	1251	`/* and set the force register bit for the */`
		1252	`/* outer declaration */`
		1253	`force = 1;`
		1254	`}`
		1255	`#ifdef NEWDIAGS`
		1256	`e = copy_dg_separate (e); /* original may remain in use */`
		1257	`#else`
6	7u83	1258	`e = copy(e);`
2	7u83	1259	`#endif`
		1260	`/* so son(t) can be killed or used in declaration */`
		1261	`} else {`
		1262	`/* the next few consts are args of the same operator */`
6	7u83	1263	`exp op = pt(t), new_c, prev = nilexp, c_arg = nilexp, t2 = t;`
2	7u83	1264	`int scan = true;`
		1265
6	7u83	1266	`new_c = copyexp(op);`
2	7u83	1267
		1268	`while (scan) {`
6	7u83	1269	`if (no(t2) == 0 && pt(t2) == op) {`
2	7u83	1270	`#ifdef NEWDIAGS`
6	7u83	1271	`c_arg = copy_dg_separate(son(t2));`
2	7u83	1272	`/* original may remain in use */`
		1273	`#else`
6	7u83	1274	`c_arg = copy(son(t2));`
2	7u83	1275	`#endif`
6	7u83	1276	`if (prev == nilexp) {`
		1277	`son(new_c) = c_arg;`
		1278	`} else {`
		1279	`bro(prev) = c_arg;`
		1280	`clearlast(prev);`
2	7u83	1281	`}`
		1282	`prev = c_arg;`
		1283	`}`
6	7u83	1284	`if (t2 == limit) {`
2	7u83	1285	`scan = false;`
6	7u83	1286	`} else {`
		1287	`t2 = bro(t2);`
		1288	`}`
2	7u83	1289	`}`
		1290
6	7u83	1291	`e = hc(new_c, c_arg);`
2	7u83	1292	`}`
		1293
6	7u83	1294	`if (is_worth(e)) {`
2	7u83	1295	`/* declare new constant */`
		1296	`exp konst;`
		1297	`exp newdec;`
		1298	`int kill_e = false;`
		1299	`#ifdef NEWDIAGS`
6	7u83	1300	`if (diagnose) {`
		1301	`strip_dg_context(e);`
		1302	`}`
2	7u83	1303	`#endif`
6	7u83	1304	`if (props(t) > 1) {`
2	7u83	1305	`/* this const. is in a conditional in the loop */`
		1306	`/* ensure that extraction from loop does not cause a failure */`
		1307	`kill_e = true;`
6	7u83	1308	`konst = safe_eval(e, nilexp);`
		1309	`} else {`
2	7u83	1310	`konst = e;`
6	7u83	1311	`}`
		1312	`newdec = getexp(sh(val), bro(val),`
		1313	`(int)(last(val)), konst, nilexp, 0, 0, ident_tag);`
		1314	`if (has_lj_dest) {`
2	7u83	1315	`setvis(newdec);`
6	7u83	1316	`}`
		1317	`if (force && isvis(father(e))) {`
2	7u83	1318	`setvis(newdec);`
6	7u83	1319	`} else if (force \|\| ismips)`
		1320	`setusereg(newdec);`
2	7u83	1321
6	7u83	1322	`if (name(sh(konst)) == ptrhd) {`
2	7u83	1323	`look_for_caonly(konst);`
6	7u83	1324	`}`
2	7u83	1325
6	7u83	1326	`bro(konst) = val;`
		1327	`clearlast(konst);`
		1328	`bro(val) = newdec;`
		1329	`setlast(val);`
		1330	`if (issn) {`
		1331	`son(rf) = newdec;`
		1332	`} else {`
		1333	`bro(rf) = newdec;`
		1334	`}`
2	7u83	1335
		1336	`#ifdef NEWDIAGS`
		1337	`if (diagnose) {`
6	7u83	1338	`make_optim_dg(DGD_EXTRACT, newdec);`
2	7u83	1339	`}`
		1340	`#endif`
6	7u83	1341	`do_this_k(newdec, e, t, limit);`
		1342	`if (kill_e) {`
		1343	`kill_exp(e, e);`
		1344	`}`
2	7u83	1345	`changed = 1; /* have made a change */`
6	7u83	1346	`} else {`
		1347	`kill_exp(e, e);`
		1348	`}`
2	7u83	1349	`}`
		1350
6	7u83	1351	`if (t == limit) {`
		1352	`/* that was the last in the list */`
2	7u83	1353	`contin = false;`
6	7u83	1354	`} else {`
		1355	`exp n = bro(t);`
		1356	`retcell(t);`
2	7u83	1357	`t = n;`
		1358	`}`
6	7u83	1359	`} while (contin);`
2	7u83	1360
6	7u83	1361	`retcell(t);`
2	7u83	1362
6	7u83	1363	`retcell(list_head);`
		1364	`return(changed);`
2	7u83	1365	`}`
		1366
		1367
		1368	`/************************************************************************`
		1369	`* assigns_alias`
		1370	`*`
		1371	`* scans e - returns true if any aliased variables are assigned to`
		1372	`*`
		1373	`*`
		1374	`************************************************************************/`
		1375
6	7u83	1376	`int named_dest(exp dest);`
		1377
		1378	`int`
		1379	`named_dest(exp dest)`
2	7u83	1380	`{`
6	7u83	1381	`switch (name(dest)) {`
		1382	`case name_tag:`
		1383	`if (isvar(son(dest))) {`
		1384	`if (iscaonly(son(dest))) {`
2	7u83	1385	`return true;`
6	7u83	1386	`}`
2	7u83	1387	`if (isglob(son(dest))) {`
6	7u83	1388	`if (find_glob(son(dest))) {`
2	7u83	1389	`return true;`
6	7u83	1390	`}`
		1391	`if (glob_index == globmax) {`
2	7u83	1392	`return false;`
6	7u83	1393	`}`
2	7u83	1394	`glob_dest[glob_index++] = son(dest);`
		1395	`return true;`
6	7u83	1396	`}`
		1397	`} else if (!isvar(son(dest)) && son(son(dest)) != nilexp) {`
		1398	`return named_dest(son(son(dest)));`
2	7u83	1399	`}`
		1400	`return false;`
		1401	`case addptr_tag:`
6	7u83	1402	`case reff_tag:`
2	7u83	1403	`/* Should we look at bro son to see if it contains an assignment ??? */`
		1404	`return false;`
		1405	`default:`
		1406	`return false;`
		1407	`}`
		1408	`}`
		1409
6	7u83	1410	`int`
		1411	`assigns_alias(exp e)`
2	7u83	1412	`{`
6	7u83	1413	`switch (name(e)) {`
2	7u83	1414	`case assvol_tag:`
6	7u83	1415	`case ass_tag: {`
		1416	`exp dest = son(e);`
2	7u83	1417
6	7u83	1418	`if (!named_dest(son(e))) {`
		1419	`/* LHS may be aliassed */`
		1420	`return(true);`
		1421	`} else {`
		1422	`/* check RHS for assignments */`
		1423	`return(assigns_alias(bro(dest)));`
		1424	`}`
2	7u83	1425	`}`
		1426
		1427	`case name_tag:`
		1428	`case env_offset_tag:`
		1429	`case general_env_offset_tag:`
6	7u83	1430	`return(false);`
2	7u83	1431
		1432	`case case_tag:`
6	7u83	1433	`return(assigns_alias(son(e)));`
2	7u83	1434	`/* NB - must only look at first son */`
		1435
		1436	`case bfass_tag:`
		1437	`case apply_tag:`
		1438	`return (true); /* pessimist! */`
		1439
6	7u83	1440	`default: {`
2	7u83	1441	`int aa = false;`
6	7u83	1442	`exp s = son(e);`
2	7u83	1443
		1444	`while ((s != nilexp) && !aa) {`
6	7u83	1445	`aa = assigns_alias(s);`
		1446	`if (aa \|\| last(s))`
2	7u83	1447	`s = nilexp;`
		1448	`else`
6	7u83	1449	`s = bro(s);`
2	7u83	1450	`}`
		1451
6	7u83	1452	`return(aa);`
2	7u83	1453	`}`
6	7u83	1454	`}`
2	7u83	1455	`}`
		1456
6	7u83	1457
2	7u83	1458	`/************************************************************************`
		1459	`* scan_for_lv`
		1460	`*`
		1461	`* scans e - returns true if any label may be long jump destination`
		1462	`*`
		1463	`*`
		1464	`************************************************************************/`
		1465
6	7u83	1466	`static int`
		1467	`scan_for_lv(exp e)`
2	7u83	1468	`{`
6	7u83	1469	`switch (name(e)) {`
2	7u83	1470	`case make_lv_tag:`
6	7u83	1471	`return(true);`
2	7u83	1472
		1473	`case name_tag:`
		1474	`case env_offset_tag:`
		1475	`case general_env_offset_tag:`
6	7u83	1476	`return(false);`
2	7u83	1477
6	7u83	1478	`default: {`
2	7u83	1479	`int aa = false;`
6	7u83	1480	`exp s = son(e);`
2	7u83	1481
		1482	`while ((s != nilexp) && !aa) {`
6	7u83	1483	`aa = scan_for_lv(s);`
		1484	`if (aa \|\| last(s)) {`
2	7u83	1485	`s = nilexp;`
6	7u83	1486	`} else {`
		1487	`s = bro(s);`
		1488	`}`
2	7u83	1489	`}`
		1490
6	7u83	1491	`return(aa);`
2	7u83	1492	`}`
6	7u83	1493	`}`
2	7u83	1494	`}`
		1495
		1496
		1497	`/************************************************************************`
		1498	`* repeat_consts`
		1499	`*`
		1500	`* calls extract_consts on each element of the list of repeat loops`
		1501	`************************************************************************/`
		1502
6	7u83	1503	`void`
		1504	`repeat_consts(void)`
2	7u83	1505	`{`
6	7u83	1506	`exp reps = get_repeats();`
2	7u83	1507
		1508	`while (reps != nilexp) {`
6	7u83	1509	`if (son(reps) != nilexp && name(son(reps)) == rep_tag`
		1510	`&& no(reps) < max_loop_depth) {`
		1511	`exp loop = son(reps);`
		1512	`exp sts = bro(son(loop));`
2	7u83	1513	`int no_alias;`
		1514	`maxconst mx;`
		1515	`exp consts;`
		1516
		1517	`/* put old identifier memory list into its free list */`
		1518	`memlist **mptr = &mem;`
		1519
		1520	`glob_index = 0;`
6	7u83	1521	`no_alias = !assigns_alias(sts);`
		1522	`while (*mptr != nilmem) {`
		1523	`mptr = & ((*mptr) ->next);`
		1524	`}`
2	7u83	1525	`*mptr = fmem;`
		1526	`fmem = mem;`
		1527	`mem = nilmem;`
		1528
6	7u83	1529	`mx = mc_list(loop, sts, no_alias, false);`
2	7u83	1530
		1531	`consts = mx.cont;`
		1532	`/* NB - false forces a list to be produced */`
		1533
6	7u83	1534	`if (no_alias) {`
2	7u83	1535	`set_noalias (reps); /* preserve for forall processing */`
6	7u83	1536	`}`
2	7u83	1537
		1538	`if (consts != nilexp) {`
		1539	`exp rr;`
		1540	`int sn;`
6	7u83	1541	`exp fa = father(loop);`
		1542	`if (son(fa) == loop) {`
2	7u83	1543	`sn = 1;`
		1544	`rr = fa;`
		1545	`} else {`
		1546	`sn = 0;`
6	7u83	1547	`rr = son(fa);`
		1548	`while (bro(rr) != loop && !last(rr)) {`
		1549	`rr = bro(rr);`
		1550	`}`
		1551	`}`
		1552	`if (sn \|\| bro(rr) == loop) {`
		1553	`while (name(fa) != proc_tag && name(fa) != general_proc_tag &&`
		1554	`name(fa) != hold_tag && name(fa) != hold2_tag) {`
2	7u83	1555	`fa = father(fa);`
6	7u83	1556	`}`
2	7u83	1557	`if (name(fa) != hold_tag && name(fa) != hold2_tag) {`
6	7u83	1558	`if (proc_uses_crt_env(fa)) {`
		1559	`has_lj_dest = scan_for_lv(sts);`
		1560	`} else {`
2	7u83	1561	`has_lj_dest = 0;`
6	7u83	1562	`}`
		1563	`IGNORE extract_consts(sn, rr, consts);`
2	7u83	1564	`}`
		1565	`}`
		1566	`}`
		1567	`}`
6	7u83	1568	`reps = pt(reps);`
2	7u83	1569	`}`
		1570	`}`
		1571
		1572
		1573	`/************************************************************************`
		1574	`* get_repeats`
		1575	`*`
		1576	`* calculates maximum distance of every repeat from a leaf node`
		1577	`* (this allows repeat processing to be restricted to inner loops)`
		1578	`* returns the repeat_list`
		1579	`************************************************************************/`
		1580
6	7u83	1581	`exp`
		1582	`get_repeats(void)`
2	7u83	1583	`{`
6	7u83	1584	`if (repeat_list != nilexp && !is_dist(repeat_list)) {`
2	7u83	1585	`exp reps = repeat_list;`
		1586
		1587	`while (reps != nilexp) {`
6	7u83	1588	`if (no(reps) == 0) {`
2	7u83	1589	`/* this is a leaf node */`
		1590	`/* no(x) is used in dexp to count directly nested loops */`
		1591	`int dist = 0;`
		1592	`exp sup = reps;`
		1593	`do {`
		1594	`set_dist (sup); /* no(x) is now max dist to leaf */`
6	7u83	1595	`no(sup) = dist;`
		1596	`if (son(sup) != nilexp && name(son(sup)) == rep_tag) {`
2	7u83	1597	`++dist; /* only repeats are significant */`
6	7u83	1598	`}`
		1599	`sup = bro(sup); /* go to enclosing repeat */`
		1600	`} while (sup != nilexp && (!is_dist(sup) \|\| no(sup) < dist));`
2	7u83	1601	`}`
6	7u83	1602	`reps = pt(reps);`
2	7u83	1603	`}`
		1604	`}`
6	7u83	1605	`return(repeat_list);`
2	7u83	1606	`}`
		1607
		1608
		1609	`/************************************************************************`
		1610	`* return_repeats`
		1611	`*`
		1612	`* returns the storage used by repeat_list`
		1613	`************************************************************************/`
		1614
6	7u83	1615	`void`
		1616	`return_repeats(void)`
2	7u83	1617	`{`
		1618	`exp reps = repeat_list;`
		1619
		1620	`while (reps != nilexp) {`
6	7u83	1621	`exp next = pt(reps);`
		1622	`retcell(reps);`
2	7u83	1623	`reps = next;`
		1624	`}`
		1625	`repeat_list = nilexp;`
		1626	`}`

Subversion Repositories tendra.SVN

(root)/branches/tendra5-amd64/src/installers/common/construct/const.c – Rev 123