Subversion Repositories tendra.SVN

Rev

Rev 2 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 7u83 1 
/*
7 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 
			    VERSION INFORMATION
61 
			    ===================
62 
 
63 
--------------------------------------------------------------------------
64 
$Header: /u/g/release/CVSROOT/Source/src/installers/680x0/common/coder.c,v 1.1.1.1 1998/01/17 15:55:49 release Exp $
65 
--------------------------------------------------------------------------
66 
$Log: coder.c,v $
67 
 * Revision 1.1.1.1  1998/01/17  15:55:49  release
68 
 * First version to be checked into rolling release.
69 
 *
70 
Revision 1.4  1997/11/13 08:27:10  ma
71 
All avs test passed (except add_to_ptr).
72 
 
73 
Revision 1.3  1997/11/09 14:06:09  ma
74 
Fixed AVS problems.
75 
 
76 
Revision 1.2  1997/10/29 10:22:06  ma
77 
Replaced use_alloca with has_alloca.
78 
 
79 
Revision 1.1.1.1  1997/10/13 12:42:48  ma
80 
First version.
81 
 
82 
Revision 1.8  1997/10/13 08:49:01  ma
83 
Made all pl_tests for general proc & exception handling pass.
84 
 
85 
Revision 1.7  1997/09/25 06:44:52  ma
86 
All general_proc tests passed
87 
 
88 
Revision 1.6  1997/06/24 10:55:57  ma
89 
Added changes for "Plumhall Patch"
90 
 
91 
Revision 1.5  1997/06/18 12:04:49  ma
92 
Merged with Input Baseline changes.
93 
 
94 
Revision 1.4  1997/06/18 10:09:23  ma
95 
Checking in before merging with Input Baseline changes.
96 
 
97 
Revision 1.3  1997/04/20 11:30:19  ma
98 
Introduced gcproc.c & general_proc.[ch].
99 
Added cases for apply_general_proc next to apply_proc in all files.
100 
 
101 
Revision 1.2  1997/03/20 12:46:22  ma
102 
Now tag ids are kept in unsigned chars (MAX tag id > 127).
103 
 
104 
Revision 1.1.1.1  1997/03/14 07:50:10  ma
105 
Imported from DRA
106 
 
107 
 * Revision 1.1.1.1  1996/09/20  10:56:52  john
108 
 *
109 
 * Revision 1.4  1996/07/31  16:25:46  john
110 
 * Changed alloca
111 
 *
112 
 * Revision 1.3  1996/07/30  16:30:43  john
113 
 * Removed offset conversion
114 
 *
115 
 * Revision 1.2  1996/07/05  14:16:42  john
116 
 * Changes for spec 3.1
117 
 *
118 
 * Revision 1.1.1.1  1996/03/26  15:45:09  john
119 
 *
120 
 * Revision 1.5  94/06/29  14:18:27  14:18:27  ra (Robert Andrews)
121 
 * always_round_fl has changed its name.  Need to be slightly more careful
122 
 * in a couple of places.
123 
 *
124 
 * Revision 1.4  94/02/21  15:56:25  15:56:25  ra (Robert Andrews)
125 
 * A couple of flags which used to be bool are now int.
126 
 *
127 
 * Revision 1.3  93/11/19  16:15:49  16:15:49  ra (Robert Andrews)
128 
 * Minor corrections to nof_tag and ncopies_tag cases.
129 
 *
130 
 * Revision 1.2  93/03/08  15:28:34  15:28:34  ra (Robert Andrews)
131 
 * Procedures which take compound arguments and return a compound
132 
 * result which is ignored were having their arguments put on the
133 
 * stack in the wrong place.
134 
 *
135 
 * Revision 1.1  93/02/22  17:15:20  17:15:20  ra (Robert Andrews)
136 
 * Initial revision
137 
 *
138 
--------------------------------------------------------------------------
139 
*/
140 
 
141 
 
142 
#include "config.h"
143 
#include <limits.h>
144 
#include "common_types.h"
145 
#include "check.h"
146 
#include "exp.h"
147 
#include "expmacs.h"
148 
#include "flags.h"
149 
#include "shapemacs.h"
150 
#include "externs.h"
151 
#include "install_fns.h"
152 
#include "spec.h"
153 
#include "mach.h"
154 
#include "where.h"
155 
#include "tags.h"
156 
#include "codec.h"
157 
#include "coder.h"
158 
#include "operations.h"
159 
#include "mach.h"
160 
#include "mach_ins.h"
161 
#include "mach_op.h"
162 
#include "instr.h"
163 
#include "installglob.h"
164 
#include "codex.h"
165 
#include "instrs.h"
166 
#include "peephole.h"
167 
#include "szs_als.h"
168 
#include "tests.h"
169 
#include "utility.h"
170 
#include "weights.h"
171 
#include "translate.h"
172 
#include "ops_shared.h"
173 
#include "general_proc.h"
174 
#include "68k_globals.h"
175 
 
176 
#if have_diagnostics
177 
#include "xdb_basics.h"
178 
#endif
179 
 
7 7u83 180 
extern int do_peephole;
181 
extern int normal_version;
182 
static int extra_weight = 0;
2 7u83 183 
 
184 
 
185 
/*
186 
    ADD A SHAPE TO A THE STACK
187 
 
188 
    Given an ash p, representing the stack, and a shape s, this procedure
189 
    returns the ast correponding to the new stack formed by adding s to the
190 
    old stack.
191 
*/
192 
 
7 7u83 193 
ast
194 
add_shape_to_stack(ash p, shape s)
2 7u83 195 
{
7 7u83 196 
	ast res;
197 
	char n = name(s);
198 
	long sz = shape_size(s);
199 
	long adj = 0;
200 
	if (n == scharhd || n == ucharhd || n == swordhd || n == uwordhd) {
201 
		adj = SLONG_SZ - sz;
202 
		sz = SLONG_SZ;
203 
	}
204 
	if (n == bitfhd) {
205 
		sz = SLONG_SZ;
206 
	}
207 
	res.astoff = round(p, param_align);
208 
	res.astadj = adj;
209 
	res.astash = round(res.astoff + sz, param_align);
210 
	return (res);
2 7u83 211 
}
212 
 
213 
 
214 
/*
215 
    REGISTER ALLOCATION ROUTINES
216 
 
217 
    This routine tries to choose registers for a value of shape sha.  br
218 
    gives the breakpoint - the minimum number of registers which need to
219 
    be free for it to be worth putting this value in a register.  The big
220 
    flag is true to indicate that a register which is preserved across
221 
    procedure calls is required.  If a register can be allocated, then
222 
    its bitpattern is returned.  Otherwise 0 is returned.
223 
*/
224 
 
7 7u83 225 
static bitpattern
226 
alloc_reg(shape sha, int br, bool big)
2 7u83 227 
{
7 7u83 228 
	int go = 1;
229 
	bitpattern mask;
230 
	bitpattern rs = regsinuse;
231 
	int i, start, end, rev = 0;
2 7u83 232 
 
7 7u83 233 
	int rg;
234 
	int r = shtype(sha);
2 7u83 235 
 
7 7u83 236 
	if (r == Dreg) {
237 
		rg = bits_in(~rs & 0x00fc);
238 
		mask = regmsk(REG_D2);
239 
		start =  REG_D2;
240 
		end = REG_D7;
241 
	} else if (r == Areg) {
242 
		rg = bits_in(~rs & 0x3c00);
243 
		mask = regmsk(REG_A2);
244 
		start = REG_A2;
245 
		end = REG_A5;
246 
		if (br > extra_weight) {
247 
			br -= extra_weight;
248 
		}
249 
	} else if (r == Freg) {
250 
		if (round_after_flop) {
251 
			return (0);
252 
		}
253 
		rg = bits_in(~rs & 0xfc0000);
254 
		mask = regmsk(REG_FP7);
255 
		start = REG_FP7;
256 
		end = REG_FP2;
257 
		rev = 1;
258 
	} else {
259 
		error("Illegal register type");
260 
		return (0);
261 
	}
2 7u83 262 
 
7 7u83 263 
	if (rg < br || rg == 0) {
264 
		return (0);
265 
	}
2 7u83 266 
 
7 7u83 267 
	i = start;
268 
	while (go) {
269 
		if (!(rs & mask)) {
270 
			if (big) {
271 
				bigregs |= mask;
272 
				if (r == Freg) {
273 
					normal_version = 0;
274 
				}
275 
			}
276 
			regsinproc |= mask;
277 
			return (mask);
278 
		}
279 
		if (i == end) {
280 
			go = 0;
281 
		} else {
282 
			if (rev) {
283 
				i--;
284 
				mask >>= 1;
285 
			} else {
286 
				i++;
287 
				mask <<= 1;
288 
			}
289 
		}
2 7u83 290 
	}
7 7u83 291 
	return (0);
2 7u83 292 
}
293 
 
294 
 
295 
/*
296 
    IS A GIVEN EXPRESSION A USE OF A REUSABLE REGISTER?
297 
 
298 
    This routine returns 0 if the expression e is not a use of a reuseable
299 
    register, and the bitmask of the register otherwise.
300 
*/
301 
 
7 7u83 302 
static long
303 
reuse_check(exp e)
2 7u83 304 
{
7 7u83 305 
	exp id;
306 
	if (name(e) != name_tag) {
307 
		return (0);
308 
	}
309 
	id = son(e);
310 
	if (isglob(id) || pt(id) != reg_pl) {
311 
		return (0);
312 
	}
313 
	return (reuseables & no(id));
2 7u83 314 
}
315 
 
316 
 
317 
/*
318 
    CAN WE REUSE A REGISTER?
319 
 
320 
    This routine checks whether or not we can use a reuseable register to
321 
    store def.  It returns the bitmask of a suitable register if so and 0
322 
    otherwise.
323 
*/
324 
 
7 7u83 325 
static long
326 
reuse(exp def)
2 7u83 327 
{
7 7u83 328 
	switch (name(def)) {
329 
	case name_tag:
330 
		return (reuse_check(def));
331 
	case plus_tag:
332 
	case and_tag:
333 
	case or_tag:
334 
	case xor_tag:
335 
	case mult_tag: {
336 
		/* Allow at most two arguments - check both */
337 
		exp arg1 = son(def);
338 
		exp arg2 = bro(arg1);
339 
		if (last(arg1)) {
340 
			return (reuse_check(arg1));
341 
		}
342 
		if (last(arg2)) {
343 
			return (reuse_check(arg1) || reuse_check(arg2));
344 
		}
345 
		return (0);
2 7u83 346 
	}
7 7u83 347 
	case chvar_tag:
348 
	case neg_tag:
349 
	case not_tag:
350 
		/* Check one argument */
351 
		return (reuse_check(son(def)));
352 
	case minus_tag:
353 
	case subptr_tag:
354 
	case minptr_tag:
355 
	case shl_tag:
356 
	case shr_tag: {
357 
		/* Check two arguments */
358 
		exp arg1 = son(def);
359 
		exp arg2 = bro(arg1);
360 
		return (reuse_check(arg1) || reuse_check(arg2));
2 7u83 361 
	}
362 
	}
7 7u83 363 
	return (0);
2 7u83 364 
}
365 
 
366 
 
367 
/*
368 
    IS AN EXPRESSION GUARANTEED NOT TO USE D0?
369 
 
370 
    Or if it is, are we really careful?
371 
*/
372 
 
7 7u83 373 
static bool
374 
nouse(exp e)
2 7u83 375 
{
7 7u83 376 
	char n = name(e);
377 
	if (n == test_tag) {
378 
		return (1);
379 
	}
380 
	return (0);
2 7u83 381 
}
382 
 
383 
 
384 
/*
385 
    WHERE IS A DECLARATION TO BE PUT?
386 
 
387 
    The routine alloc_variable chooses where to put a declaration. e is the
388 
    declaration, def is the definition (for identity) or initialisation
389 
    (for variable), stack is the ash for the current stack position.
390 
    The place field of the result indicates where the declaration should
391 
    be put (reg_pl, var_pl etc. - see coder.h).  num gives the offset
392 
    (for objects put on the stack) or register mask (for objects put into
393 
    registers).  new_stack gives the ash of the stack after this declaration.
394 
    is_new is a flag indicating a new declaration or a reuse of an old
395 
    declaration.
396 
*/
397 
 
7 7u83 398 
static allocation
399 
alloc_variable(exp e, exp def, ash stack)
2 7u83 400 
{
7 7u83 401 
	ast locast;
402 
	allocation dc;
403 
	bitpattern ru;
2 7u83 404 
 
7 7u83 405 
	unsigned char n = name(def);
406 
	exp s = son(def);
407 
	exp body = bro(def);
408 
	int br = (int)no(e);
2 7u83 409 
 
7 7u83 410 
	bool force_reg = isusereg(e);
411 
	bool big = (props(e) & 0x80 ? 1 : 0);
412 
	bool in_reg1 = 0, in_reg2 = 0, in_reg3 = 1;
2 7u83 413 
 
7 7u83 414 
	dc.new_stack = stack;
415 
	dc.is_new = 1;
2 7u83 416 
 
7 7u83 417 
	if (name(sh(def)) == tophd && !isvis(e)) {
418 
		dc.place = nowhere_pl;
419 
		dc.num = 0;
420 
		return (dc);
421 
	}
2 7u83 422 
 
7 7u83 423 
	if (n == name_tag) {
424 
		in_reg1 = (!isvar(s) && (no(def) == 0 || !isglob(s)));
425 
	} else if (n == cont_tag && name(s) == name_tag) {
426 
		exp t = son(s);
427 
		in_reg2 = (isvar(t) && (no(s) == 0 || !isglob(t)) &&
428 
			   no_side(body));
429 
	}
2 7u83 430 
 
7 7u83 431 
	if (!isvar(e) && (in_reg1 || in_reg2)) {
2 7u83 432 
 
7 7u83 433 
		/* Re-identification or contents of variable not altered in
434 
		 * body */
435 
		if (in_reg1) {
436 
			dc.place = ptno(s);
2 7u83 437 
#ifndef tdf3
7 7u83 438 
			switch (ptno(s)) {
439 
			case var_pl:
440 
				dc.num = no(s) - no(def);
441 
				break;
442 
			case par3_pl:
443 
			case par2_pl:
444 
				dc.num = no(s) - no(def);
445 
				break;
446 
			default:
447 
				dc.num = no(s) + no(def);
448 
			}
2 7u83 449 
#else
7 7u83 450 
			if (ptno(s) == var_pl) {
451 
				dc.num = no(s) - no(def);
452 
			} else {
453 
				dc.num = no(s) + no(def);
454 
			}
2 7u83 455 
#endif
7 7u83 456 
		} else {
457 
			s = son(s);
458 
			dc.place = ptno(s);
459 
			if (ptno(s) == var_pl) {
460 
				dc.num = no(s) - no(son(def));
461 
			} else {
462 
				dc.num = no(s) + no(son(def));
463 
			}
464 
		}
2 7u83 465 
 
7 7u83 466 
		/* We have a declaration */
467 
		if (dc.place == reg_pl) {
468 
			/* If the old one was in registers, reuse it */
469 
			dc.is_new = 0;
470 
			return (dc);
471 
		}
472 
 
473 
		if (!force_reg) {
474 
			if (regable(e)) {
475 
				ru = alloc_reg(sh(def), br, big);
476 
				if (ru) {
477 
					dc.place = reg_pl;
478 
					dc.num = ru;
479 
					return (dc);
480 
				}
481 
			}
482 
			if (isglob(s)) {
483 
				locast = add_shape_to_stack(stack, sh(def));
484 
				dc.new_stack = locast.astash;
485 
				dc.place = var_pl;
486 
				if (locast.astadj) {
487 
					dc.num = locast.astoff + locast.astadj;
488 
				} else {
489 
					dc.num = locast.astash;
490 
				}
491 
				return (dc);
492 
			}
493 
			/* If there was not room, reuse the old dec */
494 
			dc.is_new = 0;
495 
			return (dc);
496 
		}
497 
 
498 
		if (regable(e)) {
499 
			ru = alloc_reg(sh(def), br, big);
500 
			if (ru) {
501 
				dc.place = reg_pl;
502 
				dc.num = ru;
503 
				return (dc);
504 
			}
505 
			if (isglob(s)) {
506 
				locast = add_shape_to_stack(stack, sh(def));
507 
				dc.new_stack = locast.astash;
508 
				dc.place = var_pl;
509 
				if (locast.astadj) {
510 
					dc.num = locast.astoff + locast.astadj;
511 
				} else {
512 
					dc.num = locast.astash;
513 
				}
514 
				return (dc);
515 
			}
516 
			dc.is_new = 0;
517 
			return (dc);
518 
		}
519 
		return (dc);
2 7u83 520 
	}
521 
 
7 7u83 522 
	if (n == apply_tag || n == apply_general_tag || n == tail_call_tag) {
523 
		in_reg3 = result_in_reg(sh(def));
2 7u83 524 
	}
525 
 
7 7u83 526 
	/* Try to allocate in registers */
527 
	if (regable(e) && in_reg3) {
528 
		if ((n == apply_tag || n == apply_general_tag ||
529 
		     n == tail_call_tag) && shtype(sh(def)) != Freg &&
530 
		    nouse(bro(def))) {
531 
			dc.place = reg_pl;
532 
			dc.num = regmsk(REG_D0);
533 
			return (dc);
2 7u83 534 
		}
7 7u83 535 
		if (is_a(n)) {
536 
			long rg = reuse(def) & 0x3cfc;
537 
			if (rg) {
538 
				reuseables &= ~rg;
539 
				dc.place = reg_pl;
540 
				dc.num = rg;
541 
				return (dc);
542 
			}
2 7u83 543 
		}
7 7u83 544 
		ru = alloc_reg(sh(def), br, big);
545 
		if (ru) {
546 
			dc.place = reg_pl;
547 
			dc.num = ru;
548 
			return (dc);
2 7u83 549 
		}
550 
	}
551 
 
7 7u83 552 
	/* Otherwise allocate on the stack */
553 
	locast = add_shape_to_stack(stack, sh(def));
554 
	dc.new_stack = locast.astash;
555 
	dc.place = var_pl;
556 
	if (locast.astadj) {
557 
		dc.num = locast.astoff + locast.astadj;
558 
	} else {
559 
		dc.num = locast.astash;
2 7u83 560 
	}
7 7u83 561 
	return (dc);
2 7u83 562 
}
563 
 
564 
 
565 
/*
566 
    CURRENT SCOPES
567 
 
568 
    These variables are used for the scope and destination of inlined
569 
    procedures.
570 
*/
571 
 
7 7u83 572 
static exp crt_rscope;
573 
static where rscope_dest;
2 7u83 574 
 
575 
 
576 
 
577 
 
578 
/*
579 
    PUSH A SET OF PROCEDURE ARGUMENTS
580 
 
581 
    The arguments are given by a bro-list starting with t.  They are
582 
    coded in reverse order.
583 
*/
584 
 
7 7u83 585 
static void
586 
code_pars(where w, ash stack, exp t)
2 7u83 587 
{
7 7u83 588 
	long sz = shape_size(sh(t));
589 
	if (last(t)) {
590 
		/* Code last argument */
591 
		coder(w, stack, t);
592 
		stack_dec -= round(sz, param_align);
593 
	} else {
594 
		/* Code the following arguments */
595 
		code_pars(w, stack, bro(t));
596 
		/* And then this one */
597 
		coder(w, stack, t);
598 
		stack_dec -= round(sz, param_align);
599 
	}
600 
	return;
2 7u83 601 
}
602 
 
603 
 
604 
/*
605 
    PRODUCE CODE FOR A SOLVE STATEMENT
606 
 
607 
    The solve statement with starter s, labelled statements l, destination
608 
    dest and default jump jr is processed.
609 
*/
610 
 
7 7u83 611 
static void
612 
solve(exp s, exp l, where dest, exp jr, ash stack)
2 7u83 613 
{
7 7u83 614 
	exp t;
615 
	long r1;
2 7u83 616 
 
7 7u83 617 
	while (!last(l)) {
618 
		allocation dc;
619 
		long lb = next_lab();
620 
		exp record = simple_exp(0);
621 
		if (props(son(bro(l))) & 2) {
622 
			setlast(record);
623 
		}
624 
		no(record) = stack;
625 
		sonno(record) = stack_dec;
626 
		ptno(record) = lb;
627 
		pt(son(bro(l))) = record;
628 
		dc = alloc_variable(bro(l), son(bro(l)), stack);
629 
		ptno(bro(l)) = dc.place;
630 
		no(bro(l)) = dc.num;
631 
		l = bro(l);
632 
	}
2 7u83 633 
 
7 7u83 634 
	r1 = regsinuse;
2 7u83 635 
 
7 7u83 636 
	if (name(s) != goto_tag || pt(s) != bro(s)) {
637 
		/* Code the starting expression */
638 
		have_cond = 0;
639 
		coder(dest, stack, s);
2 7u83 640 
	}
7 7u83 641 
	t = s;
2 7u83 642 
 
7 7u83 643 
	do {
644 
		regsinuse = r1;
645 
		if (name(sh(t)) != bothd) {
646 
			make_jump(m_bra, ptno(jr));
647 
		}
648 
		t = bro(t);
649 
		if (no(son(t)) > 0) {
650 
			make_label(ptno(pt(son(t))));
651 
			coder(dest, stack, t);
652 
		}
653 
	} while (!last(t));
654 
 
655 
	regsinuse = r1;
656 
	have_cond = 0;
657 
	return;
2 7u83 658 
}
659 
 
660 
 
661 
/*
662 
    PRODUCE CODE FOR A CASE STATEMENT
663 
 
664 
    The controlling number of the case statement is in the D1 register, from
665 
    which already has been deducted.  The list of options is given as a
666 
    bro-list in arg.  The routine returns the total number which has been
667 
    deducted from D1 at the end.
668 
*/
7 7u83 669 
static long
670 
caser(exp arg, long already)
2 7u83 671 
{
7 7u83 672 
	bool sw, go = 1, diff = 0;
673 
	exp t, jr, jt, split_at;
674 
	shape sha = sh(arg);
675 
	double low, high;
676 
	double lowest = LONG_MAX, highest = LONG_MIN;
677 
	long i, j, n, *jtab;
678 
	long worth = 0;
2 7u83 679 
 
7 7u83 680 
	for (t = bro(arg); go && (t != nilexp); t = bro(t)) {
681 
		if (is_signed(sh(t))) {
682 
			low = no(t);
683 
		}
684 
		else {
685 
			low = (unsigned)no(t);
686 
		}
687 
		if (son(t)) {
688 
			if (is_signed(sh(son(t)))) {
689 
				high = no(son(t));
690 
			} else {
691 
				high = (unsigned)no(son(t));
692 
			}
693 
		} else {
694 
			high = low;
695 
		}
2 7u83 696 
 
7 7u83 697 
		if (low != high) {
698 
			diff = 1;
699 
		}
700 
		if (low < lowest) {
701 
			lowest = low;
702 
		}
703 
		if (high > highest) {
704 
			highest = high;
705 
		}
706 
		worth += (low == high ? 1 : 2);
707 
		if (bro(t) != nilexp) {
708 
			double nextlow;
709 
			if (is_signed(sh(bro(t)))) {
710 
				nextlow = no(bro(t));
711 
			} else {
712 
				nextlow = (unsigned)no(bro(t));
713 
			}
714 
			if ((nextlow / 2) > (high / 2) + 20) {
715 
				split_at = t;
716 
				go = 0;
717 
			}
718 
		}
2 7u83 719 
#ifndef tdf3
7 7u83 720 
		if (high / 2 > low / 2 + 20) {
721 
			worth = 0;
722 
		}
2 7u83 723 
#endif
7 7u83 724 
	}
2 7u83 725 
 
7 7u83 726 
	if (!go) {
727 
		/* Split into two */
728 
		long a;
729 
		exp new = copyexp(arg);
730 
		exp old_bro = bro(split_at);
731 
		bro(new) = old_bro;
732 
		bro(split_at) = nilexp;
733 
		setlast(split_at);
734 
		/* Code the first half */
735 
		a = caser(arg, already);
2 7u83 736 
 
7 7u83 737 
		/* Code the second half */
738 
		return (caser(new, a));
739 
	}
2 7u83 740 
 
7 7u83 741 
	if (worth > 2) {
742 
		/* Construct a jump table */
743 
		mach_op *op1, *op2;
744 
		long rlab = next_lab();
745 
		long tlab = next_lab();
746 
		long slab = next_lab();
747 
		n = highest - lowest + 1;
748 
		jtab = (long *)xcalloc(n, sizeof(long));
2 7u83 749 
 
7 7u83 750 
		for (i = 0; i < n; i++) {
751 
			jtab[i] = rlab;
752 
		}
2 7u83 753 
 
7 7u83 754 
		for (t = bro(arg); t != nilexp; t = bro(t)) {
755 
			if (is_signed(sh(t))) {
756 
				low = no(t);
757 
			} else {
758 
				low = (unsigned)no(t);
759 
			}
760 
			if (son(t)) {
761 
				if (is_signed(sh(son(t)))) {
762 
					high = no(son(t));
763 
				} else {
764 
					high = (unsigned)no(son(t));
765 
				}
766 
			} else {
767 
				high = low;
768 
			}
2 7u83 769 
 
7 7u83 770 
			j = ptno(pt(son(pt(t))));
771 
			for (i = low; i <= high; i++) {
772 
				jtab[i - (long)lowest] = j;
773 
			}
774 
		}
2 7u83 775 
 
7 7u83 776 
		/* Move offset into D1 */
777 
		jt = simple_exp(0);
778 
		ptno(jt) = rlab;
779 
		/*
780 
		 * Subtract the lowest value (minus anything already deducted).
781 
		 */
782 
		sub(slongsh, mnw(lowest - already), D1, D1);
783 
		sw = cmp(slongsh, D1, mnw(highest - lowest), tst_gr);
784 
		branch(tst_gr, jt, 0, sw, 0);
2 7u83 785 
 
7 7u83 786 
		/* Move displacement into D0 */
2 7u83 787 
#if 0
7 7u83 788 
		op1 = make_reg_index(REG_ZA0, REG_D1, 0, 4);
789 
		op1->of->plus->plus = make_lab(slab, 0);
790 
		regsinproc |= regmsk(REG_A0);
791 
		debug_warning("%%za0 used");
2 7u83 792 
#else
7 7u83 793 
		op1 = make_lab_ind(slab, 0);
794 
		i = tmp_reg(m_lea, op1);
795 
		op1 = make_reg_index(i, REG_D1, 0, 4);
2 7u83 796 
#endif
7 7u83 797 
		op2 = make_register(REG_D0);
798 
		make_instr(m_movl, op1, op2, regmsk(REG_D0));
2 7u83 799 
 
7 7u83 800 
		/* Do the jump */
801 
		op1 = make_reg_index(REG_PC, REG_D0, 2, 1);
802 
		make_instr(m_jmp, op1, null, 0);
2 7u83 803 
 
7 7u83 804 
		/* Print out table */
805 
		make_label(tlab);
2 7u83 806 
#ifndef no_align_directives
7 7u83 807 
		make_instr(m_as_align4, null, null, 0);
2 7u83 808 
#endif
7 7u83 809 
		make_label(slab);
810 
		for (i = 0; i < n; i++) {
811 
			op1 = make_lab_diff(jtab[i], tlab);
812 
			make_instr(m_as_long, op1, null, 0);
813 
		}
814 
		make_label(rlab);
815 
 
816 
		/* Return the total number deducted from D1 */
817 
		return (lowest);
2 7u83 818 
	}
819 
 
7 7u83 820 
	/* If 'high' is not always equal to 'low', restore value of D1 */
821 
	if (diff) {
822 
		add(slongsh, D1, mnw(already), D1);
823 
		already = 0;
824 
	}
2 7u83 825 
 
7 7u83 826 
	/* A series of jumps/comparisons */
827 
	for (t = bro(arg); t != nilexp; t = bro(t)) {
828 
		if (is_signed(sh(t))) {
829 
			low = no(t);
830 
		} else {
831 
			low = (unsigned)no(t);
832 
		}
833 
		if (son(t)) {
834 
			if (is_signed(sh(son(t)))) {
835 
				high = no(son(t));
836 
			} else {
837 
				high = (unsigned)no(son(t));
838 
			}
839 
		} else {
840 
			high = low;
841 
		}
2 7u83 842 
 
7 7u83 843 
		jr = pt(son(pt(t)));
844 
		if (low == high) {
845 
			sw = cmp(sha, D1, mnw(low - already), tst_eq);
846 
			branch(tst_eq, jr, 1, sw, 0);
847 
		} else {
848 
			jt = simple_exp(0);
849 
			ptno(jt) = next_lab();
850 
			sw = cmp(sha, D1, mnw(low - already), tst_ls);
851 
			branch(tst_ls, jt, is_signed(sh(t)), sw, 0);
852 
			sw = cmp(sha, D1, mnw((unsigned)(high - already)),
853 
				 tst_le);
854 
			branch(tst_le, jr, is_signed(sh(son(t))), sw, 0);
855 
			make_label(ptno(jt));
856 
		}
2 7u83 857 
	}
7 7u83 858 
	/* Return what has been subtracted from D1 */
859 
	have_cond = 0;
860 
	return (already);
2 7u83 861 
}
862 
 
863 
/*
864 
    RESET STACK POINTER FROM APPLICATIONS POINTER
865 
    sp = AP - (env_size - (sizeof(params) + sizeof(ret-addr) + sizeof(AP)))
866 
*/
867 
 
7 7u83 868 
static void
869 
reset_stack_pointer(void)
2 7u83 870 
{
7 7u83 871 
	mach_op *op1, *op2, *op3;
872 
	make_comment("reset stack pointer ...");
873 
	update_stack();
2 7u83 874 
 
7 7u83 875 
	op1 = make_indirect(REG_AP, 0);
876 
	op2 = op1->of->plus = new_mach_op();
877 
	op2->type = MACH_NEG;
878 
	op2->plus = make_ldisp(4);
2 7u83 879 
 
7 7u83 880 
	op2 = make_register(REG_SP);
881 
	make_instr(m_lea, op1, op2, regmsk(REG_SP));
2 7u83 882 
 
883 
#if 0
7 7u83 884 
	/* gas misinterpret lea a6@( <label> ) if <label> isn't declared ?? */
885 
	op1 = make_indirect(REG_AP, 0);
886 
	op2 = new_mach_op();
887 
	op1->of->plus = op2;
888 
	/* The address of cur_proc_dec is used to form the env_size label */
889 
	op3 = make_lab((long)cur_proc_dec,8+ (cur_proc_callers_size+cur_proc_callees_size) /8);
890 
	op2->type = MACH_NEG;
891 
	op2->plus = op3;
892 
	op2 = make_register(REG_SP);
893 
	make_instr(m_lea, op1, op2, regmsk(REG_SP));
2 7u83 894 
#endif
7 7u83 895 
	make_comment("reset stack pointer done");
2 7u83 896 
}
897 
 
898 
/*
899 
    CHECK UP ON JUMPS
900 
 
901 
    This routine checks for jumps to immediately following labels.
902 
*/
903 
 
7 7u83 904 
static bool
905 
red_jump(exp e, exp la)
2 7u83 906 
{
7 7u83 907 
	if (!last(la) && pt(e) == bro(la)) {
908 
		return (1);
909 
	}
910 
	return (0);
2 7u83 911 
}
912 
 
913 
 
914 
/*
915 
    ALLOW SPACE ON STACK
916 
*/
917 
 
7 7u83 918 
static ash
919 
stack_room(ash stack, where dest, long off)
2 7u83 920 
{
7 7u83 921 
	exp e = dest.wh_exp;
922 
	if (name(e) == ident_tag) {
923 
		if (ptno(e) != var_pl) {
924 
			return (stack);
925 
		}
926 
		if (no(e) + off > stack) {
927 
			stack = no(e) + off;
928 
		}
929 
	}
930 
	return (stack);
2 7u83 931 
}
932 
 
933 
 
934 
/*
935 
    MAIN CODING ROUTINE
936 
 
937 
    This routine is the main coding routine for such things as identity
938 
    definitions and control structures.  Most of the actual expression
939 
    evaluation is dealt with by codec.  The expression e is coded and
940 
    the result put into dest.  The stack argument gives the current
941 
    structure of the stack.
942 
*/
943 
 
7 7u83 944 
void
945 
coder(where dest, ash stack, exp e)
2 7u83 946 
{
7 7u83 947 
	bool sw;
2 7u83 948 
 
7 7u83 949 
	if (e == nilexp) {
950 
		error("Internal coding error");
951 
		return;
952 
	}
2 7u83 953 
 
7 7u83 954 
	switch (name(e)) {
955 
	case ident_tag: {
956 
		long sz;
957 
		int dw = 0;
958 
		allocation dc;
959 
		bool used_once, used_twice;
960 
		bitpattern rg = regsinproc;
961 
		mach_ins *p = current_ins;
2 7u83 962 
 
7 7u83 963 
		/* Find the identity definition and body */
964 
		exp def = son(e);
965 
		exp body = bro(def);
2 7u83 966 
 
7 7u83 967 
		/* Check up on uses */
968 
		exp x = pt(e);
969 
		used_once = (x == nilexp || pt(x) == nilexp);
970 
		used_twice = (used_once || pt(pt(x)) == nilexp);
2 7u83 971 
 
7 7u83 972 
		/* Allocate space for definition */
973 
		if (ismarked(e) && isparam(e) &&  no(e) > 2) {
974 
			/* Rarely used procedure arguments ... */
975 
			dc.is_new = 0;
976 
			dc.place = par_pl;
977 
			dc.num = no(def);
978 
			dc.new_stack = stack;
979 
			extra_weight++;
980 
			dw = 1;
981 
		} else {
982 
			/* And the rest ... */
983 
			dc = alloc_variable(e, def, stack);
984 
		}
2 7u83 985 
 
7 7u83 986 
		/* Mark the declaration */
987 
		ptno(e) = dc.place;
988 
		no(e) = dc.num;
2 7u83 989 
#ifndef tdf3
7 7u83 990 
		make_visible(e);
2 7u83 991 
#endif
7 7u83 992 
		if (dc.place == var_pl) {
993 
			used_stack = 1;
2 7u83 994 
		}
7 7u83 995 
		sz = dc.new_stack;
2 7u83 996 
 
7 7u83 997 
		/* Does the definition need evaluating? */
998 
		if (dc.is_new) {
999 
			if (ptno(e) == nowhere_pl) {
1000 
				/*
1001 
				 * Calculate and discard value if not required
1002 
				 */
1003 
				coder(zero, stack, def);
1004 
			} else {
1005 
				/* Encode the definition */
1006 
				if (ptno(e) == reg_pl) {
1007 
					regsindec |= dc.num;
1008 
				}
1009 
				coder(zw(e), stack, def);
1010 
			}
1011 
 
1012 
			/* Modify regsinuse if a register is being used */
1013 
			if (ptno(e) == reg_pl) {
1014 
				regsindec &= ~dc.num;
1015 
				if (used_once) {
1016 
					regsinuse |= dc.num;
1017 
					reuseables |= dc.num;
1018 
				} else {
1019 
					regsinuse |= dc.num;
1020 
					reuseables &= ~dc.num;
1021 
				}
1022 
			}
1023 
 
1024 
			/* Modify max_stack is the stack is being used */
1025 
			if (ptno(e) == var_pl && sz > max_stack) {
1026 
				max_stack = sz;
1027 
			}
2 7u83 1028 
		}
1029 
 
7 7u83 1030 
		/* Encode the body */
1031 
		coder(dest, dc.new_stack, body);
1032 
		extra_weight -= dw;
2 7u83 1033 
 
7 7u83 1034 
		/* Look for peephole optimizations */
1035 
		if (dc.is_new && pt(e) == reg_pl) {
1036 
			regsinuse &= ~dc.num;
1037 
			if (!output_immediately && p && do_peephole) {
1038 
				if (used_twice && post_inc_check(p, no(e))) {
1039 
					regsinproc = rg;
1040 
					return;
1041 
				}
1042 
			}
2 7u83 1043 
		}
7 7u83 1044 
		return;
2 7u83 1045 
	}
1046 
#ifndef tdf3
1047 
#else
7 7u83 1048 
	case clear_tag:
1049 
		/* Clear means do nothing */
1050 
		return;
2 7u83 1051 
#endif
7 7u83 1052 
	case seq_tag: {
1053 
		/* Sequences */
1054 
		bool no_bottom = 1;
1055 
		exp t = son(son(e));
1056 
		/* Code each sub-expression */
1057 
		while (coder(zero, stack, t),
1058 
		       no_bottom = (name(sh(t)) != bothd),
1059 
		       !last(t))t = bro(t);
1060 
		/* Code the result expression if necessary */
1061 
		if (no_bottom) {
1062 
			coder(dest, stack, bro(son(e)));
1063 
		}
1064 
		return;
2 7u83 1065 
	}
7 7u83 1066 
	case cond_tag: {
1067 
		/* Conditionals */
1068 
		long lb, r1;
1069 
		allocation dc;
1070 
		exp jr, record;
1071 
		bool is_condgoto = 0;
2 7u83 1072 
 
7 7u83 1073 
		/* Find the first and alternative expressions */
1074 
		exp first = son(e);
1075 
		exp alt = bro(first);
2 7u83 1076 
 
7 7u83 1077 
		/* Check for "if cond goto ..." */
1078 
		if (name(bro(son(alt))) == goto_tag) {
1079 
			is_condgoto = 1;
1080 
		}
2 7u83 1081 
 
7 7u83 1082 
		/* Find or create the label */
1083 
		if (is_condgoto) {
1084 
			record = pt(son(pt(bro(son(alt)))));
1085 
		} else {
1086 
			lb = next_lab();
1087 
			record = simple_exp(0);
1088 
			no(record) = stack;
1089 
			sonno(record) = stack_dec;
1090 
			ptno(record) = lb;
1091 
		}
1092 
		no(son(alt)) = ptno(record);
1093 
		pt(son(alt)) = record;
2 7u83 1094 
 
7 7u83 1095 
		/* Allocate space for the alternative expression */
1096 
		dc = alloc_variable(alt, son(alt), stack);
1097 
		ptno(alt) = dc.place;
1098 
		no(alt) = dc.num;
2 7u83 1099 
 
7 7u83 1100 
		/* If first is just a jump to alt, just encode alt */
1101 
		if (name(first) == goto_tag && pt(first) == alt &&
1102 
		    son(first) != nilexp && name(sh(son(first))) == tophd) {
1103 
			coder(dest, stack, bro(son(alt)));
1104 
			return;
1105 
		}
2 7u83 1106 
 
7 7u83 1107 
		/* Code the first expression */
1108 
		reuseables = 0;
1109 
		r1 = regsinuse;
1110 
		coder(dest, stack, first);
2 7u83 1111 
 
7 7u83 1112 
		/* Restore regsinuse */
1113 
		regsinuse = r1;
2 7u83 1114 
 
7 7u83 1115 
		/* If alt is trivial, no further action is required */
1116 
		if (name(bro(son(alt))) == top_tag) {
1117 
			bitpattern ch = last_jump_regs;
1118 
			make_label(ptno(record));
1119 
			if (!is_condgoto && !output_immediately &&
1120 
			    last_jump == lb) {
1121 
				current_ins->changed = ch;
1122 
			}
1123 
			return;
1124 
		}
2 7u83 1125 
 
7 7u83 1126 
		/* No further action is required for conditional gotos */
1127 
		if (is_condgoto) {
1128 
			return;
2 7u83 1129 
		}
1130 
 
7 7u83 1131 
		/* If first doesn't end with a jump, add one */
1132 
		if (name(sh(first)) != bothd) {
1133 
			long lb2 = next_lab();
1134 
			jr = simple_exp(0);
1135 
			ptno(jr) = lb2;
1136 
			make_jump(m_bra, lb2);
1137 
		}
2 7u83 1138 
 
7 7u83 1139 
		/* Encode the alternative expression */
1140 
		reuseables = 0;
1141 
		make_label(ptno(record));
1142 
		coder(dest, stack, alt);
1143 
		regsinuse = r1;
1144 
		reuseables = 0;
2 7u83 1145 
 
7 7u83 1146 
		/* Output the label for the jump added to first if necessary */
1147 
		if (name(sh(first)) != bothd) {
1148 
			make_label(ptno(jr));
1149 
			retcell(jr);
1150 
		}
1151 
		have_cond = 0;
1152 
		retcell(record);
1153 
		return;
2 7u83 1154 
	}
7 7u83 1155 
	case labst_tag: {
1156 
		/* Labelled statements */
1157 
		allocation dc;
1158 
		have_cond = 0;
2 7u83 1159 
 
7 7u83 1160 
		/* Is there long jump access to this label ? */
1161 
		if (is_loaded_lv(e)) {
1162 
			if (need_preserve_stack)
1163 
				restore_stack();
1164 
			else if (!has_alloca)
1165 
				reset_stack_pointer();
1166 
		}
2 7u83 1167 
 
7 7u83 1168 
		/* Allocate space */
1169 
		dc = alloc_variable(e, son(e), stack);
1170 
		if (dc.place == reg_pl) {
1171 
			regsinuse |= dc.num;
1172 
			reuseables &= ~dc.num;
1173 
		}
2 7u83 1174 
 
7 7u83 1175 
		/* Encode the body */
1176 
		coder(dest, stack, bro(son(e)));
2 7u83 1177 
 
7 7u83 1178 
		/* Update max_stack and regsinuse */
1179 
		if (dc.place == var_pl) {
1180 
			if (dc.new_stack > max_stack) {
1181 
				max_stack = dc.new_stack;
1182 
			}
1183 
		}
1184 
		if (dc.place == reg_pl) {
1185 
			regsinuse &= (~dc.num);
1186 
		}
1187 
		return;
2 7u83 1188 
	}
7 7u83 1189 
	case rep_tag: {
1190 
		/* Loops */
1191 
		long lb;
1192 
		exp record;
1193 
		allocation dc;
2 7u83 1194 
 
7 7u83 1195 
		/* Find the starter and the body of the loop */
1196 
		exp start = son(e);
1197 
		exp body = bro(start);
2 7u83 1198 
 
7 7u83 1199 
		/* Allocate space */
1200 
		dc = alloc_variable(body, son(body), stack);
1201 
		ptno(body) = dc.place;
1202 
		no(body) = dc.num;
2 7u83 1203 
 
7 7u83 1204 
		/* Code the starter of the loop */
1205 
		coder(zw(body), stack, start);
2 7u83 1206 
 
7 7u83 1207 
		/* Create the repeat label */
1208 
		lb = next_lab();
1209 
		make_label(lb);
1210 
		record = simple_exp(0);
1211 
		setlast(record);
1212 
		no(record) = stack;
1213 
		sonno(record) = stack_dec;
1214 
		ptno(record) = lb;
1215 
		pt(son(body)) = record;
1216 
		reuseables = 0;
2 7u83 1217 
 
7 7u83 1218 
		/* Encode the body of the loop */
1219 
		coder(dest, stack, body);
1220 
		retcell(record);
1221 
		return;
2 7u83 1222 
	}
7 7u83 1223 
	case goto_tag: {
1224 
		/* Jumps */
1225 
		exp lab;
2 7u83 1226 
 
7 7u83 1227 
		/* Try to avoid unnecessary jumps */
1228 
		if (last(e) && name(bro(e)) == seq_tag &&
1229 
		    name(bro(bro(e))) == labst_tag &&
1230 
		    red_jump(e, bro(e))) {
1231 
			return;
1232 
		}
2 7u83 1233 
 
7 7u83 1234 
		/* Output the jump */
1235 
		lab = pt(e);
1236 
		make_jump(m_bra, ptno(pt(son(lab))));
1237 
		reuseables = 0;
1238 
		return;
2 7u83 1239 
	}
7 7u83 1240 
	case goto_lv_tag: {
1241 
		exp dest_exp = son(e); /* destination label */
1242 
		exp cont_exp = getexp(sh(dest_exp), nilexp, 1, dest_exp,
1243 
				      nilexp, 0, 0, cont_tag);
1244 
		where wh;
1245 
		mach_op *op;
1246 
		wh = zw(cont_exp);
1247 
		wh.wh_is = RegInd;
1248 
		op = operand(32,wh);
1249 
		/*epilogue(1);*/
1250 
		make_instr(m_jmp,op,null,~save_msk);
1251 
		/*ins1(m_jmp,32,D0,0);*/
1252 
		return;
2 7u83 1253 
	}
1254 
#ifndef tdf3
7 7u83 1255 
	case return_to_label_tag: {
1256 
		exp dest_lab = son(e);
2 7u83 1257 
 
7 7u83 1258 
		make_comment("return_to_label ...");
2 7u83 1259 
 
7 7u83 1260 
		move(slongsh, zw(dest_lab), A0);
1261 
		restore_regs(ALL);
1262 
		make_instr(m_jmp,operand(32,A0_p),null,~save_msk);
2 7u83 1263 
 
7 7u83 1264 
		make_comment("return_to_label done");
1265 
		return;
1266 
	}
2 7u83 1267 
#endif
7 7u83 1268 
	case long_jump_tag: {
1269 
		exp new_env = son(e);
1270 
		exp dest_lab = bro(new_env);
1271 
		make_comment("long_jump");
2 7u83 1272 
 
7 7u83 1273 
		move(sh(dest_lab),zw(dest_lab),A0);
1274 
		move(sh(new_env),zw(new_env),A1);
2 7u83 1275 
 
7 7u83 1276 
		/* restore all registers but A6 or SP */
1277 
		restore_regs(NOT_A6_OR_SP);
2 7u83 1278 
 
7 7u83 1279 
		move(sh(new_env),A1,AP);
1280 
		make_instr(m_jmp,operand(32,A0_p),null,~save_msk);
1281 
		return;
2 7u83 1282 
	}
7 7u83 1283 
	case test_tag: {
1284 
		/* Tests */
1285 
		exp qwe;
1286 
		where qw;
1287 
		bool sg = 1, sf = 0;
1288 
		int shn;
2 7u83 1289 
 
7 7u83 1290 
		/* Find the test number */
1291 
		long test_n = (long)props(e);
2 7u83 1292 
 
7 7u83 1293 
		/* Find the expressions being compared */
1294 
		exp arg1 = son(e);
1295 
		exp arg2 = bro(arg1);
2 7u83 1296 
 
7 7u83 1297 
		/* Find the label to be jumped to */
1298 
		exp lab_exp = pt(e);
1299 
		exp jr = pt(son(lab_exp));
2 7u83 1300 
 
7 7u83 1301 
		/* If arg1 is not an operand, code it into D1 */
1302 
		if (!is_o(name(arg1))) {
1303 
			qwe = sim_exp(sh(arg1), D1);
1304 
			qw = zw(qwe);
1305 
			regsinproc |= regmsk(REG_D1);
1306 
			coder(qw, stack, arg1);
1307 
			arg1 = qwe;
1308 
		}
2 7u83 1309 
 
7 7u83 1310 
		/* If arg2 is not an operand, code it into D1 */
1311 
		if (!is_o(name(arg2))) {
1312 
			qwe = sim_exp(sh(arg2), D1);
1313 
			qw = zw(qwe);
1314 
			regsinproc |= regmsk(REG_D1);
1315 
			coder(qw, stack, arg2);
1316 
			arg2 = qwe;
1317 
		}
2 7u83 1318 
 
7 7u83 1319 
		/* Look for unsigned or floating tests */
1320 
		shn = name(sh(arg1));
2 7u83 1321 
 
7 7u83 1322 
		switch (shn) {
1323 
		case ucharhd:
1324 
		case uwordhd:
1325 
		case ulonghd:
1326 
		case u64hd:
1327 
			sg = 0;
1328 
			break;
1329 
		case shrealhd:
1330 
		case realhd:
1331 
		case doublehd:
1332 
			sg = 0;
1333 
			sf = 1;
1334 
			break;
1335 
		}
2 7u83 1336 
 
7 7u83 1337 
		/* Certain comparisons with 1 or -1 can be changed */
1338 
		if (name(arg1) == val_tag) {
1339 
			long d = no(arg1);
1340 
			if (is_offset(arg1)) {
1341 
				d /= 8;
1342 
			}
1343 
			if (d == 1) {
1344 
				if (test_n == tst_le) {
1345 
					/* 1 <= x becomes 0 < x */
1346 
					test_n = tst_ls;
1347 
					no(arg1) = 0;
1348 
				} else if (test_n == tst_gr) {
1349 
					/* 1 > x becomes 0 >= x */
1350 
					test_n = tst_ge;
1351 
					no(arg1) = 0;
1352 
				}
1353 
			} else if (d == -1 && sg) {
1354 
				if (test_n == tst_ls) {
1355 
					/* -1 < x becomes 0 <= x */
1356 
					test_n = tst_le;
1357 
					no(arg1) = 0;
1358 
				} else if (test_n == tst_ge) {
1359 
					/* -1 >= x becomes 0 > x */
1360 
					test_n = tst_gr;
1361 
					no(arg1) = 0;
1362 
				}
1363 
			}
2 7u83 1364 
		}
1365 
 
7 7u83 1366 
		/* Certain other comparisons with 1 or -1 can be changed */
1367 
		if (name(arg2) == val_tag) {
1368 
			long d = no(arg2);
1369 
			if (is_offset(arg2)) {
1370 
				d /= 8;
1371 
			}
1372 
			if (d == 1) {
1373 
				if (test_n == tst_ge) {
1374 
					/* x >= 1 becomes x > 0 */
1375 
					test_n = tst_gr;
1376 
					no(arg2) = 0;
1377 
				} else if (test_n == tst_ls) {
1378 
					/* x < 1 becomes x <= 0 */
1379 
					test_n = tst_le;
1380 
					no(arg2) = 0;
1381 
				}
1382 
			} else if (d == -1 && sg) {
1383 
				if (test_n == tst_gr) {
1384 
					/* x > -1 becomes x >= 0 */
1385 
					test_n = tst_ge;
1386 
					no(arg2) = 0;
1387 
				} else if (test_n == tst_le) {
1388 
					/* x <= 1 becomes x < 0 */
1389 
					test_n = tst_ls;
1390 
					no(arg2) = 0;
1391 
				}
1392 
			}
2 7u83 1393 
		}
7 7u83 1394 
		if (shn == u64hd || shn == s64hd) {
1395 
			where w1, w2;
1396 
			w1 = zw(arg1);
1397 
			w2 = zw(arg2);
2 7u83 1398 
 
7 7u83 1399 
			/* compare low word (unsigned) */
1400 
			sw = cmp(ulongsh, w1, w2, test_n);
1401 
			branch(test_n, jr, sg, sw, sf);
2 7u83 1402 
 
7 7u83 1403 
			/* compare high word */
1404 
			w1.wh_off += 32;
1405 
			w2.wh_off += 32;
1406 
			if (sg) {
1407 
				sw = cmp(slongsh, w1, w2, test_n);
1408 
			} else {
1409 
				sw = cmp(ulongsh, w1, w2, test_n);
1410 
			}
1411 
			branch(test_n, jr, sg, sw, sf);
2 7u83 1412 
 
7 7u83 1413 
			return;
1414 
		}
2 7u83 1415 
 
7 7u83 1416 
		/* Code the comparison */
1417 
		sw = cmp(sh(arg1), zw(arg1), zw(arg2), test_n);
2 7u83 1418 
 
7 7u83 1419 
		/* Output the condition jump */
1420 
		branch(test_n, jr, sg, sw, sf);
1421 
		return;
2 7u83 1422 
	}
7 7u83 1423 
	case testbit_tag: {
1424 
		/* Bit tests */
1425 
		exp qwe;
1426 
		where qw;
2 7u83 1427 
 
7 7u83 1428 
		/* Find the arguments */
1429 
		exp arg1 = son(e);
1430 
		exp arg2 = bro(arg1);
2 7u83 1431 
 
7 7u83 1432 
		/* Find the label to be jumped to */
1433 
		exp lab_exp = pt(e);
1434 
		exp jr = pt(son(lab_exp));
2 7u83 1435 
 
7 7u83 1436 
		/* If arg1 is not an operand, code it into D1 */
1437 
		if (!is_o(name(arg1))) {
1438 
			qwe = sim_exp(sh(arg1), D1);
1439 
			qw = zw(qwe);
1440 
			regsinproc |= regmsk(REG_D1);
1441 
			coder(qw, stack, arg1);
1442 
			arg1 = qwe;
1443 
		}
2 7u83 1444 
 
7 7u83 1445 
		/* If arg2 is not an operand, code it into D1 */
1446 
		if (!is_o(name(arg2))) {
1447 
			qwe = sim_exp(sh(arg2), D1);
1448 
			qw = zw(qwe);
1449 
			regsinproc |= regmsk(REG_D1);
1450 
			coder(qw, stack, arg2);
1451 
			arg2 = qwe;
1452 
		}
2 7u83 1453 
 
7 7u83 1454 
		/* Code the test */
1455 
		bit_test(sh(arg1), zw(arg1), zw(arg2));
2 7u83 1456 
 
7 7u83 1457 
		/* Output the conditional jump */
1458 
		branch((long)props(e), jr, 1, 0, 0);
1459 
		return;
2 7u83 1460 
	}
7 7u83 1461 
	case ass_tag:
1462 
	case assvol_tag: {
1463 
		/* Variable assignments */
1464 
		exp assdest = son(e);
1465 
		exp assval = bro(assdest);
1466 
		make_comment("assign ...");
1467 
		if (name(sh(assval)) == bitfhd) {
1468 
			int_to_bitf(assval, e, stack);
1469 
			return;
1470 
		}
1471 
		codec(zw(e), stack, assval);
1472 
		make_comment("assign done");
1473 
		return;
2 7u83 1474 
	}
7 7u83 1475 
	case nof_tag: {
1476 
		shape sha;
1477 
		long crt, off;
1478 
		exp v = son(e);
2 7u83 1479 
 
7 7u83 1480 
		if (v == nilexp) {
1481 
			return;
1482 
		}
1483 
		if (name(dest.wh_exp) == val_tag) {
1484 
			return;
1485 
		}
2 7u83 1486 
 
7 7u83 1487 
		sha = sh(v);
1488 
		crt = dest.wh_off;
1489 
		off = rounder(shape_size(sha), shape_align(sha));
2 7u83 1490 
 
7 7u83 1491 
		while (1) {
1492 
			where wh;
1493 
			ash stack2;
1494 
			wh = mw(dest.wh_exp, crt);
1495 
			stack2 = stack_room(stack, dest, off + crt);
1496 
			coder(wh, stack2, v);
1497 
			if (last(v)) {
1498 
				return;
1499 
			}
1500 
			crt += off;
1501 
			v = bro(v);
1502 
		}
1503 
		/* Not reached */
2 7u83 1504 
	}
7 7u83 1505 
	case ncopies_tag: {
1506 
		where wh;
1507 
		long n = no(e);
1508 
		shape sha = sh(son(e));
1509 
		long sz = rounder(shape_size(sha), shape_align(sha));
1510 
		if (n == 0) {
1511 
			return;
2 7u83 1512 
		}
7 7u83 1513 
		if (name(dest.wh_exp) == val_tag) {
1514 
			return;
1515 
		}
1516 
		if (n == 1) {
1517 
			coder(dest, stack, son(e));
1518 
			return;
1519 
		}
1520 
		if (sz == 8 || sz == 16 || sz == 32) {
1521 
			coder(D1, stack, son(e));
1522 
			regsinproc |= regmsk(REG_D1);
1523 
			if (n <= 10) {
1524 
				long i;
1525 
				for (i = 0; i < n; i++) {
1526 
					wh = mw(dest.wh_exp,
1527 
						dest.wh_off + i * sz);
1528 
					move(sha, D1, wh);
1529 
				}
1530 
				return;
1531 
			} else {
1532 
				mach_op *op1, *op2;
1533 
				long lab = next_lab();
1534 
				int instr = ins(sz, ml_mov);
1535 
				mova(dest, A0);
1536 
				regsinproc |= regmsk(REG_A0);
1537 
				move(slongsh, mnw(n - 1), D0);
1538 
				make_label(lab);
1539 
				op1 = make_register(REG_D1);
1540 
				op2 = make_postinc(REG_A0);
1541 
				make_instr(instr, op1, op2, regmsk(REG_A0));
1542 
				op1 = make_register(REG_D0);
1543 
				op2 = make_lab_data(lab, 0);
1544 
				make_instr(m_dbf, op1, op2, regmsk(REG_D0));
1545 
				return;
1546 
			}
1547 
		}
1548 
		coder(dest, stack, son(e));
1549 
		wh = mw(dest.wh_exp, dest.wh_off + sz);
1550 
		move_bytes(sz *(n - 1), dest, wh, 0);
1551 
		return;
2 7u83 1552 
	}
7 7u83 1553 
	case concatnof_tag: {
1554 
		ash stack2;
1555 
		exp a1 = son(e);
1556 
		exp a2 = bro(a1);
1557 
		long off = dest.wh_off + shape_size(sh(a1));
1558 
		coder(dest, stack, a1);
1559 
		stack2 = stack_room(stack, dest, off);
1560 
		coder(mw(dest.wh_exp, off), stack2, a2);
1561 
		return;
2 7u83 1562 
	}
1563 
#ifndef tdf3
7 7u83 1564 
	case apply_tag:
1565 
	case apply_general_tag:
1566 
		apply_general_proc(e, dest, stack);
1567 
		return;
1568 
	case tail_call_tag: {
1569 
		int old_stack_dec = stack_dec;
1570 
		tail_call(e, dest, stack);
1571 
		stack_dec = old_stack_dec;
1572 
		return;
1573 
	}
1574 
	case caller_tag:
1575 
		coder(dest, stack, son(e));
1576 
		return;
1577 
	case trap_tag:
1578 
		trap_ins(no(e));
1579 
		return;
2 7u83 1580 
#endif
1581 
#if 0
7 7u83 1582 
	case apply_tag: {
1583 
		/* Procedure applications */
2 7u83 1584 
#ifndef tdf3
1585 
#else
7 7u83 1586 
		static int apply_tag_flag = 0;
2 7u83 1587 
#endif
7 7u83 1588 
		exp t;
1589 
		ash st;
1590 
		long comp_room = 0;
1591 
		long longs = 0, stkdec;
1592 
		long start_stack = stack_dec;
1593 
		bool use_push = 1, reg_res;
2 7u83 1594 
 
7 7u83 1595 
		/* Find the procedure and the arguments */
1596 
		exp proc = son(e);
1597 
		exp arg = (last(proc)? nilexp : bro(proc));
2 7u83 1598 
 
1599 
 
1600 
#if 0
7 7u83 1601 
		/*
1602 
		 * Not a normal procedure call, but a way to specify a debuger
1603 
		 * break point.
1604 
		 */
1605 
		if ((brog(son(proc)) ->dec_u.dec_val.processed) &&
1606 
		    (brog(son(proc)) ->dec_u.dec_val.extnamed) &&
1607 
		    (!strcmp(brog(son(proc))->dec_u.dec_val.dec_id,
1608 
			     "_TESTPOINT"))) {
1609 
			TESTPOINT();
1610 
			return;
1611 
		}
2 7u83 1612 
#endif
1613 
 
7 7u83 1614 
		make_comment("Call Normal Proc");
1615 
		/* See if we can push all the arguments */
1616 
		st = 0;
1617 
		if (arg != nilexp) {
1618 
			t = arg;
1619 
			while (t != nilexp) {
1620 
				ast a;
1621 
				if (cpd_param(sh(t))) {
1622 
					use_push = 0;
1623 
				}
1624 
				if ((name(sh(t)) == s64hd) ||
1625 
				    (name(sh(t)) == u64hd)) {
1626 
					use_push = 0;
1627 
				}
1628 
				if (!push_arg(t)) {
1629 
					use_push = 0;
1630 
				}
1631 
				a = add_shape_to_stack(st, sh(t));
1632 
				st = a.astash;
2 7u83 1633 
 
7 7u83 1634 
				t = (last(t) ? nilexp : bro(t));
1635 
			}
2 7u83 1636 
		}
7 7u83 1637 
		longs = st;
2 7u83 1638 
 
7 7u83 1639 
		/* Does the result go into a register? */
1640 
		reg_res = result_in_reg(sh(e));
1641 
		if (!reg_res) {
1642 
			if (eq_where(dest, zero)) {
1643 
				/* Calculate room for ignored compound result */
1644 
				/* todo: use symbol instead of 32 */
1645 
				comp_room = round(shape_size(sh(e)), 32);
1646 
			}
2 7u83 1647 
		}
1648 
 
7 7u83 1649 
		/* Find total amount of stack decrease */
1650 
		stkdec = longs + comp_room;
2 7u83 1651 
 
7 7u83 1652 
		/* Put arguments onto stack */
1653 
		if (use_push) {
1654 
			make_comment("Push callers");
1655 
			if (comp_room) {
1656 
				/* Make room for unwanted compound result */
1657 
				dec_stack(comp_room);
1658 
				stack_dec -= comp_room;
1659 
			}
1660 
			/* Push the arguments */
1661 
			if (arg != nilexp) {
1662 
				code_pars(zw(e), stack, arg);
1663 
			}
1664 
		} else {
1665 
			make_comment("Place callers");
1666 
			/* Decrease stack */
1667 
			if (stkdec) {
1668 
				dec_stack(stkdec);
1669 
			}
1670 
			stack_dec -= stkdec;
1671 
			/* Indicate recursive calls */
1672 
			apply_tag_flag++;
1673 
			/* Encode the arguments onto the stack */
1674 
			st = 0;
1675 
			t = arg;
1676 
			while (t != nilexp) {
1677 
				ast a;
1678 
				where stp;
1679 
				long adj = 0;
1680 
				char nc = name(sh(t));
1681 
				if (nc == scharhd || nc == ucharhd) {
1682 
					adj = 24;
1683 
				}
1684 
				if (nc == swordhd || nc == uwordhd) {
1685 
					adj = 16;
1686 
				}
1687 
				stp = mw(SP_p.wh_exp, st + adj);
1688 
				coder(stp, stack, t);
1689 
				a = add_shape_to_stack(st, sh(t));
1690 
				st = a.astash;
1691 
				t = (last(t)? nilexp : bro(t));
1692 
			}
1693 
			apply_tag_flag--;
2 7u83 1694 
		}
7 7u83 1695 
		start_stack -= stack_dec;
2 7u83 1696 
 
7 7u83 1697 
		/*
1698 
		 * For results which do not fit into registers a pointer to
1699 
		 * where the result is to be put is passed in in A1.
1700 
		 */
1701 
		if (!reg_res) {
1702 
			if (comp_room) {
1703 
				/*
1704 
				 * Find the space allocated for unwanted
1705 
				 * results.
1706 
				 */
1707 
				where w;
1708 
				w = mnw(longs / 8);
1709 
				add(slongsh, SP, w, A1);
2 7u83 1710 
			} else {
7 7u83 1711 
				/*
1712 
				 * Find the address of where the result is to
1713 
				 * be put.
1714 
				 */
1715 
				tmp_reg_prefer = REG_A1;
1716 
				if (apply_tag_flag) {
1717 
					/*
1718 
					 * For recursive calls we need to be
1719 
					 * very careful if the result is itself
1720 
					 * to be a procedure argument to get
1721 
					 * the right stack offset.
1722 
					 */
1723 
					long ex = extra_stack;
1724 
					long doff = dest.wh_off;
1725 
					extra_stack += start_stack;
1726 
					dest.wh_off = 0;
1727 
					if (eq_where(dest, SP_p)) {
1728 
						/* Careful! */
1729 
						dest.wh_off = doff +
1730 
						    extra_stack;
1731 
						mova(dest, A1);
1732 
						dest.wh_off = doff;
1733 
					} else {
1734 
						/* Easy */
1735 
						dest.wh_off = doff;
1736 
						mova(dest, A1);
1737 
					}
1738 
					extra_stack = ex;
1739 
				} else {
1740 
					/* Otherwise (easy) ... */
1741 
					mova(dest, A1);
1742 
				}
2 7u83 1743 
			}
7 7u83 1744 
			/* Make sure we don't reuse A1 accidently */
1745 
			avoid_tmp_reg(REG_A1);
1746 
			regsinproc |= regmsk(REG_A1);
2 7u83 1747 
		}
1748 
 
7 7u83 1749 
		/* Output the call instruction */
1750 
		callins(longs, son(e));
1751 
		stack_dec += stkdec;
1752 
		have_cond = 0;
2 7u83 1753 
 
7 7u83 1754 
		/* Throw away unwanted compound result */
1755 
		if (comp_room) {
1756 
			dec_stack(-comp_room);
1757 
			return;
1758 
		}
2 7u83 1759 
 
7 7u83 1760 
		/* Throw away unwanted simple result */
1761 
		if (eq_where(dest, zero)) {
1762 
			return;
1763 
		}
2 7u83 1764 
 
7 7u83 1765 
		/* Now move the result into place */
1766 
		if (reg_res) {
1767 
			if (shape_size(sh(e)) <= 32) {
1768 
				/* Small register results are in D0 */
1769 
				move(sh(e), D0, dest);
1770 
				return;
1771 
			} else {
1772 
				/* Larger register results are in D0 and D1 */
2 7u83 1773 
#ifdef SYSV_ABI
7 7u83 1774 
				move(sh(e), FP0, dest);
2 7u83 1775 
#else
7 7u83 1776 
				move(sh(e), D0_D1, dest);
1777 
				regsinproc |= regmsk(REG_D1);
2 7u83 1778 
#endif
7 7u83 1779 
				return;
1780 
			}
1781 
		} else {
1782 
			/*
1783 
			 * Compound results should already have been copied to
1784 
			 * the position pointed to by A1 by the called
1785 
			 * procedure and returned by it in D0, so no further
1786 
			 * action should be required by the calling procedure.
1787 
			 * Unfortunately cc doesn't always get this right for
1788 
			 * union results.
1789 
			 */
2 7u83 1790 
#ifdef OLD_SPEC
7 7u83 1791 
			if (cc_conventions && name(sh(e)) == unhd) {
1792 
				regsinproc |= regmsk(REG_A0);
1793 
				move(slongsh, D0, A0);
1794 
				move(sh(e), A0_p, dest);
1795 
			}
1796 
#endif
1797 
			return;
2 7u83 1798 
		}
1799 
	}
1800 
#endif
7 7u83 1801 
	case alloca_tag: {
1802 
		/* Local memory allocation */
1803 
		exp s = son(e);
1804 
		where size_w;
1805 
		bool allocation_done = 0;
1806 
		used_stack = 1;
2 7u83 1807 
 
7 7u83 1808 
		make_comment("Allocate ...");
2 7u83 1809 
 
7 7u83 1810 
		/* Create a where representing the value to be allocated */
2 7u83 1811 
 
7 7u83 1812 
		if (name(s) == val_tag) {
1813 
			long off = no(s);
1814 
			if (!is_offset(s)) {
1815 
				off *= 8;
1816 
			}
1817 
			off = rounder(off, stack_align);
2 7u83 1818 
 
7 7u83 1819 
			if (checkalloc(e)) {
1820 
				size_w = mw(zeroe, off / 8);
1821 
			} else {
1822 
				/* simple allocation of constant */
1823 
				dec_stack(off);
1824 
				allocation_done = 1;
1825 
			}
1826 
		} else {
1827 
			size_w = zw(s);
1828 
		}
2 7u83 1829 
 
7 7u83 1830 
		/* Allocate (checked or not) */
2 7u83 1831 
 
7 7u83 1832 
		if (!allocation_done)
1833 
			if (checkalloc(e)) {
1834 
				checkalloc_stack(size_w, 1);
1835 
			} else {
1836 
				sub(slongsh, size_w, SP, SP);
1837 
			}
2 7u83 1838 
 
7 7u83 1839 
		/* The result of the construct is SP */
2 7u83 1840 
 
7 7u83 1841 
		if (!eq_where(dest, zero)) {
1842 
			move(sh(e), SP, dest);
1843 
		}
2 7u83 1844 
 
7 7u83 1845 
		have_cond = 0;
2 7u83 1846 
 
7 7u83 1847 
		if (need_preserve_stack) {
1848 
			save_stack();
1849 
		}
2 7u83 1850 
 
7 7u83 1851 
		make_comment("Allocate done");
1852 
		return;
2 7u83 1853 
	}
7 7u83 1854 
	case last_local_tag:
1855 
		make_comment("last_local ...");
1856 
		move(sh(e), SP, dest);
1857 
		make_comment("last_local done");
1858 
		return;
1859 
	case local_free_tag: {
1860 
		exp base = son(e);
1861 
		exp offset = bro(base);
1862 
		exp s_a0 = sim_exp(sh(base),A0);
1863 
		where w_a0;
1864 
		w_a0 = zw(s_a0);
2 7u83 1865 
 
7 7u83 1866 
		make_comment("local_free ...");
2 7u83 1867 
 
7 7u83 1868 
		coder(w_a0,stack,base);
2 7u83 1869 
 
7 7u83 1870 
		if (name(offset) == val_tag) {
1871 
			long off = no(offset);
1872 
			where size_w;
2 7u83 1873 
 
7 7u83 1874 
			if (!is_offset(offset)) {
1875 
				off *= 8;
1876 
			}
1877 
			off = rounder(off, stack_align) / 8;
1878 
			size_w = mw(zeroe, off);
1879 
			add(sh(offset),A0,zw(offset),SP);
1880 
		} else {
1881 
			exp s_d0 = sim_exp(sh(offset),D0);
1882 
			where w_d0;
1883 
			w_d0 = zw(s_d0);
1884 
			coder(w_d0,stack,offset);
1885 
			add(sh(offset),mnw(7),D0,D0);
1886 
			and(sh(offset),D0,mnw(~7),D0);
1887 
			add(sh(offset),A0,D0,SP);
1888 
		}
2 7u83 1889 
 
7 7u83 1890 
		if (need_preserve_stack) {
1891 
			save_stack();
1892 
		}
2 7u83 1893 
 
7 7u83 1894 
		make_comment("local_free done");
2 7u83 1895 
 
7 7u83 1896 
		return;
2 7u83 1897 
	}
7 7u83 1898 
	case local_free_all_tag: {
1899 
		mach_op *op1, *op2;
1900 
		must_use_bp = 1;
1901 
		make_comment("local_free_all ...");
1902 
		reset_stack_pointer();
1903 
		if (need_preserve_stack) {
1904 
			save_stack();
1905 
		}
1906 
		make_comment("local_free_all done");
1907 
		return;
2 7u83 1908 
	}
1909 
 
1910 
#ifndef tdf3
7 7u83 1911 
	case untidy_return_tag:
2 7u83 1912 
#endif
7 7u83 1913 
	case res_tag:
1914 
		/* Procedure results */
1915 
		have_cond = 0;
2 7u83 1916 
 
7 7u83 1917 
		/* Has the procedure been inlined? */
1918 
		if (crt_rscope == 0) {
2 7u83 1919 
 
7 7u83 1920 
			/* Non-inlined procedures */
1921 
			shape rsha = sh(son(e));
2 7u83 1922 
 
7 7u83 1923 
			/* Does the result go into a register? */
1924 
			if (result_in_reg(rsha)) {
1925 
				if (shape_size(rsha) <= 32) {
1926 
					/* Small register results go into D0 */
1927 
					coder(D0, stack, son(e));
1928 
				} else {
2 7u83 1929 
#ifdef SYSV_ABI
7 7u83 1930 
					coder(FP0, stack, son(e));
2 7u83 1931 
#else
7 7u83 1932 
					/*
1933 
					 * Larger register results go into D0
1934 
					 * and D1.
1935 
					 */
1936 
					coder(D0_D1, stack, son(e));
1937 
					regsinproc |= regmsk(REG_D1);
2 7u83 1938 
#endif
7 7u83 1939 
				}
1940 
				/* Jump to the return label */
1941 
				if (name(rsha) != bothd) {
2 7u83 1942 
#ifndef tdf3
7 7u83 1943 
					if (name(e) == untidy_return_tag) {
1944 
						untidy_return();
1945 
					} else
2 7u83 1946 
#endif
7 7u83 1947 
						make_jump(m_bra, crt_ret_lab);
1948 
				}
1949 
				return;
1950 
			}
2 7u83 1951 
 
7 7u83 1952 
			/* Otherwise the result has to be encoded into the
1953 
			 * position pointed to by A1 at the start of the
1954 
			 * procedure. This value was stored in A6_4. The value
1955 
			 * of this pointer is returned in D0.
1956 
			 */
1957 
			if (name(son(e)) == apply_tag ||
1958 
			    name(son(e)) == apply_general_tag) {
1959 
				coder(A6_4_p, stack, son(e));
1960 
			} else {
1961 
				codec(A6_4_p, stack, son(e));
1962 
			}
2 7u83 1963 
#ifdef SYSV_ABI
7 7u83 1964 
			move(slongsh, A6_4, A1);
2 7u83 1965 
#else
7 7u83 1966 
			move(slongsh, A6_4, D0);
2 7u83 1967 
#endif
7 7u83 1968 
			regsinproc |= regmsk(REG_A1);
2 7u83 1969 
#ifndef tdf3
7 7u83 1970 
			if (name(e) == untidy_return_tag) {
1971 
				untidy_return();
1972 
			} else
2 7u83 1973 
#endif
7 7u83 1974 
				make_jump(m_bra, crt_ret_lab);
1975 
			return;
1976 
		} else {
1977 
			/*
1978 
			 * For inlined procedures, the result goes into
1979 
			 * rscope_dest and a jump is made to crt_rscope.
1980 
			 */
1981 
			coder(rscope_dest, stack, son(e));
2 7u83 1982 
#ifndef tdf3
7 7u83 1983 
			if (name(e) == untidy_return_tag) {
1984 
				untidy_return();
1985 
			} else
2 7u83 1986 
#endif
7 7u83 1987 
				make_jump(m_bra, ptno(crt_rscope));
1988 
			return;
1989 
		}
2 7u83 1990 
#ifdef rscope_tag
7 7u83 1991 
	case rscope_tag: {
1992 
		/* Procedure scopes */
1993 
		exp record;
1994 
		where old_rscope_dest;
1995 
		exp old_rscope = crt_rscope;
1996 
		old_rscope_dest = rscope_dest;
2 7u83 1997 
 
7 7u83 1998 
		/* Check for inlined procedures */
1999 
		if (last(e) &&
2000 
		    (name(bro(e)) == proc_tag ||
2001 
		     name(bro(e)) == general_proc_tag)) {
2002 
			/* Non-inlined procedures are simple */
2003 
			crt_rscope = 0;
2004 
			coder(zero, stack, son(e));
2005 
		} else {
2006 
			/* This is an inlined procedure */
2007 
			long lb = next_lab();
2008 
			record = simple_exp(0);
2009 
			ptno(record) = lb;
2010 
			crt_rscope = record;
2011 
			rscope_dest = dest;
2012 
			coder(zero, stack, son(e));
2013 
			make_label(lb);
2014 
			retcell(record);
2015 
		}
2 7u83 2016 
 
7 7u83 2017 
		/* Restore the previous scopes */
2018 
		rscope_dest = old_rscope_dest;
2019 
		crt_rscope = old_rscope;
2020 
		return;
2 7u83 2021 
	}
2022 
#endif
7 7u83 2023 
	case solve_tag: {
2024 
		/* Solve statements */
2025 
		long lb = next_lab();
2026 
		exp jr = simple_exp(0);
2027 
		ptno(jr) = lb;
2028 
		solve(son(e), son(e), dest, jr, stack);
2029 
		make_label(lb);
2030 
		retcell(jr);
2031 
		return;
2 7u83 2032 
	}
7 7u83 2033 
	case case_tag: {
2034 
		/* Case statements */
2035 
		exp d1;
2036 
		where w1;
2037 
		bool old_D1_sp = D1_is_special;
2038 
		exp arg1 = son(e);
2039 
		exp t = arg1;
2 7u83 2040 
 
7 7u83 2041 
		/* Mark the end of the cases */
2042 
		while (!last(t)) {
2043 
			t = bro(t);
2044 
		}
2045 
		bro(t) = nilexp;
2 7u83 2046 
 
7 7u83 2047 
		d1 = sim_exp(sh(arg1), D1);
2048 
		w1 = zw(d1);
2049 
		D1_is_special = 1;
2050 
		regsinproc |= regmsk(REG_D1);
2051 
		coder(w1, stack, arg1);
2 7u83 2052 
 
7 7u83 2053 
		change_var_sh(slongsh, sh(arg1), w1, D1);
2054 
		D1_is_special = old_D1_sp;
2 7u83 2055 
 
7 7u83 2056 
		/* Output the case statement */
2057 
		(void)caser(arg1, L0);
2 7u83 2058 
 
7 7u83 2059 
		retcell(d1);
2060 
		return;
2 7u83 2061 
	}
7 7u83 2062 
	case movecont_tag: {
2063 
		/* This is done by a library call to memmove */
2064 
		exp from_exp = son(e);
2065 
		exp to_exp = bro(from_exp);
2066 
		exp num_bytes = bro(to_exp);
2 7u83 2067 
#if defined(SUN)
7 7u83 2068 
		mach_op *op = make_extern_ind("_bcopy",0);
2 7u83 2069 
#else
7 7u83 2070 
		mach_op *op = make_extern_ind("_memmove",0);
2 7u83 2071 
#endif
7 7u83 2072 
		make_comment("move_some ...");
2073 
		push(slongsh,L32,D0);
2074 
		push(slongsh,L32,D1);
2075 
		push(slongsh,L32,zw(num_bytes));
2 7u83 2076 
#if defined(SUN)
7 7u83 2077 
		push(slongsh,L32,zw(to_exp));
2078 
		push(slongsh,L32,zw(from_exp));
2 7u83 2079 
#else
7 7u83 2080 
		push(slongsh,L32,zw(from_exp));
2081 
		push(slongsh,L32,zw(to_exp));
2 7u83 2082 
#endif
7 7u83 2083 
		make_instr(m_call,op,null,0);
2084 
		dec_stack(-96);
2085 
		pop(slongsh,L32,D1);
2086 
		pop(slongsh,L32,D0);
2087 
		make_comment("move_some done");
2088 
		return;
2 7u83 2089 
	}
7 7u83 2090 
	case diagnose_tag:
2 7u83 2091 
#if have_diagnostics
7 7u83 2092 
		diag_start(dno(e), e);
2093 
		coder(dest, stack, son(e));
2094 
		diag_end(dno(e), e);
2 7u83 2095 
#else
7 7u83 2096 
		coder(dest, stack, son(e));
2 7u83 2097 
#endif
7 7u83 2098 
		return;
2099 
	case prof_tag:
2100 
		return;
2101 
	default:
2102 
		if (!is_a(name(e))) {
2103 
			error("Bad operation");
2104 
			return;
2105 
		}
2106 
		if (name(dest.wh_exp) != val_tag) {
2107 
			/* All other cases are passed to codec */
2108 
			codec(dest, stack, e);
2109 
			return;
2110 
		} else if (!optop(e)) {
2111 
			/*
2112 
			 * An operation with an error jump must always be
2113 
			 * performed, even if the result is discarded.
2114 
			 */
2115 
			codec(zero,stack,e);
2116 
			return;
2117 
		}
2 7u83 2118 
	}
2119 
}