Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed
/*
Crown Copyright (c) 1996
This TenDRA(r) Computer Program is subject to Copyright
owned by the United Kingdom Secretary of State for Defence
acting through the Defence Evaluation and Research Agency
(DERA). It is made available to Recipients with a
royalty-free licence for its use, reproduction, transfer
to other parties and amendment for any purpose not excluding
product development provided that any such use et cetera
shall be deemed to be acceptance of the following conditions:-
(1) Its Recipients shall ensure that this Notice is
reproduced upon any copies or amended versions of it;
(2) Any amended version of it shall be clearly marked to
show both the nature of and the organisation responsible
for the relevant amendment or amendments;
(3) Its onward transfer from a recipient to another
party shall be deemed to be that party's acceptance of
these conditions;
(4) DERA gives no warranty or assurance as to its
quality or suitability for any purpose and DERA accepts
no liability whatsoever in relation to any use to which
it may be put.
*/
/*
VERSION INFORMATION
===================
--------------------------------------------------------------------------
$Header: /u/g/release/CVSROOT/Source/src/installers/680x0/common/codec.c,v 1.1.1.1 1998/01/17 15:55:49 release Exp $
--------------------------------------------------------------------------
$Log: codec.c,v $
* Revision 1.1.1.1 1998/01/17 15:55:49 release
* First version to be checked into rolling release.
*
Revision 1.3 1997/11/13 08:27:09 ma
All avs test passed (except add_to_ptr).
Revision 1.2 1997/11/09 14:06:53 ma
Rounding mode represented with names.
Revision 1.1.1.1 1997/10/13 12:42:47 ma
First version.
Revision 1.5 1997/10/13 08:48:58 ma
Made all pl_tests for general proc & exception handling pass.
Revision 1.4 1997/09/25 06:44:49 ma
All general_proc tests passed
Revision 1.3 1997/06/18 10:09:22 ma
Checking in before merging with Input Baseline changes.
Revision 1.2 1997/04/20 11:30:17 ma
Introduced gcproc.c & general_proc.[ch].
Added cases for apply_general_proc next to apply_proc in all files.
Revision 1.1.1.1 1997/03/14 07:50:10 ma
Imported from DRA
* Revision 1.1.1.1 1996/09/20 10:56:52 john
*
* Revision 1.3 1996/07/30 16:29:34 john
* Fixed bug, discarding side-effecting operations
*
* Revision 1.2 1996/07/05 14:16:20 john
* Changes for spec 3.1
*
* Revision 1.1.1.1 1996/03/26 15:45:08 john
*
* Revision 1.5 94/11/16 10:36:02 10:36:02 ra (Robert Andrews)
* Added integer absolute construct.
* -
*
* Revision 1.4 94/06/29 14:18:00 14:18:00 ra (Robert Andrews)
* Added div0, rem0, max and min for TDF 3.0.
*
* Revision 1.3 93/11/19 16:14:42 16:14:42 ra (Robert Andrews)
* Corrected order of arguments in offset_subtract.
*
* Revision 1.2 93/03/03 14:46:05 14:46:05 ra (Robert Andrews)
* Added error handling routines.
*
* Revision 1.1 93/02/22 17:15:17 17:15:17 ra (Robert Andrews)
* Initial revision
*
--------------------------------------------------------------------------
*/
#include "config.h"
#include "common_types.h"
#include "exp.h"
#include "expmacs.h"
#include "flags.h"
#include "shapemacs.h"
#include "install_fns.h"
#include "tags.h"
#include "mach.h"
#include "where.h"
#include "codec.h"
#include "coder.h"
#include "operations.h"
#include "utility.h"
#include "mach.h"
#include "instr.h"
#include "codex.h"
#include "instrs.h"
#include "f64.h"
#include "me_fns.h"
#include "evaluate.h"
#include "ops_shared.h"
#include "mach_ins.h"
extern bool have_cond ;
/*
CONSTRUCT A SIMILAR EXP
This routine, given a where, copies the corresponding exp, and sets
its sh equal to the given shape.
*/
exp sim_exp
PROTO_N ( ( sha, w ) )
PROTO_T ( shape sha X where w )
{
exp e = copyexp ( w.wh_exp ) ;
sh ( e ) = sha ;
return ( e ) ;
}
/*
PROCESS A UNARY OPERATION
This routine processes the unary operation described by the routine
op. The operand is given by a and the result, which is of shape
sha, is put into dest. The stack argument describes the current
state of the stack.
*/
static void uop
PROTO_N ( ( op, sha, a, dest, stack ) )
PROTO_T ( void ( *op ) PROTO_S ( ( shape, where, where ) ) X
shape sha X exp a X where dest X ash stack )
{
int old_rmode ;
if ( !is_o ( name ( a ) ) ) {
/* If a is not an operand, we need to calculate its value first */
if ( whereis ( dest ) == Dreg ) {
/* If dest is in a D register, code a into dest */
old_rmode = crt_rmode ;
coder ( dest, stack, a ) ;
crt_rmode = old_rmode ;
/* Now apply op to dest */
( *op ) ( sha, dest, dest ) ;
return ;
} else {
/* Code a into D1 */
where w ;
exp e = sim_exp ( sha, D1 ) ;
w = zw ( e ) ;
regsinproc |= regmsk ( REG_D1 ) ;
old_rmode = crt_rmode ;
coder ( w, stack, a ) ;
crt_rmode = old_rmode ;
/* Apply op to D1 */
( *op ) ( sha, w, dest ) ;
retcell ( e ) ;
if ( have_cond == 3 ) have_cond = 1 ;
return ;
}
}
/* If a is an operand, apply op directly to a */
( *op ) ( sha, zw ( a ), dest ) ;
return ;
}
/*
PROCESS A BINARY OPERATION
This routine processes the binary operation described by the routine
op. The operands are given by a and b and the result, which is of
shape sha, is put into dest. The stack argument describes the current
state of the stack.
*/
static void bop
PROTO_N ( ( op, sha, a, b, dest, stack ) )
PROTO_T ( void ( *op ) PROTO_S ( ( shape, where, where, where ) ) X
shape sha X exp a X exp b X where dest X ash stack )
{
where w, t ;
bool noa = !is_o ( name ( a ) ) ;
bool nob = !is_o ( name ( b ) ) ;
if ( noa ) {
/* If a is not an operand, we need to calculate its value first */
if ( nob ) {
/* a and b cannot both not be operands */
error ( "Illegal binary operation" ) ;
}
t = zw ( b ) ;
if ( whereis ( dest ) == Dreg && !interfere ( dest, t ) ) {
/* If dest is in a D register which is not used in b,
code a into dest */
coder ( dest, stack, a ) ;
/* Apply op to dest and b */
( *op ) ( sha, dest, t, dest ) ;
return ;
} else {
/* Code a into D1 */
exp e = sim_exp ( sha, D1 ) ;
w = zw ( e ) ;
regsinproc |= regmsk ( REG_D1 ) ;
coder ( w, stack, a ) ;
/* Apply op to D1 and b */
( *op ) ( sha, w, t, dest ) ;
retcell ( e ) ;
if ( have_cond == 3 ) have_cond = 1 ;
return ;
}
}
if ( nob ) {
/* If b is not an operand, we need to calculate its value first */
t = zw ( a ) ;
if ( whereis ( dest ) == Dreg && !interfere ( dest, t ) ) {
/* If dest is in a D register which is not used in a,
code b into dest */
coder ( dest, stack, b ) ;
/* Apply op to a and dest */
( *op ) ( sha, t, dest, dest ) ;
return ;
} else {
/* Code b into D1 */
exp e = sim_exp ( sha, D1 ) ;
w = zw ( e ) ;
regsinproc |= regmsk ( REG_D1 ) ;
coder ( w, stack, b ) ;
/* Apply op to a and D1 */
( *op ) ( sha, t, w, dest ) ;
retcell ( e ) ;
if ( have_cond == 3 ) have_cond = 1 ;
return ;
}
}
/* If a and b are both operands, apply op directly */
( *op ) ( sha, zw ( a ), zw ( b ), dest ) ;
return ;
}
/*
PROCESS A LOGICAL OPERATION
This routine processes the logical operation described by the routine
op. This operation will be binary, commutative and associative. The
operands are given by the bro-list starting at the son of e. The
result is put into dest. The stack argument describes the current
state of the stack.
*/
static void logop
PROTO_N ( ( op, e, dest, stack ) )
PROTO_T ( void ( *op ) PROTO_S ( ( shape, where, where, where ) ) X
exp e X where dest X ash stack )
{
exp arg1 = son ( e ) ; /* First argument */
exp arg2 = bro ( arg1 ) ; /* Second argument */
exp t, u, v ;
where w ;
if ( last ( arg1 ) ) {
/* If there is of one argument, code it into dest */
coder ( dest, stack, arg1 ) ;
return ;
}
if ( last ( arg2 ) ) {
/* If there are two arguments, use bop */
bop ( op, sh ( e ), arg1, arg2, dest, stack ) ;
return ;
}
/* Three or more arguments : need to take care about overlap between
dest and args, so use D1. */
regsinproc |= regmsk ( REG_D1 ) ;
v = sim_exp ( sh ( e ), D1 ) ;
w = zw ( v ) ;
t = arg1 ;
/* Scan the arguments. t will hold either the first non-operand,
or nilexp if all the arguments are operands. There should be
at most one non-operand. */
while ( 1 ) {
if ( !is_o ( name ( t ) ) ) break ;
if ( last ( t ) ) {
t = nilexp ;
break ;
}
t = bro ( t ) ;
}
/*
Deal with the case where all the arguments are operands. This
does :
D1 = op ( arg1, arg2 )
D1 = op ( arg3, D1 )
D1 = op ( arg4, D1 )
....................
dest = op ( argn, D1 )
*/
if ( t == nilexp ) {
/* Process the first two terms */
( *op ) ( sh ( e ), zw ( arg1 ), zw ( arg2 ), w ) ;
t = bro ( arg2 ) ;
while ( !last ( t ) ) {
/* Process the third, fourth, ... terms */
( *op ) ( sh ( e ), zw ( t ), w, w ) ;
t = bro ( t ) ;
}
/* Process the last term */
reuseables |= regmsk ( REG_D1 ) ;
( *op ) ( sh ( e ), zw ( t ), w, dest ) ;
reuseables &= ~regmsk ( REG_D1 ) ;
retcell ( v ) ;
if ( have_cond == 3 ) have_cond = 1 ;
return ;
}
/*
Deal with the case where one argument, say arg2, is a non-operand.
This does :
D1 = arg2
D1 = op ( arg1, D1 )
D1 = op ( arg3, D1 )
....................
dest = op ( argn, D1 )
*/
coder ( w, stack, t ) ;
u = arg1 ;
while ( 1 ) {
if ( t != u ) {
if ( last ( u ) || ( bro ( u ) == t && last ( bro ( u ) ) ) ) {
( *op ) ( sh ( e ), zw ( u ), w, dest ) ;
} else {
( *op ) ( sh ( e ), zw ( u ), w, w ) ;
}
}
if ( last ( u ) ) break ;
u = bro ( u ) ;
}
retcell ( v ) ;
if ( have_cond == 3 ) have_cond = 1 ;
return ;
}
/*
PROCESS ADD AND SUBTRACT
This routine processes the binary operation add. It does dest = b + a.
The second argument, a, may be of the form neg ( a1 ), in which case
we use sub.
*/
static void addsub
PROTO_N ( ( sha, a, b, dest, stack ) )
PROTO_T ( shape sha X where a X where b X where dest X ash stack )
{
exp e = a.wh_exp ;
if ( name ( e ) == neg_tag ) {
bop ( sub, sha, son ( e ), b.wh_exp, dest, stack ) ;
}
else {
bop ( add, sha, e, b.wh_exp, dest, stack ) ;
}
return ;
}
/*
Some constructs only set the overflow bit for 32 bit results.
This checks values of other varieties to determine whether or not an
overflow has occured
*/
void check_unset_overflow
PROTO_N ( (dest,shp) )
PROTO_T ( where dest X shape shp )
{
exp max_val = getexp(shp,nilexp,0,nilexp,nilexp,0,range_max(shp),
val_tag);
exp min_val = getexp(shp,nilexp,0,nilexp,nilexp,0,range_min(shp),
val_tag);
bool sw;
move(shp,dest,D0);
if(is_signed(shp) && (shape_size(shp) < 32)) {
ins1((shape_size(shp) == 16)?m_extl : m_extbl,32,D0,1);
}
sw = cmp(is_signed(shp)?slongsh:ulongsh,D0,zw(max_val),tst_gr);
test_overflow2(branch_ins(tst_gr,sw,is_signed(shp),is_floating(name(shp))));
sw = cmp(is_signed(shp)?slongsh:ulongsh,D0,zw(min_val),tst_ls);
test_overflow2(branch_ins(tst_ls,sw,is_signed(shp), is_floating(name(shp))));
kill_exp(max_val,max_val);
kill_exp(min_val,min_val);
return;
}
/*
MAIN OPERATION CODING ROUTINE
This routine creates code to evaluate e, putting the result into dest.
The stack argument describes the current stack position.
*/
void codec
PROTO_N ( ( dest, stack, e ) )
PROTO_T ( where dest X ash stack X exp e )
{
if ( e == nilexp ) {
error ( "Internal coding error" ) ;
return ;
}
switch ( name ( e ) ) {
case plus_tag : {
/*
Addition is treated similarly to logical operations -
see the routine logop above. It takes a variable number
of arguments in the form of a bro-list starting with
the son of e. Each argument may be of the form
neg ( x ).
*/
exp arg1 = son ( e ) ; /* First argument */
exp arg2 = bro ( arg1 ) ; /* Second argument */
exp s, t, u, v ;
where w ;
int prev_ov ;
if ( last ( arg1 ) ) {
/* One argument */
coder ( dest, stack, arg1 ) ;
return ;
}
prev_ov = set_overflow ( e ) ;
if ( last ( arg2 ) ) {
/* Two arguments */
addsub ( sh ( e ), zw ( arg2 ), zw ( arg1 ), dest, stack ) ;
clear_overflow ( prev_ov ) ;
return ;
}
/* Three or more arguments - use D1 */
t = arg1 ;
regsinproc |= regmsk ( REG_D1 ) ;
s = sim_exp ( sh ( e ), D1 ) ;
w = zw ( s ) ;
/* Look for the non-operand if there is one */
while ( 1 ) {
if ( !is_o ( name ( t ) ) &&
( name ( t ) != neg_tag ||
!is_o ( name ( son ( t ) ) ) ) ) break ;
if ( last( t ) ) {
t = nilexp ;
break ;
}
t = bro( t ) ;
}
if ( t == nilexp && name ( arg1 ) == neg_tag &&
name ( arg2 ) == neg_tag ) t = arg1 ;
/* Deal with the case where all the arguments are operands */
if ( t == nilexp ) {
t = bro ( arg2 ) ;
/* Deal with the first two arguments */
if ( name ( arg1 ) == neg_tag ) {
addsub ( sh ( e ), zw ( arg1 ), zw ( arg2 ),
( ( t == e ) ? dest : w ), stack ) ;
} else {
addsub ( sh ( e ), zw ( arg2 ), zw ( arg1 ),
( ( t == e ) ? dest : w ), stack ) ;
}
if ( t == e ) {
clear_overflow ( prev_ov ) ;
return ;
}
/* Deal with the third, fourth, ... arguments */
while ( !last ( t ) ) {
u = bro ( t ) ;
addsub ( sh ( e ), zw ( t ), w, w, stack ) ;
t = u ;
}
/* Deal with the last argument */
addsub ( sh ( e ), zw ( t ), w, dest, stack ) ;
retcell ( s ) ;
if ( have_cond == 3 ) have_cond = 1 ;
clear_overflow ( prev_ov ) ;
return ;
}
/* Deal with the case where one argument is a non-operand */
coder ( w, stack, t ) ;
u = arg1 ;
while ( 1 ) {
v = bro ( u ) ;
if ( t != u ) {
if ( last ( u ) || ( v == t && last ( v ) ) ) {
addsub ( sh ( e ), zw ( u ), w, dest, stack ) ;
} else {
addsub ( sh ( e ), zw ( u ), w, w, stack ) ;
}
}
if ( last ( u ) ) break ;
u = v ;
}
retcell ( s ) ;
if ( have_cond == 3 ) have_cond = 1 ;
clear_overflow ( prev_ov ) ;
return ;
}
#ifndef tdf3
case addptr_tag : {
exp pointer = son ( e ) ;
exp offset = son ( pointer ) ;
make_comment("addptr_tag ...") ;
mova ( zw ( e ), dest ) ;
make_comment("addptr_tag done") ;
return ;
}
#endif
case chvar_tag : {
/* Change variety, the son of e, a, gives the argument */
exp a = son ( e ) ;
int prev_ov = set_overflow(e);
if ( !is_o ( name ( a ) ) ) {
/* If a is not an operand */
if ( whereis ( dest ) != Dreg ) {
/* If dest is not a D register, code a into D1 */
where w ;
exp s = sim_exp ( sh ( a ), D1 ) ;
w = zw ( s ) ;
regsinproc |= regmsk ( REG_D1 ) ;
coder ( w, stack, a ) ;
/* Preform the change variety on D1 */
change_var ( sh ( e ), w, dest ) ;
retcell ( s ) ;
if ( have_cond == 3 ) have_cond = 1 ;
clear_overflow ( prev_ov ) ;
return ;
}
/* If dest is a D register, code a into dest */
coder ( dest, stack, a ) ;
/* Preform the change variety on dest */
change_var_sh ( sh ( e ), sh ( a ), dest, dest ) ;
clear_overflow ( prev_ov ) ;
return ;
}
/* If a is an operand, call change_var directly */
change_var ( sh ( e ), zw ( a ), dest ) ;
clear_overflow ( prev_ov ) ;
return ;
}
case minus_tag : {
/* Minus, subtract pointer etc are binary operations */
int prev_ov = set_overflow ( e ) ;
bop ( sub, sh ( e ), bro ( son ( e ) ), son ( e ),
dest, stack ) ;
clear_overflow ( prev_ov ) ;
return ;
}
#ifndef tdf3
case make_stack_limit_tag :
#endif
case subptr_tag :
case minptr_tag : {
/* Minus, subtract pointer etc are binary operations */
bop ( sub, sh ( e ), bro ( son ( e ) ), son ( e ),
dest, stack ) ;
return ;
}
case mult_tag : {
/* Multiply is treated as a logical operation */
int prev_ov = set_overflow ( e ) ;
logop ( mult, e, dest, stack ) ;
if (!optop(e)&&(name(sh(e))!=slonghd)&&(name(sh(e))!=ulonghd)) {
check_unset_overflow(dest,sh(e));
}
clear_overflow ( prev_ov ) ;
return ;
}
case div0_tag :
case div2_tag : {
/* Division is a binary operation */
int prev_ov = set_overflow(e);
bop ( div2, sh ( e ), bro ( son ( e ) ), son ( e ),
dest, stack ) ;
if (!optop(e)&&(name(sh(e))!=slonghd)&&(name(sh(e))!=ulonghd)) {
check_unset_overflow(dest,sh(e));
}
clear_overflow( prev_ov );
return ;
}
case div1_tag : {
/* Division is a binary operation */
int prev_ov = set_overflow(e);
bop ( div1, sh ( e ), bro ( son ( e ) ), son ( e ),
dest, stack ) ;
if (!optop(e)&&(name(sh(e))!=slonghd)&&(name(sh(e))!=ulonghd)) {
check_unset_overflow(dest,sh(e));
}
clear_overflow( prev_ov );
return ;
}
case neg_tag : {
/* Negation is a unary operation */
int prev_ov = set_overflow ( e ) ;
uop ( negate, sh ( e ), son ( e ), dest, stack ) ;
clear_overflow ( prev_ov ) ;
return ;
}
case abs_tag : {
/* Abs is a unary operation */
int prev_ov = set_overflow(e);
uop ( absop, sh ( e ), son ( e ), dest, stack ) ;
clear_overflow( prev_ov ) ;
return ;
}
case shl_tag : {
/* Shifting left is a binary operation */
int prev_ov = set_overflow ( e ) ;
bop ( shift, sh ( e ), bro ( son ( e ) ), son ( e ),
dest, stack ) ;
clear_overflow ( prev_ov ) ;
return ;
}
case shr_tag : {
/* Shifting right is a binary operation */
bop ( rshift, sh ( e ), bro ( son ( e ) ), son ( e ),
dest, stack ) ;
return ;
}
case mod_tag : {
/* Remainder is a binary operation */
int prev_ov = set_overflow ( e ) ;
bop ( rem1, sh ( e ), bro ( son ( e ) ), son ( e ),
dest, stack ) ;
clear_overflow ( prev_ov ) ;
return ;
}
case rem0_tag :
case rem2_tag : {
/* Remainder is a binary operation */
int prev_ov = set_overflow ( e ) ;
bop ( rem2, sh ( e ), bro ( son ( e ) ), son ( e ),
dest, stack ) ;
clear_overflow ( prev_ov ) ;
return ;
}
case round_tag : {
/* Rounding a floating point number is a unary operation */
int prev_ov = set_overflow ( e ) ;
set_continue(e);
crt_rmode = round_number ( e ) ;
uop ( round_float, sh ( e ), son ( e ), dest, stack ) ;
clear_overflow ( prev_ov ) ;
clear_continue(e);
return ;
}
case fmult_tag : {
/* Floating multiplication is a floating binary operation */
exp f1 = son ( e ) ;
exp f2 = bro ( f1 ) ;
int prev_ov = set_overflow ( e ) ;
if(last(f2)) {
/* two arguments */
fl_binop ( fmult_tag, sh ( e ), zw ( f1 ), zw ( f2 ), dest ) ;
}
else {
/* more than two arguments; use %fp1. Assumes that all
parameters are operands */
where w;
exp s = sim_exp(sh(e), FP1);
regsinproc |= regmsk(REG_FP1);
w = zw(s);
fl_binop(fmult_tag,sh(e),zw(f1),zw(f2),w);
while(!last(f2)) {
f2 = bro(f2);
fl_binop(fmult_tag,sh(e),w,zw(f2),(last(f2)?dest:w));
}
}
clear_overflow ( prev_ov ) ;
return ;
}
case fminus_tag : {
/* Floating subtraction is a floating binary operation */
exp f1 = son ( e ) ;
exp f2 = bro ( f1 ) ;
int prev_ov = set_overflow ( e ) ;
fl_binop ( fminus_tag, sh ( e ), zw ( f2 ), zw ( f1 ), dest ) ;
clear_overflow ( prev_ov ) ;
return ;
}
case fdiv_tag : {
/* Floating division is a floating binary operation */
exp f1 = son ( e ) ;
exp f2 = bro ( f1 ) ;
int prev_ov = set_overflow ( e ) ;
fl_binop ( fdiv_tag, sh ( e ), zw ( f2 ), zw ( f1 ), dest ) ;
clear_overflow ( prev_ov ) ;
return ;
}
case fneg_tag : {
/* Floating negation is simple */
int prev_ov = set_overflow ( e ) ;
negate_float ( sh ( e ), zw ( son ( e ) ), dest ) ;
clear_overflow ( prev_ov ) ;
return ;
}
case fabs_tag : {
/* Floating absolute value is simple */
int prev_ov = set_overflow ( e ) ;
abs_float ( sh ( e ), zw ( son ( e ) ), dest ) ;
clear_overflow ( prev_ov ) ;
return ;
}
case float_tag : {
/* Casting to a floating point number is simple */
int prev_ov = set_overflow ( e ) ;
int_to_float ( sh ( e ), zw ( son ( e ) ), dest ) ;
clear_overflow ( prev_ov ) ;
return ;
}
case chfl_tag : {
/* Changing a floating variety is simple */
int prev_ov = set_overflow ( e ) ;
change_flvar ( sh ( e ), zw ( son ( e ) ), dest ) ;
clear_overflow ( prev_ov ) ;
return ;
}
case and_tag : {
/* And is a logical operation */
logop ( and, e, dest, stack ) ;
return ;
}
case or_tag : {
/* Or is a logical operation */
logop ( or, e, dest, stack ) ;
return ;
}
case xor_tag : {
/* Xor is a logical operation */
logop ( xor, e, dest, stack ) ;
return ;
}
case not_tag : {
/* Not is a unary operation */
uop ( not, sh ( e ), son ( e ), dest, stack ) ;
return ;
}
case absbool_tag : {
/* The setcc instruction is not used */
error ( "Not implemented" ) ;
return ;
}
case fplus_tag : {
/* Floating addition is similar to integer addition */
exp f1 = son ( e ) ; /* First argument */
exp f2 = bro ( f1 ) ; /* Second argument */
exp t ;
long count_dest = 2 ;
exp de = dest.wh_exp ;
int prev_ov = set_overflow ( e ) ;
if ( last ( f1 ) ) {
/* If there is only one argument things are simple */
move ( sh ( e ), zw ( f1 ), dest ) ;
clear_overflow ( prev_ov ) ;
return ;
}
if ( last ( f2 ) ) {
/* If there are two arguments code directly */
if ( name ( f2 ) == fneg_tag ) {
f2 = son ( f2 ) ;
fl_binop ( fminus_tag, sh ( e ), zw ( f2 ),
zw ( f1 ), dest ) ;
} else {
fl_binop ( fplus_tag, sh ( e ), zw ( f1 ),
zw ( f2 ), dest ) ;
}
clear_overflow ( prev_ov ) ;
return ;
}
if ( last ( bro ( f2 ) ) &&
name ( bro ( f2 ) ) == real_tag &&
name ( dest.wh_exp ) != apply_tag
&& name ( dest.wh_exp ) != tail_call_tag
&& name ( dest.wh_exp ) != apply_general_tag ) {
/* If there are 3 arguments, the last of which is constant */
if ( name ( f2 ) == fneg_tag ) {
f2 = son ( f2 ) ;
fl_binop ( fminus_tag, sh ( e ), zw ( f2 ),
zw ( f1 ), dest ) ;
fl_binop ( fplus_tag, sh ( e ), zw ( bro ( f2 ) ),
dest, dest ) ;
} else {
fl_binop ( fplus_tag, sh ( e ), zw ( f1 ),
zw ( f2 ), dest ) ;
fl_binop ( fplus_tag, sh ( e ), zw ( bro ( f2 ) ),
dest, dest ) ;
}
clear_overflow ( prev_ov ) ;
return ;
}
if ( name ( de ) == ass_tag &&
name ( son ( de ) ) == name_tag &&
( ( props ( son ( son ( de ) ) ) & 0x9 ) == 0x9 ) ) {
count_dest = 0 ;
t = f1 ;
if ( eq_where ( dest, zw ( t ) ) ) count_dest++ ;
while ( !last ( t ) ) {
t = bro ( t ) ;
if ( name ( t ) == fneg_tag ) {
if ( eq_where ( zw ( son ( t ) ), dest ) )
count_dest = 2 ;
} else {
if ( eq_where ( zw ( t ), dest ) ) count_dest++ ;
}
}
}
if ( count_dest < 2 && (name ( dest.wh_exp ) != apply_tag
&& name ( dest.wh_exp ) != tail_call_tag
&& name ( dest.wh_exp ) != apply_general_tag) ) {
if ( count_dest == 1 ) {
t = f1 ;
} else {
if ( name ( f2 ) == fneg_tag ) {
exp m = son ( f2 ) ;
fl_binop ( fminus_tag, sh ( e ), zw ( m ),
zw ( f1 ), dest ) ;
} else {
fl_binop ( fplus_tag, sh ( e ), zw ( f1 ),
zw ( f2 ), dest ) ;
}
t = bro ( f2 ) ;
}
for ( ; ; ) {
where tw ;
if ( name ( t ) == fneg_tag ) {
tw = zw ( son ( t ) ) ;
if ( !eq_where ( dest, tw ) ) {
fl_binop ( fminus_tag, sh ( e ), tw, dest, dest ) ;
}
} else {
tw = zw ( t ) ;
if ( !eq_where ( dest, tw ) ) {
fl_binop ( fplus_tag, sh ( e ), tw, dest, dest ) ;
}
}
if ( last ( t ) ) break ;
t = bro ( t ) ;
}
} else {
if ( name ( f2 ) == fneg_tag ) {
fl_binop ( fminus_tag, sh ( e ), zw ( son ( f2 ) ),
zw ( f1 ), FP0 ) ;
} else {
fl_binop ( fplus_tag, sh ( e ), zw ( f1 ),
zw ( f2 ), FP0 ) ;
}
t = bro ( f2 ) ;
while ( !last ( t ) ) {
if ( name ( t ) == fneg_tag ) {
fl_binop ( fminus_tag, sh ( e ), zw ( son ( t ) ),
FP0, FP0 ) ;
} else {
fl_binop ( fplus_tag, sh ( e ), zw ( t ), FP0, FP0 ) ;
}
t = bro ( t ) ;
}
if ( name ( t ) == fneg_tag ) {
fl_binop ( fminus_tag, sh ( e ), zw ( son ( t ) ),
FP0, dest ) ;
} else {
fl_binop ( fplus_tag, sh ( e ), zw ( t ), FP0, dest ) ;
}
}
clear_overflow ( prev_ov ) ;
return ;
}
/*
Note : in the following offset operations I have put the
shape as slongsh rather than sh ( e ). This is because
the system stddef.h wrongly says that ptrdiff_t is unsigned
and I don't trust people to put it right when making up
TDF libraries. If this was right sh ( e ) would be slongsh.
*/
case offset_add_tag : {
make_comment("offset_add_tag...");
/* Offset addition is a binary operation */
bop ( add, slongsh, son ( e ), bro ( son ( e ) ), dest, stack ) ;
make_comment("offset_add_tag done");
return ;
}
case offset_subtract_tag : {
/* Offset subtraction is a binary operation */
bop ( sub, slongsh, bro ( son ( e ) ), son ( e ), dest, stack ) ;
return ;
}
case offset_mult_tag : {
make_comment("offset_mult_tag...");
/* Offset multiplication is a binary operation */
bop ( mult, slongsh, son ( e ), bro ( son ( e ) ), dest, stack ) ;
make_comment("offset_mult_tag done");
return ;
}
case offset_negate_tag : {
/* Offset negation is a unary operation */
uop ( negate, slongsh, son ( e ), dest, stack ) ;
return ;
}
case offset_div_tag :
case offset_div_by_int_tag : {
/* Offset division is a binary operation */
if(name(sh(bro(son(e)))) < slonghd){
exp changer = me_u3(slongsh,bro(son(e)),chvar_tag);
bro(son(e)) = changer;
}
bop ( div2, slongsh, bro ( son ( e ) ), son ( e ), dest, stack ) ;
return ;
}
case offset_pad_tag : {
/* Pad an operand */
exp cur_offset = son ( e ) ;
long cur_align = al2 ( sh ( cur_offset ) ) ;
long next_align = al2 ( sh ( e ) ) ;
make_comment("offset_pad ...") ;
/* does current alignment include next alignment? */
if ( cur_align >= next_align ) {
if( ( next_align !=1 ) || ( cur_align ==1 ) ) {
coder ( dest, stack, cur_offset ) ;
}
else {
/* left shift */
shift( sh(e), mnw(3), zw(cur_offset),dest);
}
} else {
/* cur_align < next_align */
where r ;
if ( whereis ( dest ) == Dreg ) {
r = dest ;
} else {
r = D1 ;
regsinproc |= regmsk ( REG_D1 ) ;
}
codec ( r, stack, cur_offset ) ;
if( cur_align == 1){
add ( slongsh, mnw ( next_align - 1 ), r, r ) ;
and ( slongsh, mnw ( -next_align ), r, dest ) ;
rshift(sh(e),mnw(3),dest,dest);
}
else {
long al = next_align / 8 ;
add ( slongsh, mnw ( al - 1 ), r, r ) ;
and ( slongsh, mnw ( -al ), r, dest ) ;
}
}
make_comment("offset_pad done") ;
return ;
}
case bitf_to_int_tag : {
if ( whereis ( dest ) == Dreg ) {
coder ( dest, stack, son ( e ) ) ;
change_var_sh ( sh ( e ), sh ( son ( e ) ), dest, dest ) ;
} else {
regsinproc |= regmsk ( REG_D1 ) ;
coder ( D1, stack, son ( e ) ) ;
change_var_sh ( sh ( e ), sh ( son ( e ) ), D1, dest ) ;
}
return ;
}
case int_to_bitf_tag : {
where r ;
long nbits = shape_size ( sh ( e ) ) ;
long mask = lo_bits [ nbits ] ;
r = ( whereis ( dest ) == Dreg ? dest : D0 ) ;
move ( slongsh, zw ( son ( e ) ), r ) ;
and ( slongsh, mnw ( mask ), r, dest ) ;
return ;
}
case offset_max_tag :
case max_tag : {
/* Maximum */
bop ( maxop, sh ( e ), son ( e ), bro ( son ( e ) ), dest, stack ) ;
return ;
}
case min_tag : {
/* Minimum */
bop ( minop, sh ( e ), son ( e ), bro ( son ( e ) ), dest, stack ) ;
return ;
}
case cont_tag : {
make_comment("cont_tag ...") ;
if ( name ( sh ( e ) ) == bitfhd ) {
bitf_to_int ( e, sh ( e ), dest, stack ) ;
return ;
}
move ( sh ( e ), zw ( e ), dest ) ;
make_comment("cont_tag done") ;
return ;
}
default : {
if ( !is_o ( name ( e ) ) ) {
/* If e is not an operand, code e into a register */
exp s ;
where w ;
if ( name ( e ) == apply_tag
|| name ( e ) == apply_general_tag
|| name ( e ) == tail_call_tag ) {
s = sim_exp ( sh ( e ), D0 ) ;
} else {
if ( whereis ( dest ) == Dreg ) {
/* error ( "Untested optimization" ) ;*/
s = sim_exp ( sh ( e ), dest ) ;
} else {
regsinproc |= regmsk ( REG_D1 ) ;
s = sim_exp ( sh ( e ), D1 ) ;
}
}
w = zw ( s ) ;
coder ( w, stack, e ) ;
/* Move the value of this register into dest */
move ( sh ( e ), w, dest ) ;
retcell ( s ) ;
if ( have_cond == 3 ) have_cond = 1 ;
return ;
}
if ( name ( e ) == reff_tag && shape_size ( sh ( e ) ) != 32 ) {
/* Deal with pointers to bitfields */
exp s ;
where d ;
/* s = sim_exp ( sh ( e ), D0 ) ; */
d = mw ( dest.wh_exp, dest.wh_off + 32 ) ;
if ( shape_size ( sh ( son ( e ) ) ) == 32 ) {
make_comment("Pointer to bitfield (32) ...") ;
coder ( dest, stack, son ( e ) ) ;
move ( slongsh, mnw ( no ( e ) ), d ) ;
make_comment("Pointer to bitfield (32) done") ;
return ;
}
make_comment("Pointer to bitfield ...") ;
coder ( dest, stack, son ( e ) ) ;
add ( slongsh, mnw ( no ( e ) ), d, d ) ;
make_comment("Pointer to bitfield done") ;
return ;
}
if ( name ( e ) == reff_tag &&
( name ( son ( e ) ) == name_tag ||
( name ( son ( e ) ) == cont_tag &&
name ( son ( son ( e ) ) ) == name_tag ) ) ) {
/* Deal with pointers with offsets */
long off = no ( e ) / 8 ;
make_comment("reff_tag ...");
add ( slongsh, zw ( son ( e ) ), mnw ( off ), dest ) ;
make_comment("reff_tag done");
return ;
}
if ( ( name ( e ) == name_tag && isvar ( son ( e ) ) ) ||
name ( e ) == reff_tag){
/* Deal with pointers */
mova ( zw ( e ), dest ) ;
return ;
}
if ( name ( e ) == clear_tag ) {
/* Deal with clear shapes */
char sn = name ( sh ( e ) ) ;
if ( sn >= shrealhd && sn <= doublehd ) {
move ( sh ( e ), fzero, dest ) ;
}
#ifndef tdf3
if(name (dest.wh_exp) == apply_tag ||
name (dest.wh_exp) == apply_general_tag ||
name (dest.wh_exp) == tail_call_tag ) {
move ( sh ( e ), zero, dest ) ;
}
#endif
return ;
}
if (name(e) == val_tag && ((name(sh(e)) == s64hd) ||
name(sh(e)) == u64hd)){
flt64 bval;
where w;
bval = exp_to_f64(e);
if ( eq_where ( dest, D0_D1 ) ) {
move_const(slongsh,32,bval.big, D1);
move_const(slongsh,32,bval.small, D0);
}
else {
w = dest;
move_const(sh(e),32,bval.small,w);
w.wh_off += 32;
move_const(sh(e),32,bval.big,w);
}
return;
}
/* If all else fails, use move */
if ( name ( e ) == top_tag ) return ;
move ( sh ( e ), zw ( e ), dest ) ;
return ;
}
}
}