WebSVN – tendra.SVN – Blame – /branches/tendra5/src/installers/common/diag/dg_aux.c

Rev	Author	Line No.	Line
2	7u83	1	`/*`
		2	`Crown Copyright (c) 1997`
		3
		4	`This TenDRA(r) Computer Program is subject to Copyright`
		5	`owned by the United Kingdom Secretary of State for Defence`
		6	`acting through the Defence Evaluation and Research Agency`
		7	`(DERA). It is made available to Recipients with a`
		8	`royalty-free licence for its use, reproduction, transfer`
		9	`to other parties and amendment for any purpose not excluding`
		10	`product development provided that any such use et cetera`
		11	`shall be deemed to be acceptance of the following conditions:-`
		12
		13	`(1) Its Recipients shall ensure that this Notice is`
		14	`reproduced upon any copies or amended versions of it;`
		15
		16	`(2) Any amended version of it shall be clearly marked to`
		17	`show both the nature of and the organisation responsible`
		18	`for the relevant amendment or amendments;`
		19
		20	`(3) Its onward transfer from a recipient to another`
		21	`party shall be deemed to be that party's acceptance of`
		22	`these conditions;`
		23
		24	`(4) DERA gives no warranty or assurance as to its`
		25	`quality or suitability for any purpose and DERA accepts`
		26	`no liability whatsoever in relation to any use to which`
		27	`it may be put.`
		28	`*/`
		29
		30
		31	`/**********************************************************************`
		32	$Author: release $
		33	$Date: 1998/03/17 16:54:17 $
		34	$Revision: 1.6 $
		35	$Log: dg_aux.c,v $
		36	`* Revision 1.6 1998/03/17 16:54:17 release`
		37	`* Couple of minor fixes.`
		38	`*`
		39	`* Revision 1.5 1998/03/17 16:34:58 pwe`
		40	`* correction for non-NEWDIAGS`
		41	`*`
		42	`* Revision 1.4 1998/03/15 16:00:29 pwe`
		43	`* regtrack dwarf dagnostics added`
		44	`*`
		45	`* Revision 1.3 1998/03/11 11:03:28 pwe`
		46	`* DWARF optimisation info`
		47	`*`
		48	`* Revision 1.2 1998/02/18 11:22:13 pwe`
		49	`* test corrections`
		50	`*`
		51	`* Revision 1.1.1.1 1998/01/17 15:55:46 release`
		52	`* First version to be checked into rolling release.`
		53	`*`
		54	`* Revision 1.8 1998/01/11 18:44:46 pwe`
		55	`* consistent new/old diags`
		56	`*`
		57	`* Revision 1.7 1998/01/09 09:29:40 pwe`
		58	`* prep restructure`
		59	`*`
		60	`* Revision 1.6 1997/12/04 19:36:13 pwe`
		61	`* ANDF-DE V1.9`
		62	`*`
		63	`* Revision 1.5 1997/11/06 09:17:33 pwe`
		64	`* ANDF-DE V1.8`
		65	`*`
		66	`* Revision 1.4 1997/10/28 10:12:26 pwe`
		67	`* local location support`
		68	`*`
		69	`* Revision 1.3 1997/10/23 09:20:57 pwe`
		70	`* ANDF-DE V1.7 and extra diags`
		71	`*`
		72	`* Revision 1.2 1997/10/10 18:16:33 pwe`
		73	`* prep ANDF-DE revision`
		74	`*`
		75	`* Revision 1.1 1997/08/23 13:26:36 pwe`
		76	`* initial ANDF-DE`
		77	`*`
		78	`***********************************************************************/`
		79
		80
		81	`#include "config.h"`
		82	`#include "common_types.h"`
		83	`#include "basicread.h"`
		84	`#include "xalloc.h"`
		85	`#include "sortmacs.h"`
		86	`#include "expmacs.h"`
		87	`#include "tags.h"`
		88	`#include "externs.h"`
		89	`#include "check.h"`
		90	`#include "exp.h"`
		91	`#include "me_fns.h"`
		92	`#include "table_fns.h"`
		93	`#include "flags.h"`
		94	`#include "const.h"`
		95	`#include "dg_aux.h"`
		96	`#include "dg_globs.h"`
		97
		98
		99	`#ifndef NEWDIAGS`
		100	`#define isdiaginfo(e) 0`
		101	`#define setisdiaginfo(e)`
		102	`#define isdiscarded(e) 0`
		103	`#define setisdiscarded(e)`
		104	`#else`
		105	`static int clean_copy = 0; /* set by copy_dg_separate */`
		106	`#endif`
		107
		108
		109	`int doing_inlining = 0;`
		110
		111	`dg_info current_dg_info = (dg_info)0; /* needed when coding extra_diags */`
		112	`exp current_dg_exp = nilexp; /* needed when coding extra_diags */`
		113
		114	`short_sourcepos no_short_sourcepos;`
		115
		116
		117
		118	`#define DG_CLUMP_SIZE 50 /* Generate a clump of dg_name etc together */`
		119	`#define FILE_CLUMP_SIZE 5`
		120
		121
		122	`typedef union /* These have similar size */`
		123	`{`
		124	`struct dg_name_t nam;`
		125	`struct dg_type_t typ;`
		126	`struct dg_info_t inf;`
		127	`struct dg_more_t mor;`
		128	`} dg_union;`
		129
		130	`static int dg_clump_left = 0;`
		131	`static dg_union * next_dg;`
		132
		133	`static void make_dg_clump`
		134	`PROTO_Z ()`
		135	`{`
		136	`next_dg = (dg_union *) xcalloc (DG_CLUMP_SIZE, sizeof (dg_union));`
		137	`dg_clump_left = DG_CLUMP_SIZE;`
		138	`return;`
		139	`}`
		140
		141	`dg_name new_dg_name`
		142	`PROTO_N ( (k) )`
		143	`PROTO_T ( dg_name_key k )`
		144	`{`
		145	`dg_name ans;`
		146	`if (!dg_clump_left) make_dg_clump();`
		147	`dg_clump_left --;`
		148	`ans = &((next_dg ++)->nam);`
		149	`ans->key = k;`
		150	`ans->mor = (dg_more_name)0;`
		151	`ans->next = (dg_name)0;`
		152	`return ans;`
		153	`}`
		154
		155	`dg_type new_dg_type`
		156	`PROTO_N ( (k) )`
		157	`PROTO_T ( dg_type_key k )`
		158	`{`
		159	`dg_type ans;`
		160	`if (!dg_clump_left) make_dg_clump();`
		161	`dg_clump_left --;`
		162	`ans = &((next_dg ++)->typ);`
		163	`ans->key = k;`
		164	`ans->outref.k = NO_LAB;`
		165	`ans->mor = (dg_more_name)0;`
		166	`return ans;`
		167	`}`
		168
		169	`dg_info new_dg_info`
		170	`PROTO_N ( (k) )`
		171	`PROTO_T ( dg_info_key k )`
		172	`{`
		173	`dg_info ans;`
		174	`if (!dg_clump_left) make_dg_clump();`
		175	`dg_clump_left --;`
		176	`ans = &((next_dg ++)->inf);`
		177	`ans->key = k;`
		178	`ans->this_tag = (dg_tag)0;`
		179	`ans->more = (dg_info)0;`
		180	`return ans;`
		181	`}`
		182
		183	`void extend_dg_name`
		184	`PROTO_N ( (nm) )`
		185	`PROTO_T ( dg_name nm )`
		186	`{`
		187	`dg_more_name mor;`
		188	`if (!dg_clump_left) make_dg_clump();`
		189	`dg_clump_left --;`
		190	`nm->mor = mor = &((next_dg ++)->mor);`
		191	`mor->this_tag = (dg_tag)0;`
		192	`mor->inline_ref = (dg_tag)0;`
		193	`mor->refspec = (dg_tag)0;`
		194	`mor->elabn = (dg_tag)0;`
		195	`mor->exptns = no_dg_type_list_option;`
		196	`mor->end_pos = no_short_sourcepos;`
		197	`mor->en_family = (dg_dim *)0;`
		198	`mor->vslot = nilexp;`
		199	`mor->repn = nilexp;`
		200	`mor->acc = DG_ACC_NONE;`
		201	`mor->virt = DG_VIRT_NONE;`
		202	`mor->isinline = 0;`
		203	`mor->prognm = 0;`
		204	`mor->isconst = 0;`
		205	`mor->isspec = 0;`
		206	`mor->issep = 0;`
		207	`mor->isnew = 0;`
		208	`mor->aderiv = 0;`
		209	`return;`
		210	`}`
		211
		212	`void extend_dg_type`
		213	`PROTO_N ( (tp) )`
		214	`PROTO_T ( dg_type tp )`
		215	`{`
		216	`dg_more_name mor;`
		217	`if (!dg_clump_left) make_dg_clump();`
		218	`dg_clump_left --;`
		219	`tp->mor = mor = &((next_dg ++)->mor);`
		220	`mor->this_tag = (dg_tag)0;`
		221	`mor->inline_ref = (dg_tag)0;`
		222	`mor->refspec = (dg_tag)0;`
		223	`mor->elabn = (dg_tag)0;`
		224	`mor->acc = DG_ACC_NONE;`
		225	`mor->virt = DG_VIRT_NONE;`
		226	`mor->isinline = 0;`
		227	`mor->prognm = 0;`
		228	`mor->isconst = 0;`
		229	`mor->isspec = 0;`
		230	`mor->isnew = 0;`
		231	`mor->aderiv = 0;`
		232	`return;`
		233	`}`
		234
		235	`void init_dgtag`
		236	`PROTO_N ( (tg) )`
		237	`PROTO_T ( dg_tag tg )`
		238	`{`
		239	`tg->key = DGK_NONE;`
		240	`tg->done = 0;`
		241	`tg->needed = 0;`
		242	`tg->any_inl = 0;`
		243	`tg->outref.k = NO_LAB;`
		244	`tg->abstract_lab = (long)0;`
		245	`tg->copy = (dg_tag)0;`
		246	`return;`
		247	`}`
		248
		249	`dg_tag gen_tg_tag`
		250	`PROTO_Z ()`
		251	`{`
		252	`dg_tag tg = (dgtag_struct *) xcalloc (1, sizeof (dgtag_struct));`
		253	`init_dgtag (tg);`
		254	`return tg;`
		255	`}`
		256
		257
		258
		259	`/* The following avoids repetitions of pointers and other qualified types */`
		260
		261	`dg_type get_qual_dg_type`
		262	`PROTO_N ( (qual, typ) )`
		263	`PROTO_T ( dg_qual_type_key qual X dg_type typ )`
		264	`{`
		265	`static dg_type qual_type_list [N_DG_QUAL_TYPES] = { (dg_type)0 };`
		266	`dg_type ans = qual_type_list[qual];`
		267	`while (ans) {`
		268	`if (ans->data.t_qual.typ == typ)`
		269	`return ans;`
		270	`ans = ans->data.t_qual.another;`
		271	`}`
		272	`ans = new_dg_type(DGT_QUAL);`
		273	`ans->data.t_qual.q_key = qual;`
		274	`ans->data.t_qual.typ = typ;`
		275	`ans->data.t_qual.another = qual_type_list[qual];`
		276	`qual_type_list[qual] = ans;`
		277	`return ans;`
		278	`}`
		279
		280	`/* The following avoids repetitions of bitfield types */`
		281
		282	`dg_type get_dg_bitfield_type`
		283	`PROTO_N ( (typ, sha, bv) )`
		284	`PROTO_T ( dg_type typ X shape sha X bitfield_variety bv )`
		285	`{`
		286	`static dg_type bf_list = (dg_type)0;`
		287	`dg_type ans = bf_list;`
		288	`while (ans) {`
		289	`if (ans->data.t_bitf.expanded == typ &&`
		290	`ans->data.t_bitf.bv.bits == bv.bits &&`
		291	`ans->data.t_bitf.bv.has_sign == bv.has_sign )`
		292	`return ans;`
		293	`ans = ans->data.t_bitf.another;`
		294	`}`
		295	`ans = new_dg_type(DGT_BITF);`
		296	`ans->data.t_bitf.expanded = typ;`
		297	`ans->data.t_bitf.sha = sha;`
		298	`ans->data.t_bitf.bv = bv;`
		299	`ans->data.t_bitf.another = bf_list;`
		300	`bf_list = ans;`
		301	`return ans;`
		302	`}`
		303
		304	`/* All other types are either unlikely to be repeated, or are rare */`
		305
		306
		307	`/* dg_idname is overkill for many purposes - we just want a string */`
		308
		309	`char * idname_chars`
		310	`PROTO_N ( (nam) )`
		311	`PROTO_T ( dg_idname nam )`
		312	`{`
		313	`static char * empty = "";`
		314	`switch (nam.id_key) {`
		315	`case DG_ID_INST: failer ("inappropriate dg_instance_idname"); return empty;`
		316	`case DG_ID_NONE: return empty;`
		317	`default: return nam.idd.nam;`
		318	`}`
		319	`}`
		320
		321
		322	`/* Avoid repetition of files */`
		323
		324	`dg_filename get_filename`
		325	`PROTO_N ( (dat, host, path, nam) )`
		326	`PROTO_T ( long dat X char * host X char * path X char * nam )`
		327	`{`
		328	`static dg_filename next_file = (dg_filename)0;`
		329	`static int filespace_left = 0;`
		330
		331	`dg_filename ans = all_files;`
		332	`while (ans) {`
		333	`if (ans->file_dat == dat &&`
		334	`!strcmp (ans->file_host, host) &&`
		335	`!strcmp (ans->file_path, path) &&`
		336	`!strcmp (ans->file_name, nam) )`
		337	`return ans;`
		338	`ans = ans->another;`
		339	`}`
		340
		341	`if (!filespace_left) {`
		342	`next_file = (dg_filename) xcalloc (FILE_CLUMP_SIZE, sizeof (struct file_t));`
		343	`filespace_left = FILE_CLUMP_SIZE;`
		344	`}`
		345	`filespace_left --;`
		346	`ans = (next_file ++);`
		347	`ans->file_dat = dat;`
		348	`ans->file_host = host;`
		349	`ans->file_path = path;`
		350	`ans->file_name = nam;`
		351	`ans->another = all_files;`
		352	`all_files = ans;`
		353	`return ans;`
		354	`}`
		355
		356
		357	`short_sourcepos shorten_sourcepos`
		358	`PROTO_N ( (pos) )`
		359	`PROTO_T ( dg_sourcepos pos )`
		360	`{`
		361	`short_sourcepos ans;`
		362	`switch (pos.sp_key) {`
		363	`case SP_SHORT:`
		364	`case SP_SPAN: {`
		365	`ans.file = pos.file;`
		366	`ans.line = pos.from_line;`
		367	`ans.column = pos.from_column;`
		368	`break;`
		369	`}`
		370	`case SP_FILE: {`
		371	`ans.file = pos.file;`
		372	`ans.line = 0;`
		373	`ans.column = 0;`
		374	`break;`
		375	`}`
		376	`default: {`
		377	`ans.file = (dg_filename)0;`
		378	`ans.line = 0;`
		379	`ans.column = 0;`
		380	`}`
		381	`}`
		382	`return ans;`
		383	`}`
		384
		385	`short_sourcepos end_sourcepos`
		386	`PROTO_N ( (pos) )`
		387	`PROTO_T ( dg_sourcepos pos )`
		388	`{`
		389	`short_sourcepos ans;`
		390	`if (pos.sp_key == SP_SPAN) {`
		391	`ans.file = pos.to_file;`
		392	`ans.line = pos.to_line;`
		393	`ans.column = pos.to_column;`
		394	`}`
		395	`else {`
		396	`ans.file = (dg_filename)0;`
		397	`ans.line = 0;`
		398	`ans.column = 0;`
		399	`}`
		400	`return ans;`
		401	`}`
		402
		403
		404	`dg_type find_proc_type`
		405	`PROTO_N ( (t) )`
		406	`PROTO_T ( dg_type t )`
		407	`{`
		408	`if (t && t->key == DGT_PROC)`
		409	`return t;`
		410	`if (t && t->key == DGT_TAGGED) {`
		411	`dg_tag tg = t->data.t_tag;`
		412	`if (tg->key == DGK_TYPE)`
		413	`return find_proc_type (tg->p.typ);`
		414	`if (tg->key == DGK_NAME) {`
		415	`dg_name ref_n = tg->p.nam;`
		416	`if (ref_n->key == DGN_TYPE)`
		417	`return find_proc_type (ref_n->data.n_typ.raw);`
		418	`}`
		419	`}`
		420	`failer ("proc type details unavailable");`
		421	`return f_dg_proc_type (new_dg_param_list (0), f_dg_void_type,`
		422	`no_bool_option, no_nat_option, no_nat_option,`
		423	`no_procprops_option);`
		424	`}`
		425
		426
		427
		428
		429	`static void scan_diag_names`
		430	`PROTO_N ( (e, whole) )`
		431	`PROTO_T ( exp e X exp whole )`
		432	`{`
		433	`if (name (e) == name_tag) {`
		434	`exp id = son(e);`
		435	`if (!isdiaginfo (e) && !internal_to (whole, id)) {`
		436	`setisdiaginfo (e);`
		437	`-- no(id);`
		438	`}`
		439	`return;`
		440	`}`
		441	`if (son(e) != nilexp && name (e) != env_offset_tag) {`
		442	`exp t = son(e);`
		443	`for (;;) {`
		444	`scan_diag_names (t, whole);`
		445	`if (last(t))`
		446	`return;`
		447	`t = bro(t);`
		448	`}`
		449	`}`
		450	`return;`
		451	`}`
		452
		453	`exp diaginfo_exp`
		454	`PROTO_N ( (e) )`
		455	`PROTO_T ( exp e )`
		456	`{`
		457	`/* mark external names to avoid influencing optimisations */`
		458	`exp ans;`
		459	`if (!e)`
		460	`return e;`
		461	`scan_diag_names (e, e);`
		462	`ans = hold (e);`
		463	`setpt (ans, nilexp);`
		464	`setbro (ans, nilexp); /* these fields are used in dwarf generation */`
		465	`no(ans) = 0;`
		466	`props(ans) = 0;`
		467	`clearlast (ans);`
		468	`IGNORE check (e, e);`
		469	`return ans;`
		470	`}`
		471
		472
		473	`#ifdef NEWDIAGS`
		474
		475	`void diag_kill_id`
		476	`PROTO_N ( (id) )`
		477	`PROTO_T ( exp id )`
		478	`{`
		479	`exp t = pt(id);`
		480	`while (t) {`
		481	`if (!isdiaginfo(t))`
		482	`failer ("bad kill ident");`
		483	`setdiscarded(t);`
		484	`t = pt(t);`
		485	`}`
		486	`son(id) = nilexp;`
		487	`return;`
		488	`}`
		489
		490
		491	`void set_obj_ref`
		492	`PROTO_N ( (nm) )`
		493	`PROTO_T ( dg_name nm )`
		494	`{ /* nm is defining reference for its obtain value */`
		495	`exp e = nm->data.n_obj.obtain_val;`
		496	`while (e && (name(e) == hold_tag \|\| name(e) == cont_tag \|\|`
		497	`name(e) == reff_tag))`
		498	`e = son(e);`
		499	`if (e && name(e) == name_tag && isglob(son(e)) &&`
		500	`!(brog(son(e))->dec_u.dec_val.diag_info))`
		501	`brog(son(e))->dec_u.dec_val.diag_info = nm;`
		502	`return;`
		503	`}`
		504
		505	`static int matched_obj`
		506	`PROTO_N ( (e, nm, refans) )`
		507	`PROTO_T ( exp e X dg_name nm X dg_tag * refans )`
		508	`{ /* e is name_tag for required object */`
		509	`exp x;`
		510	`if (nm->key != DGN_OBJECT)`
		511	`return 0;`
		512	`x = nm->data.n_obj.obtain_val;`
		513	`while (x && (name(x) == hold_tag \|\| name(x) == cont_tag \|\|`
		514	`name(x) == reff_tag))`
		515	`x = son(x);`
		516	`if ((x) && name(x) == name_tag && son(x) == son(e)) {`
		517	`if ((no(x) <= no(e)) &&`
		518	`(no(x) + shape_size(sh(x)) >= no(e) + shape_size(sh(e)) )) {`
		519	`if (!nm->mor \|\| !nm->mor->this_tag)`
		520	`IGNORE f_dg_tag_name (gen_tg_tag (), nm);`
		521	`*refans = nm->mor->this_tag;`
		522	`return 1;`
		523	`}`
		524	`}`
		525	`return 0;`
		526	`}`
		527
		528	`static int end_ref_search`
		529	`PROTO_N ( (e, d, refans) )`
		530	`PROTO_T ( exp e X dg_info d X dg_tag * refans )`
		531	`{`
		532	`dg_name pm;`
		533	`while (d && d->key != DGA_NAME && d->key != DGA_INL_CALL &&`
		534	`d->key != DGA_PARAMS)`
		535	`d = d->more;`
		536	`if (!d)`
		537	`return 0;`
		538	`if (d->more && end_ref_search (e, d->more, refans))`
		539	`return 1;`
		540	`if (d->key == DGA_NAME)`
		541	`return (matched_obj (e, d->data.i_nam.dnam, refans));`
		542	`/* otherwise inlined call or outermost proc */`
		543	`if (d->key == DGA_PARAMS)`
		544	`pm = d->data.i_param.args;`
		545	`else`
		546	`pm = d->data.i_inl.args;`
		547	`while (pm && !matched_obj (e, pm, refans))`
		548	`pm = pm->next;`
		549	`return 1; /* we don't search the caller environment */`
		550	`}`
		551
		552	`static dg_tag find_obj_ref`
		553	`PROTO_N ( (contex, e) )`
		554	`PROTO_T ( exp contex X exp e )`
		555	`{ /* e is name_tag for required object */`
		556	`dg_tag ans = (dg_tag)0;`
		557	`while ((name(contex) != ident_tag \|\| !isglob(contex)) &&`
		558	`(!dgf(contex) \|\| !end_ref_search (e, dgf(contex), &ans)))`
		559	`contex = father (contex);`
		560	`if (!ans) {`
		561	`dg_compilation cl = all_comp_units;`
		562	`while (cl) {`
		563	`dg_name dl = cl->dn_list;`
		564	`while (dl) {`
		565	`if (matched_obj (e, dl, &ans))`
		566	`return ans;`
		567	`dl = dl->next;`
		568	`}`
		569	`cl = cl->another;`
		570	`}`
		571	`}`
		572	`return ans;`
		573	`}`
		574
		575
		576
		577	`static void check_const_exp`
		578	`PROTO_N ( (e) )`
		579	`PROTO_T ( exp e )`
		580	`{`
		581	`if (!e)`
		582	`return;`
		583	`if (name(e) != hold_tag \|\| name(son(e)) != val_tag)`
		584	`failer ("diag_type may need copying");`
		585	`/* copy within type, unless all name_tags are uncopied */`
		586	`return;`
		587	`}`
		588
		589	`static void check_const_type`
		590	`PROTO_N ( (t) )`
		591	`PROTO_T ( dg_type t )`
		592	`{`
		593	`int i;`
		594	`switch (t->key) {`
		595	`case DGT_QUAL:`
		596	`check_const_type (t->data.t_qual.typ);`
		597	`break;`
		598	`case DGT_CONS:`
		599	`check_const_type (t->data.t_cons.typ);`
		600	`break;`
		601	`case DGT_ARRAY:`
		602	`check_const_type (t->data.t_arr.elem_type);`
		603	`check_const_exp (t->data.t_arr.stride);`
		604	`for (i = 0; i < t->data.t_arr.dims.len; i++) {`
		605	`dg_dim * dim = &(t->data.t_arr.dims.array[i]);`
		606	`if (dim->d_key != DG_DIM_TYPE) {`
		607	`if (!dim->low_ref)`
		608	`check_const_exp (dim->lower.x);`
		609	`if (!dim->hi_ref)`
		610	`check_const_exp (dim->upper.x);`
		611	`}`
		612	`}`
		613	`break;`
		614	`case DGT_SUBR:`
		615	`check_const_type (t->data.t_subr.d_typ);`
		616	`if (!t->data.t_subr.low_ref)`
		617	`check_const_exp (t->data.t_subr.lower.x);`
		618	`if (!t->data.t_subr.hi_ref)`
		619	`check_const_exp (t->data.t_subr.upper.x);`
		620	`break;`
		621	`case DGT_STRUCT:`
		622	`for (i = 0; i < t->data.t_struct.u.fields.len; i++) {`
		623	`dg_classmem * f = &(t->data.t_struct.u.fields.array[i]);`
		624	`check_const_type (f->d.cm_f.f_typ);`
		625	`check_const_exp (f->d.cm_f.f_offset);`
		626	`}`
		627	`break;`
		628	`case DGT_PROC:`
		629	`if (t->data.t_proc.res_type)`
		630	`check_const_type (t->data.t_proc.res_type);`
		631	`for (i = 0; i < t->data.t_proc.params.len; i++) {`
		632	`dg_param * p = &(t->data.t_proc.params.array[i]);`
		633	`check_const_type (p->p_typ);`
		634	`}`
		635	`break;`
		636	`case DGT_STRING:`
		637	`check_const_exp (t->data.t_string.lb);`
		638	`check_const_exp (t->data.t_string.length);`
		639	`break;`
		640	`case DGT_CLASS:`
		641	`case DGT_PMEM:`
		642	`failer ("uncopyable type");`
		643	`break;`
		644	`default:`
		645	`break;`
		646	`}`
		647	`return;`
		648	`}`
		649
		650
		651	`static int inner_copy = 0;`
		652
		653
		654	`static dg_name new_copy_name`
		655	`PROTO_N ( (d) )`
		656	`PROTO_T ( dg_name d )`
		657	`{`
		658	`dg_name new = new_dg_name(d->key);`
		659	`if (d->mor && d->mor->this_tag) {`
		660	`IGNORE f_dg_tag_name (gen_tg_tag(), new);`
		661	`if (d->mor->this_tag->copy)`
		662	`failer ("bad copy_diagname");`
		663	`if (inner_copy)`
		664	`d->mor->this_tag->copy = new->mor->this_tag;`
		665	`}`
		666	`if (doing_inlining) {`
		667	`if (!d->mor \|\| (!d->mor->this_tag && !d->mor->inline_ref))`
		668	`IGNORE f_dg_tag_name (gen_tg_tag(), d);`
		669	`if (!d->mor->inline_ref)`
		670	`d->mor->inline_ref = d->mor->this_tag;`
		671	`}`
		672	`new->idnam = d->idnam;`
		673	`new->whence = d->whence;`
		674	`if (d->mor && (d->mor->inline_ref \|\| d->mor->refspec \|\| d->mor->acc`
		675	`\|\| d->mor->isconst)) {`
		676	`extend_dg_name (new);`
		677	`new->mor->inline_ref = d->mor->inline_ref;`
		678	`new->mor->refspec = d->mor->refspec;`
		679	`new->mor->acc = d->mor->acc;`
		680	`new->mor->isconst = d->mor->isconst;`
		681	`}`
		682	`return new;`
		683	`}`
		684
		685	`static int is_copied`
		686	`PROTO_N ( (e) )`
		687	`PROTO_T ( exp e )`
		688	`{`
		689	`if (!e)`
		690	`return 0;`
		691	`switch (name(e)) {`
		692	`case name_tag:`
		693	`return (copying(son(e)));`
		694	`case hold_tag:`
		695	`case cont_tag:`
		696	`case contvol_tag:`
		697	`case reff_tag:`
		698	`case chvar_tag:`
		699	`case chfl_tag:`
		700	`return is_copied (son(e));`
		701	`case val_tag:`
		702	`case null_tag:`
		703	`case real_tag:`
		704	`case string_tag:`
		705	`return 0;`
		706	`default:`
		707	`failer("unexpected copy_diagname obtain_val");`
		708	`}`
		709	`return 0;`
		710	`}`
		711
		712
		713	`static dg_name copy_diagname`
		714	`PROTO_N ( (d, var, lab, need) )`
		715	`PROTO_T ( dg_name d X exp var X exp lab X int need )`
		716	`{`
		717	`/* need (new dg_name) if copying a name_list, or if inlining */`
		718	`dg_name new = d;`
		719	`switch (d->key) {`
		720	`case DGN_OBJECT: {`
		721	`int moved = is_copied (d->data.n_obj.obtain_val);`
		722	`check_const_type (d->data.n_obj.typ);`
		723	`if (need \|\| moved) {`
		724	`new = new_copy_name (d);`
		725	`new->data.n_obj = d->data.n_obj;`
		726	`#if 0`
		727	`if (moved)`
		728	`#endif`
		729	`new->data.n_obj.obtain_val =`
		730	`copy_res (d->data.n_obj.obtain_val, var, lab);`
		731	`}`
		732	`break;`
		733	`}`
		734	`case DGN_TYPE: {`
		735	`check_const_type (d->data.n_typ.raw);`
		736	`break;`
		737	`}`
		738	`case DGN_IMPORT: {`
		739	`if (d->data.n_imp.i_typ)`
		740	`check_const_type (d->data.n_imp.i_typ);`
		741	`break;`
		742	`}`
		743	`default:`
		744	`failer ("unexpected copy_diagname");`
		745	`};`
		746	`return new;`
		747	`}`
		748
		749	`static void update_detch_copy PROTO_S ((detch_info * dl, int update));`
		750
		751	`static void update_diag_copy`
		752	`PROTO_N ( (e, d, update) )`
		753	`PROTO_T ( exp e X dg_info d X int update )`
		754	`{`
		755	`if (d) {`
		756	`if (update) { /* use all dg_tag copies */`
		757	`switch (d->key) {`
		758	`case DGA_INL_RES: {`
		759	`dg_tag ic = d->data.i_res.call;`
		760	`if (ic->copy)`
		761	`d->data.i_res.call = ic->copy;`
		762	`break;`
		763	`}`
		764	`case DGA_BEG: {`
		765	`dg_tag tg = d->data.i_tg;`
		766	`if (tg->copy)`
		767	`d->data.i_tg = tg->copy;`
		768	`break;`
		769	`}`
		770	`case DGA_RVS: {`
		771	`dg_tag tg = d->data.i_rvs.u.tg;`
		772	`if (tg && tg->copy)`
		773	`d->data.i_rvs.u.tg = tg->copy;`
		774	`break;`
		775	`}`
		776	`case DGA_DETCH: {`
		777	`update_detch_copy (d->data.i_detch.dl, 1);`
		778	`break;`
		779	`}`
		780	`case DGA_MOVD:`
		781	`case DGA_HOIST: {`
		782	`dg_tag tg = d->data.i_movd.tg;`
		783	`if (tg && tg->copy)`
		784	`d->data.i_movd.tg = tg->copy;`
		785	`#if 1`
		786	`if (d->key == DGA_MOVD && !d->more)`
		787	`failer ("lost movd?");`
		788	`#endif`
		789	`break;`
		790	`}`
		791	`default:`
		792	`break;`
		793	`}`
		794	`}`
		795	`else { /* remove all dg_tag copies */`
		796	`if (d->this_tag && (doing_inlining \|\| clean_copy))`
		797	`d->this_tag->copy = (dg_tag)0;`
		798	`/* otherwise keep record for code movement */`
		799	`switch (d->key) {`
		800	`case DGA_NAME: {`
		801	`dg_name a = d->data.i_nam.dnam;`
		802	`if (a->mor && a->mor->this_tag)`
		803	`a->mor->this_tag->copy = (dg_tag)0;`
		804	`break;`
		805	`}`
		806	`case DGA_INL_CALL: {`
		807	`dg_name a = d->data.i_inl.args;`
		808	`while (a) {`
		809	`if (a->mor && a->mor->this_tag)`
		810	`a->mor->this_tag->copy = (dg_tag)0;`
		811	`a = a->next;`
		812	`}`
		813	`break;`
		814	`}`
		815	`case DGA_X_CATCH: {`
		816	`dg_name a = d->data.i_catch.ex;`
		817	`if (a->mor && a->mor->this_tag)`
		818	`a->mor->this_tag->copy = (dg_tag)0;`
		819	`break;`
		820	`}`
		821	`case DGA_DETCH: {`
		822	`if (doing_inlining \|\| clean_copy)`
		823	`update_detch_copy (d->data.i_detch.dl, 0);`
		824	`break;`
		825	`}`
		826	`#if 1`
		827	`case DGA_MOVD: {`
		828	`if (!d->more)`
		829	`failer ("lost movd?");`
		830	`break;`
		831	`}`
		832	`#endif`
		833	`default:`
		834	`break;`
		835	`}`
		836	`}`
		837	`update_diag_copy (e, d->more, update);`
		838	`}`
		839	`else`
		840	`if (e) {`
		841	`switch (name(e)) {`
		842	`case name_tag:`
		843	`case env_offset_tag:`
		844	`case general_env_offset_tag:`
		845	`break;`
		846	`default: {`
		847	`exp s = son(e);`
		848	`while (s) {`
		849	`update_diag_copy (s, dgf(s), update);`
		850	`if (last(s))`
		851	`break;`
		852	`s = bro(s);`
		853	`}`
		854	`}`
		855	`}`
		856	`}`
		857	`return;`
		858	`}`
		859
		860	`static void update_detch_copy`
		861	`PROTO_N ( (dl, update) )`
		862	`PROTO_T ( detch_info * dl X int update )`
		863	`{`
		864	`while (dl) {`
		865	`if (dl->info)`
		866	`update_diag_copy (nilexp, dl->info, update);`
		867	`if (update && dl->tg && dl->tg->copy)`
		868	`dl->tg = dl->tg->copy;`
		869	`if (dl->sub)`
		870	`update_detch_copy (dl->sub, update);`
		871	`dl = dl->next;`
		872	`}`
		873	`return;`
		874	`}`
		875
		876
		877	`static detch_info * copy_detch_tree PROTO_S ((detch_info * dl));`
		878
		879	`static dg_info copy_dg_info`
		880	`PROTO_N ( (d, var, lab, doing_exp_copy) )`
		881	`PROTO_T ( dg_info d X exp var X exp lab X int doing_exp_copy )`
		882	`{`
		883	`dg_info new = new_dg_info(d->key);`
		884	`if (d->this_tag) {`
		885	`IGNORE f_make_tag_dg (gen_tg_tag(), new);`
		886	`if (d->this_tag->copy)`
		887	`failer ("bad copy_dg_info");`
		888	`if (inner_copy)`
		889	`d->this_tag->copy = new->this_tag;`
		890	`}`
		891	`switch (new->key) {`
		892	`case DGA_PARAMS: {`
		893	`new->data.i_param = d->data.i_param;`
		894	`break;`
		895	`}`
		896	`case DGA_COMP: {`
		897	`new->data.i_comp = d->data.i_comp;`
		898	`break;`
		899	`}`
		900	`case DGA_SRC: {`
		901	`new->data.i_src = d->data.i_src;`
		902	`break;`
		903	`}`
		904	`case DGA_LAB:`
		905	`case DGA_EXTRA:`
		906	`case DGA_SCOPE: {`
		907	`new->data.i_scope = d->data.i_scope;`
		908	`break;`
		909	`}`
		910	`case DGA_NAME: {`
		911	`new->data.i_nam = d->data.i_nam;`
		912	`if (doing_exp_copy) /* a named item might be copied */`
		913	`new->data.i_nam.dnam =`
		914	`copy_diagname (d->data.i_nam.dnam, var, lab, doing_inlining);`
		915	`break;`
		916	`}`
		917	`case DGA_WITH: {`
		918	`new->data.i_with = d->data.i_with;`
		919	`check_const_type (d->data.i_with.w_typ);`
		920	`if (doing_exp_copy)`
		921	`new->data.i_with.w_exp = copy_res (d->data.i_with.w_exp, var, lab);`
		922	`break;`
		923	`}`
		924	`case DGA_CALL: {`
		925	`new->data.i_call = d->data.i_call;`
		926	`break;`
		927	`}`
		928	`case DGA_INL_CALL: {`
		929	`dg_name a = d->data.i_inl.args;`
		930	`dg_name * b = &(new->data.i_inl.args);`
		931	`new->data.i_inl = d->data.i_inl;`
		932	`if (doing_exp_copy) {`
		933	`while (a) {`
		934	`*b = copy_diagname (a, var, lab, 1);`
		935	`a = a->next;`
		936	`b = &((*b)->next);`
		937	`}`
		938	`}`
		939	`d->data.i_inl.proc->any_inl = 1;`
		940	`break;`
		941	`}`
		942	`case DGA_INL_RES: {`
		943	`new->data.i_res = d->data.i_res;`
		944	`new->data.i_res.call = d->data.i_res.call;`
		945	`break;`
		946	`}`
		947	`case DGA_X_TRY: {`
		948	`new->data.i_try = d->data.i_try;`
		949	`break;`
		950	`}`
		951	`case DGA_X_CATCH: {`
		952	`new->data.i_catch = d->data.i_catch;`
		953	`if (doing_exp_copy)`
		954	`new->data.i_catch.ex =`
		955	`copy_diagname (d->data.i_catch.ex, var, lab, doing_inlining);`
		956	`break;`
		957	`}`
		958	`case DGA_X_RAISE: {`
		959	`new->data.i_raise = d->data.i_raise;`
		960	`if (d->data.i_raise.x_typ)`
		961	`check_const_type (d->data.i_raise.x_typ);`
		962	`if (d->data.i_raise.x_val && doing_exp_copy)`
		963	`new->data.i_raise.x_val = copy_res (d->data.i_raise.x_val, var, lab);`
		964	`break;`
		965	`}`
		966	`case DGA_BRANCH: {`
		967	`new->data.i_brn = d->data.i_brn;`
		968	`break;`
		969	`}`
		970	`case DGA_TEST:`
		971	`case DGA_JUMP: {`
		972	`new->data.i_tst = d->data.i_tst;`
		973	`break;`
		974	`}`
		975	`case DGA_LJ: {`
		976	`new->data.i_lj = d->data.i_lj;`
		977	`break;`
		978	`}`
		979	`case DGA_BEG: {`
		980	`new->data.i_tg = d->data.i_tg;`
		981	`break;`
		982	`}`
		983	`case DGA_DEST: {`
		984	`new->data.i_dest = d->data.i_dest;`
		985	`break;`
		986	`}`
		987	`case DGA_RVS: {`
		988	`new->data.i_rvs = d->data.i_rvs;`
		989	`break;`
		990	`}`
		991	`case DGA_BAR: {`
		992	`new->data.i_bar = d->data.i_bar;`
		993	`break;`
		994	`}`
		995	`case DGA_DETCH: {`
		996	`new->data.i_detch = d->data.i_detch;`
		997	`if (doing_exp_copy)`
		998	`new->data.i_detch.dl = copy_detch_tree (new->data.i_detch.dl);`
		999	`break;`
		1000	`}`
		1001	`case DGA_MOVD:`
		1002	`case DGA_HOIST: {`
		1003	`new->data.i_movd = d->data.i_movd;`
		1004	`#if 1`
		1005	`if (d->key == DGA_MOVD && !d->more)`
		1006	`failer ("lost movd?");`
		1007	`#endif`
		1008	`break;`
		1009	`}`
		1010	`case DGA_OPTIM: {`
		1011	`new->data.i_optim = d->data.i_optim;`
		1012	`break;`
		1013	`}`
		1014	`case DGA_REMVAL: {`
		1015	`new->data.i_remval = d->data.i_remval;`
		1016	`if (copying(son(son(d->data.i_remval.var))))`
		1017	`new->data.i_remval.var = copy (d->data.i_remval.var);`
		1018	`break;`
		1019	`}`
		1020	`default:`
		1021	`failer ("copy_diaginfo incomplete");`
		1022	`};`
		1023	`return new;`
		1024	`}`
		1025
		1026	`static detch_info * copy_detch_tree`
		1027	`PROTO_N ( (dl) )`
		1028	`PROTO_T ( detch_info * dl )`
		1029	`{`
		1030	`detch_info * ans = (detch_info *) xcalloc (1, sizeof (detch_info));`
		1031	`ans = dl;`
		1032	`if (dl->info)`
		1033	`ans->info = copy_dg_info (dl->info, nilexp, nilexp, 1);`
		1034	`if (dl->sub)`
		1035	`ans->sub = copy_detch_tree (dl->sub);`
		1036	`if (dl->next)`
		1037	`ans->next = copy_detch_tree (dl->next);`
		1038	`return ans;`
		1039	`}`
		1040
		1041
		1042	`exp copy_res_diag`
		1043	`PROTO_N ( (e, d, var, lab) )`
		1044	`PROTO_T ( exp e X dg_info d X exp var X exp lab )`
		1045	`{`
		1046	`int ic = inner_copy;`
		1047	`dg_info new;`
		1048	`exp ans;`
		1049	`if (!d /* \|\|`
		1050	`(name(e) == name_tag && isdiaginfo(e) && !doing_inlining && !clean-copy) */`
		1051	`/* only one defining name tag */`
		1052	`) {`
		1053	`dg_info all = dgf(e);`
		1054	`dgf(e) = nildiag;`
		1055	`ans = copy_res (e, var, lab);`
		1056	`dgf(e) = all;`
		1057	`dgf(ans) = combine_diaginfo (dgf(ans), d);`
		1058	`return ans;`
		1059	`}`
		1060	`if (d->key == DGA_PARAMS)`
		1061	`return copy_res_diag (e, d->more, var, lab);`
		1062	`inner_copy = 1;`
		1063	`new = copy_dg_info (d, var, lab, 1);`
		1064	`ans = copy_res_diag (e, d->more, var, lab);`
		1065
		1066	`new->more = dgf(ans);`
		1067	`dgf(ans) = new;`
		1068	`if (!ic) {`
		1069	`inner_copy = 0;`
		1070	`update_diag_copy (ans, dgf(ans), 1);`
		1071	`update_diag_copy (e, dgf(e), 0);`
		1072	`}`
		1073	`return ans;`
		1074	`}`
		1075
		1076	`exp diag_hold_check /* called by copy_res when inlining */`
		1077	`PROTO_N ( (e) )`
		1078	`PROTO_T ( exp e )`
		1079	`{`
		1080	`int was_inlining = doing_inlining;`
		1081	`exp hc;`
		1082	`doing_inlining = 0;`
		1083	`hc = hold_check (e);`
		1084	`doing_inlining = was_inlining;`
		1085	`return hc;`
		1086	`}`
		1087
		1088
		1089	`static dg_tag current_inliner = (dg_tag)0;`
		1090
		1091	`static int ref_param`
		1092	`PROTO_N ( (e) )`
		1093	`PROTO_T ( exp e )`
		1094	`{`
		1095	`switch (name(e)) {`
		1096	`case name_tag:`
		1097	`case cont_tag:`
		1098	`case chvar_tag:`
		1099	`case chfl_tag:`
		1100	`return ref_param (son(e));`
		1101	`case ident_tag:`
		1102	`if (isparam(e))`
		1103	`return 1;`
		1104	`if (dgf(e) \|\| isglob(e))`
		1105	`return 0;`
		1106	`return ref_param (son(e));`
		1107	`default:`
		1108	`return 0;`
		1109	`}`
		1110	`}`
		1111
		1112	`void start_diag_inlining`
		1113	`PROTO_N ( (e, dn) )`
		1114	`PROTO_T ( exp e X dg_name dn )`
		1115	`{`
		1116	`exp body = son(e);`
		1117	`dg_info di;`
		1118	`int any_inl;`
		1119	`dg_name_list args = (dg_name)0;`
		1120	`if (!dn \|\| dn->key != DGN_PROC)`
		1121	`return;`
		1122	`while (name(body) == ident_tag && (isparam(body) \|\|`
		1123	`(!dgf(body) && ref_param (son(body)) )))`
		1124	`body = bro(son(body));`
		1125	`di = dgf(body);`
		1126	`if (di && di->key == DGA_PARAMS) {`
		1127	`dn->data.n_proc.params = di;`
		1128	`args = di->data.i_param.args;`
		1129	`}`
		1130	`if (!dn->mor \|\| !dn->mor->this_tag)`
		1131	`IGNORE f_dg_tag_name (gen_tg_tag(), dn);`
		1132	`any_inl = dn->mor->this_tag->any_inl;`
		1133	`di = f_inline_call_dg ( /* for copying only */`
		1134	`dn->mor->this_tag,`
		1135	`args,`
		1136	`no_nat_option);`
		1137	`dn->mor->this_tag->any_inl = any_inl;`
		1138	`current_inliner = gen_tg_tag();`
		1139	`di = f_make_tag_dg (current_inliner, di);`
		1140	`di->more = dgf(body);`
		1141	`dgf(body) = di;`
		1142	`return;`
		1143	`}`
		1144
		1145	`void end_diag_inlining`
		1146	`PROTO_N ( (e, dn) )`
		1147	`PROTO_T ( exp e X dg_name dn )`
		1148	`{`
		1149	`exp body;`
		1150	`if (!dn \|\| dn->key != DGN_PROC)`
		1151	`return;`
		1152	`body = son(e);`
		1153	`while (name(body) == ident_tag && (isparam(body) \|\|`
		1154	`(!dgf(body) && ref_param (son(body)) )))`
		1155	`body = bro(son(body));`
		1156	`dgf(body) = dgf(body)->more;`
		1157	`current_inliner = 0;`
		1158	`return;`
		1159	`}`
		1160
		1161	`dg_info combine_diaginfo`
		1162	`PROTO_N ( (d1, d2) )`
		1163	`PROTO_T ( dg_info d1 X dg_info d2 )`
		1164	`{`
		1165	`dg_info d;`
		1166	`if (!d1)`
		1167	`return d2;`
		1168	`if (!d2)`
		1169	`return d1;`
		1170	`d = copy_dg_info (d1, nilexp, nilexp, 0);`
		1171	`d->more = combine_diaginfo (d1->more, d2);`
		1172	`return d;`
		1173	`}`
		1174
		1175	`void diag_inline_result`
		1176	`PROTO_N ( (e) )`
		1177	`PROTO_T ( exp e )`
		1178	`{`
		1179	`if (current_inliner)`
		1180	`dgf(e) = f_inline_result_dg (current_inliner);`
		1181	`return;`
		1182	`}`
		1183
		1184
		1185	`void dg_whole_comp`
		1186	`PROTO_N ( (whole, comp) )`
		1187	`PROTO_T ( exp whole X exp comp )`
		1188	`{`
		1189	`/* for use before replace (whole, comp, x) when`
		1190	`whole is replaced by its only remaining component */`
		1191	`if (dgf(whole)) {`
		1192	`dg_info * next = &(dgf(whole)->more);`
		1193	`while (*next)`
		1194	`next = &((*next)->more);`
		1195	`*next = dgf(comp);`
		1196	`dgf(comp) = dgf(whole);`
		1197	`}`
		1198	`return;`
		1199	`}`
		1200
		1201
		1202	`void dg_complete_inline`
		1203	`PROTO_N ( (whole , comp) )`
		1204	`PROTO_T ( exp whole X exp comp )`
		1205	`{`
		1206	`/* as dg_whole_comp, but remove DGA_CALL */`
		1207	`if (dgf(whole)) {`
		1208	`int rem = 0;`
		1209	`dg_info * next = &(dgf(whole)->more);`
		1210	`while (*next) {`
		1211	`if ((*next)->key == DGA_CALL) {`
		1212	`next = (next)->more;`
		1213	`rem = 1;`
		1214	`}`
		1215	`else`
		1216	`next = &((*next)->more);`
		1217	`}`
		1218	`if (rem) {`
		1219	`/* we must find DGA_INL_CALL to replace the DGA_CALL */`
		1220	`while (!dgf(comp)) {`
		1221	`if (name(comp) == ident_tag)`
		1222	`comp = bro(son(comp));`
		1223	`else`
		1224	`if (name(comp) == cond_tag)`
		1225	`comp = son(comp);`
		1226	`else`
		1227	`break;`
		1228	`}`
		1229	`if (!dgf(comp) \|\| dgf(comp)->key != DGA_INL_CALL)`
		1230	`failer ("lost inline call movement");`
		1231	`}`
		1232	`*next = dgf(comp);`
		1233	`dgf(comp) = dgf(whole);`
		1234	`}`
		1235	`return;`
		1236	`}`
		1237
		1238
		1239	`static detch_info * gather_detch`
		1240	`PROTO_N ( (e, dx, reason, descend, reuse, opt_ref) )`
		1241	`PROTO_T ( exp e X dg_info * dx X int reason X int descend X int reuse`
		1242	`X dg_tag opt_ref )`
		1243	`{`
		1244	`/* e is exp under consideration.`
		1245	`dx is (ref) dg_info under consideration`
		1246	`part of dgf(e); this info being removed.`
		1247	`reason is enumerated reason for debugger.`
		1248	`descend is nonzero if son(e) to be processed.`
		1249	`reuse is nonzero if simple movement (e remains in use).`
		1250	`opt_ref for reference to complex optimisation info.`
		1251	`*/`
		1252	`dg_info d = *dx;`
		1253	`detch_info * ans;`
		1254	`exp s;`
		1255	`if (d) {`
		1256	`if (d->key == DGA_DETCH) { /* previous detachment */`
		1257	`detch_info * more = gather_detch (e, &(d->more), reason, descend,`
		1258	`reuse, opt_ref);`
		1259	`detch_info ** ptr;`
		1260	`if (d->data.i_detch.posn < 0) {`
		1261	`ans = d->data.i_detch.dl;`
		1262	`}`
		1263	`else {`
		1264	`ans = more;`
		1265	`more = d->data.i_detch.dl;`
		1266	`}`
		1267	`ptr = &ans;`
		1268	`while (*ptr)`
		1269	`ptr = &((*ptr)->next);`
		1270	`*ptr = more;`
		1271	`return ans;`
		1272	`}`
		1273	`if (d->key == DGA_MOVD) { /* previous simple movement */`
		1274	`if (!d->more)`
		1275	`failer ("lost movd?");`
		1276	`if (reason < d->data.i_movd.reason) {`
		1277	`d->data.i_movd.reason = reason;`
		1278	`d->data.i_movd.tg = opt_ref;`
		1279	`}`
		1280	`if (reuse)`
		1281	`return (detch_info *)0;`
		1282	`d->data.i_movd.lost = 1;`
		1283	`if (d->more->key == DGA_INL_CALL) { /* ignore internals */`
		1284	`*dx = (dg_info)0;`
		1285	`return (detch_info *)0;`
		1286	`}`
		1287	`*dx = d->more->more;`
		1288	`return gather_detch (e, dx, reason, descend, reuse, opt_ref);`
		1289	`}`
		1290	`ans = (detch_info *) xcalloc (1, sizeof (detch_info));`
		1291	`ans->next = (detch_info *)0;`
		1292	`if (d->key == DGA_INL_CALL)`
		1293	`ans->sub = (detch_info *)0;`
		1294	`else`
		1295	`ans->sub = gather_detch (e, &(d->more), reason, descend, reuse, opt_ref);`
		1296	`ans->why = reason;`
		1297	`if (reuse) {`
		1298	`d = new_dg_info (DGA_MOVD);`
		1299	`d->data.i_movd.reason = reason;`
		1300	`d->data.i_movd.lost = 0;`
		1301	`d->data.i_movd.tg = opt_ref;`
		1302	`d->data.i_movd.lo_pc = 0;`
		1303	`d->more = *dx;`
		1304	`*dx = d;`
		1305	`if (!d->more)`
		1306	`failer ("lost movd?");`
		1307	`IGNORE f_make_tag_dg (gen_tg_tag(), d);`
		1308	`ans->info = (dg_info)0;`
		1309	`ans->tg = d->this_tag;`
		1310	`}`
		1311	`else { /* original about to be discarded */`
		1312	`ans->info = d;`
		1313	`d->more = (dg_info)0;`
		1314	`ans->tg = opt_ref;`
		1315	`}`
		1316	`return ans;`
		1317	`}`
		1318	`if (extra_diags && reuse &&`
		1319	`(name(e) == apply_tag \|\| name(e) == apply_general_tag)) {`
		1320	`/* need info to modify in case of subsequent inlining */`
		1321	`dg_info x = dgf(e);`
		1322	`while (x && x->key != DGA_CALL)`
		1323	`x = x->more;`
		1324	`if (!x) {`
		1325	`*dx = d = new_dg_info (DGA_CALL);`
		1326	`d->data.i_call.clnam = (char*)0;`
		1327	`d->data.i_call.pos = no_short_sourcepos;`
		1328	`d->data.i_call.ck = 0;`
		1329	`return gather_detch (e, dx, reason, descend, reuse, opt_ref);`
		1330	`}`
		1331	`}`
		1332	`if (!descend)`
		1333	`return (detch_info *)0;`
		1334	`s = son(e);`
		1335	`if (name(e) == name_tag \|\| name(e) == env_size_tag \|\|`
		1336	`name(e) == env_offset_tag \|\| !s)`
		1337	`return (detch_info *)0;`
		1338	`ans = gather_detch (s, &(dgf(s)), reason, descend, reuse, opt_ref);`
		1339	`if (name(e) != case_tag) {`
		1340	`detch_info ** ptr = &ans;`
		1341	`while (!last(s)) {`
		1342	`s = bro(s);`
		1343	`while (*ptr)`
		1344	`ptr = &((*ptr)->next);`
		1345	`*ptr = gather_detch (s, &(dgf(s)), reason, descend, reuse, opt_ref);`
		1346	`}`
		1347	`}`
		1348	`return ans;`
		1349	`}`
		1350
		1351
		1352	`static void dg_detach`
		1353	`PROTO_N ( (old, keep, position, reason, descend, reuse, opt_ref) )`
		1354	`PROTO_T ( exp old X exp keep X int position X int reason X int descend`
		1355	`X int reuse X dg_tag opt_ref )`
		1356	`{`
		1357	`detch_info * info =`
		1358	`gather_detch (old, &(dgf(old)), reason, descend, reuse, opt_ref);`
		1359	`if (info) {`
		1360	`dg_info newd = new_dg_info (DGA_DETCH);`
		1361	`newd->data.i_detch.posn = position;`
		1362	`newd->data.i_detch.dl = info;`
		1363	`newd->more = dgf(keep);`
		1364	`dgf(keep) = newd;`
		1365	`}`
		1366	`return;`
		1367	`}`
		1368
		1369	`void dg_dead_code`
		1370	`PROTO_N ( (dead, prev) )`
		1371	`PROTO_T ( exp dead X exp prev )`
		1372	`{ /* mark removal of dead code following prev */`
		1373	`dg_detach (dead, prev, +1, DGD_DEAD, 1, 0, (dg_tag)0);`
		1374	`return;`
		1375	`}`
		1376
		1377	`void dg_rdnd_code`
		1378	`PROTO_N ( (rdnd, next) )`
		1379	`PROTO_T ( exp rdnd X exp next )`
		1380	`{ /* mark removal of redundant code before next */`
		1381	`dg_detach (rdnd, next, -1, DGD_RDND, 1, 0, (dg_tag)0);`
		1382	`return;`
		1383	`}`
		1384
		1385	`void dg_detach_const`
		1386	`PROTO_N ( (part, whole) )`
		1387	`PROTO_T ( exp part X exp whole )`
		1388	`{ /* incorporated part in whole evaluated constant*/`
		1389	`dg_detach (part, whole, 0, DGD_CNST, 0, 0, (dg_tag)0);`
		1390	`return;`
		1391	`}`
		1392
		1393	`void dg_restruct_code`
		1394	`PROTO_N ( (outer, inner, posn) )`
		1395	`PROTO_T ( exp outer X exp inner X int posn )`
		1396	`{ /* mark movement of inner into outer */`
		1397	`dg_detach (inner, outer, posn, DGD_MOVD, 1, 1, (dg_tag)0);`
		1398	`return;`
		1399	`}`
		1400
		1401	`void dg_rem_ass`
		1402	`PROTO_N ( (ass) )`
		1403	`PROTO_T ( exp ass )`
		1404	`{ /* mark removal of propagated assignment */`
		1405	`exp val = bro(son(ass));`
		1406	`if (name(son(ass)) == name_tag && (name(val) == val_tag \|\|`
		1407	`name(val) == real_tag \|\| name (val) == null_tag)) {`
		1408	`dg_info h = dgf(val);`
		1409	`dg_info * dx = &(dgf(ass));`
		1410	`dg_info rem = new_dg_info (DGA_REMVAL);`
		1411	`rem->data.i_remval.var = hold(me_obtain (son(son(ass))));`
		1412	`setisdiaginfo (son(rem->data.i_remval.var));`
		1413	`-- no(son(son(rem->data.i_remval.var)));`
		1414	`dgf(val) = nildiag;`
		1415	`rem->data.i_remval.val = copy(val);`
		1416	`dgf(val) = h;`
		1417	`rem->data.i_remval.lo_pc = (long)0;`
		1418	`rem->more = nildiag;`
		1419	`while (*dx)`
		1420	`dx = &((*dx)->more);`
		1421	`*dx = rem;`
		1422	`}`
		1423	`dg_detach (ass, bro(son(ass)), -1, DGD_REM, 0, 0, (dg_tag)0);`
		1424	`return;`
		1425	`}`
		1426
		1427	`void strip_dg_context`
		1428	`PROTO_N ( (e) )`
		1429	`PROTO_T ( exp e )`
		1430	`{`
		1431	`dg_info d = dgf(e);`
		1432	`while (d && (d->key == DGA_DETCH \|\| d->key == DGA_NAME))`
		1433	`d = d->more;`
		1434	`dgf(e) = d;`
		1435	`return;`
		1436	`}`
		1437
		1438	`static dg_info * after_dg_context`
		1439	`PROTO_N ( (e) )`
		1440	`PROTO_T ( exp e )`
		1441	`{`
		1442	`dg_info * dx = &(dgf(e));`
		1443	`while (dx && ((dx)->key == DGA_DETCH \|\| (*dx)->key == DGA_NAME))`
		1444	`dx = &((*dx)->more);`
		1445	`return dx;`
		1446	`}`
		1447
		1448	`void dg_extracted`
		1449	`PROTO_N ( (nm, old) )`
		1450	`PROTO_T ( exp nm X exp old )`
		1451	`{ /* old replaced by nm */`
		1452	`dg_info con_start = dgf(old);`
		1453	`dg_info con_end = (strip_dg_context(old), dgf(old));`
		1454	`dg_info * dx;`
		1455	`if (name(nm) != name_tag \|\| (dx = after_dg_context (son(nm)), !(*dx)->this_tag))`
		1456	`failer ("make_optim error");`
		1457	`dg_detach (old, nm, -1, DGD_EXTRACT, 1, 0, (*dx)->this_tag);`
		1458	`if (con_start != con_end) {`
		1459	`dg_info d = con_start;`
		1460	`while (d->more != con_end)`
		1461	`d = d->more;`
		1462	`d->more = dgf(nm);`
		1463	`dgf(nm) = con_start;`
		1464	`}`
		1465	`return;`
		1466	`}`
		1467
		1468
		1469	`static void gather_objects`
		1470	`PROTO_N ( (e, whole, obs, ass) )`
		1471	`PROTO_T ( exp e X exp whole X objset ** obs X int ass )`
		1472	`{`
		1473	`/* gather into obs, all objects accessed within e that are`
		1474	`external to whole, distinguishing those that may be altered */`
		1475	`exp t;`
		1476	`switch (name(e)) {`
		1477	`case name_tag: {`
		1478	`if (!intnl_to (whole, son(e))) {`
		1479	`dg_tag tg = find_obj_ref (whole, e);`
		1480	`if (tg) {`
		1481	`objset * x = *obs;`
		1482	`while (x && x->tg != tg)`
		1483	`x = x->next;`
		1484	`if (!x) {`
		1485	`x = (objset *) xcalloc (1, sizeof (objset));`
		1486	`x->tg = tg;`
		1487	`x->ass = ass;`
		1488	`x->next = *obs;`
		1489	`*obs = x;`
		1490	`}`
		1491	`else`
		1492	`if (ass)`
		1493	`x->ass = 1;`
		1494	`}`
		1495	`}`
		1496	`return;`
		1497	`}`
		1498	`case ident_tag: {`
		1499	`gather_objects (bro(son(e)), whole, obs, ass);`
		1500	`break; /* definition part no_ass */`
		1501	`}`
		1502	`case seq_tag: {`
		1503	`gather_objects (bro(son(e)), whole, obs, ass);`
		1504	`e = son(e);`
		1505	`break; /* statements no_ass */`
		1506	`}`
		1507	`case cond_tag: {`
		1508	`gather_objects (son(e), whole, obs, ass);`
		1509	`gather_objects (bro(son(e)), whole, obs, ass);`
		1510	`return;`
		1511	`}`
		1512	`case labst_tag: {`
		1513	`gather_objects (bro(son(e)), whole, obs, ass);`
		1514	`return;`
		1515	`}`
		1516	`case rep_tag: {`
		1517	`gather_objects (son(e), whole, obs, 0);`
		1518	`gather_objects (bro(son(e)), whole, obs, ass);`
		1519	`return;`
		1520	`}`
		1521	`case solve_tag: {`
		1522	`t = son(e);`
		1523	`for (;;) {`
		1524	`gather_objects (t, whole, obs, ass);`
		1525	`if (last(t))`
		1526	`return;`
		1527	`t = bro(t);`
		1528	`}`
		1529	`}`
		1530	`case ass_tag:`
		1531	`case assvol_tag: {`
		1532	`gather_objects (son(e), whole, obs, 1);`
		1533	`gather_objects (bro(son(e)), whole, obs, 0);`
		1534	`return;`
		1535	`}`
		1536	`case addptr_tag: {`
		1537	`gather_objects (son(e), whole, obs, ass);`
		1538	`gather_objects (bro(son(e)), whole, obs, 0);`
		1539	`return;`
		1540	`}`
		1541	`case env_offset_tag: {`
		1542	`return;`
		1543	`}`
		1544	`default:`
		1545	`break;`
		1546	`}`
		1547	`t = son(e); /* remaining cases all no_ass */`
		1548	`while (t) {`
		1549	`gather_objects (t, whole, obs, 0);`
		1550	`if (last(t))`
		1551	`return;`
		1552	`t = bro(t);`
		1553	`}`
		1554	`return;`
		1555	`}`
		1556
		1557
		1558	`void make_optim_dg`
		1559	`PROTO_N ( (reason, e) )`
		1560	`PROTO_T ( int reason X exp e )`
		1561	`{`
		1562	`dg_info sub = new_dg_info (DGA_HOIST);`
		1563	`exp konst = son(e);`
		1564	`exp body = bro(konst);`
		1565	`dg_info * dx;`
		1566	`dgf(e) = dgf(body);`
		1567	`dgf(body) = nildiag;`
		1568	`dx = after_dg_context (e);`
		1569	`if (!dx \|\| (dx)->key != DGA_OPTIM \|\| (*dx)->data.i_optim.reason != reason) {`
		1570	`dg_info ans = new_dg_info (DGA_OPTIM);`
		1571	`ans->data.i_optim.reason = reason;`
		1572	`ans->data.i_optim.objs = (objset *)0;`
		1573	`ans->data.i_optim.lo_pc = ans->data.i_optim.hi_pc = 0;`
		1574	`IGNORE f_make_tag_dg (gen_tg_tag(), ans);`
		1575	`ans->more = *dx;`
		1576	`*dx = ans;`
		1577	`}`
		1578	`sub->data.i_movd.reason = reason;`
		1579	`sub->data.i_movd.lost = 0;`
		1580	`sub->data.i_movd.tg = (*dx)->this_tag;`
		1581	`sub->data.i_movd.lo_pc = sub->data.i_movd.hi_pc = 0;`
		1582	`sub->more = dgf(konst);`
		1583	`dgf(konst) = sub;`
		1584	`gather_objects (konst, konst, &((*dx)->data.i_optim.objs), 0);`
		1585	`return;`
		1586	`}`
		1587
		1588	`exp copy_dg_separate`
		1589	`PROTO_N ( (e) )`
		1590	`PROTO_T ( exp e )`
		1591	`{ /* Used instead of copy if the original may`
		1592	`still be in use. This resets tracing of`
		1593	`dg_tag copies */`
		1594	`exp ans;`
		1595	`clean_copy = 1;`
		1596	`ans = copy(e);`
		1597	`clean_copy = 0;`
		1598	`return ans;`
		1599	`}`
		1600
		1601	`#endif`
		1602
		1603
		1604	`exp relative_exp`
		1605	`PROTO_N ( (s, t) )`
		1606	`PROTO_T ( shape s X token t )`
		1607	`{`
		1608	`exp id = me_startid (s, f_make_value (s), 0);`
		1609	`tokval tv;`
		1610	`tv.tk_exp = me_obtain (id);`
		1611	`tv = apply_tok(t, keep_place(), EXP_S, &tv);`
		1612	`IGNORE me_complete_id (id, hold_check (tv.tk_exp));`
		1613	`return hold(id);`
		1614	`}`

Subversion Repositories tendra.SVN

(root)/branches/tendra5/src/installers/common/diag/dg_aux.c – Rev 5