## rtl-build-g.pkg -- derived from ~/src/sml/nj/smlnj-110.58/new/new/src/MLRISC/mltree/rtl-build.sml
#
# Build Treecode-based RTLs
# Compiled by:
# src/lib/compiler/back/low/lib/rtl.libstipulate
package lem = lowhalf_error_message; # lowhalf_error_message is from src/lib/compiler/back/low/control/lowhalf-error-message.pkg package tcp = treecode_pith; # treecode_pith is from src/lib/compiler/back/low/treecode/treecode-pith.pkgherein
# This generic is invoked (only) in:
#
# src/lib/compiler/back/low/tools/arch/adl-rtl.pkg #
generic package rtl_build_g (
# ===========
#
rtl: Treecode_Rtl
)
: (weak) Rtl_Build # Rtl_Build is from src/lib/compiler/back/low/treecode/rtl-build.api {
# package rtl = rtl;
package tcf = rtl::tcf;
stipulate
package mi = tcf::mi; # "mi" == "machine_int"
herein
Effect = rtl::Rtl;
Expression = tcf::Int_Expression;
Type = tcf::Int_Bitsize;
Flag_Expression = tcf::Flag_Expression; # flag expressions handle zero/parity/overflow/... flag stuff.
Region = tcf::Int_Expression;
Cond = tcf::Cond; #
Fcond = tcf::Fcond;
Div_Rounding_Mode = tcf::d::Div_Rounding_Mode; # Special rounding mode just for divide instructions.
fun error msg
=
lem::error("rtl_build_g", msg);
hash_counter = REF 0u23;
fun new_hash ()
=
*hash_counter
then
hash_counter := *hash_counter + 0u23499;
fun new_oper name
=
{ name,
hash => new_hash (),
attributes => REF 0u0
};
new_op_list = REF [] : Ref( List( tcp::Misc_Op ) );
fun get_new_ops () = *new_op_list;
fun clear_new_ops () = new_op_list := [];
fun new_op name
=
{ op = new_oper name;
new_op_list := op ! *new_op_list;
op = tcf::OPERATOR op;
\\ es = tcf::OP (32, op, es); # XXX
};
fun (:=) type (lhs, rhs)
=
tcf::ASSIGN (type, lhs, rhs);
fun @@@ (k, type) e # This fn was called $ in SML/NJ (i.e., MLRISC).
=
tcf::ATATAT (type, k, e);
fun mem (k, type) (address, mem)
=
tcf::ATATAT (type, k, address);
fun ??? type # This really was called ??? in SML/NJ (i.e., MLRISC).
=
tcf::QQQ;
fun arg (type, kind, name)
=
tcf::ARG (type, REF (tcf::REPX kind), name);
fun bit_slice type slice e
=
tcf::BITSLICE (type, slice, e);
fun operand type expression = expression;
fun immed type expression = expression;
fun label type expression = expression;
# integer
fun int_const type i = tcf::LITERAL (mi::from_int (type, i));
fun unt_const type u = tcf::LITERAL (mi::from_unt1 (type, u));
fun ternary_op op type (z, x, y) = op (z, type, x, y);
fun bin_op op type ( x, y) = op ( type, x, y);
fun unary_op op type ( x ) = op ( type, x );
fun sx (from, to) e = tcf::SIGN_EXTEND (to, from, e);
fun zx (from, to) e = tcf::ZERO_EXTEND (to, from, e);
(-_) = unary_op tcf::NEG;
+ = bin_op tcf::ADD;
- = bin_op tcf::SUB;
muls = bin_op tcf::MULS;
divs = ternary_op tcf::DIVS;
rems = ternary_op tcf::REMS;
mulu = bin_op tcf::MULU;
divu = bin_op tcf::DIVU;
remu = bin_op tcf::REMU;
negt = unary_op tcf::NEG_OR_TRAP;
addt = bin_op tcf::ADD_OR_TRAP;
subt = bin_op tcf::SUB_OR_TRAP;
mult = bin_op tcf::MULS_OR_TRAP;
divt = ternary_op tcf::DIVS_OR_TRAP;
bitwise_not = unary_op tcf::BITWISE_NOT;
bitwise_and = bin_op tcf::BITWISE_AND;
bitwise_or = bin_op tcf::BITWISE_OR;
bitwise_xor = bin_op tcf::BITWISE_XOR;
eqvb = bin_op tcf::BITWISE_EQV;
>>> = bin_op tcf::RIGHT_SHIFT;
>> = bin_op tcf::RIGHT_SHIFT_U;
<< = bin_op tcf::LEFT_SHIFT;
true = tcf::TRUE;
false = tcf::FALSE;
not' = tcf::NOT;
and' = tcf::AND;
or' = tcf::OR;
xor' = tcf::XOR; # Oddly, this is not exported by src/lib/compiler/back/low/treecode/rtl-build.api fun cmp cc type (x, y) = tcf::CMP (type, cc, x, y);
fun cond type (cond, x, y) = tcf::CONDITIONAL_LOAD (type, cond, x, y);
==== = cmp tcf::EQ;
<> = cmp tcf::NE;
>= = cmp tcf::GE;
> = cmp tcf::GT;
<= = cmp tcf::LE;
< = cmp tcf::LT;
geu = cmp tcf::GEU;
gtu = cmp tcf::GTU;
leu = cmp tcf::LEU;
ltu = cmp tcf::LTU;
setcc = cmp tcf::SETCC;
fun getcc type (e, cc)
=
tcf::CMP (type, cc, e, tcf::QQQ);
# floating point
fun i2f (type, x) = tcf::INT_TO_FLOAT (type, type, x);
fun f2i (type, x) = tcf::FLOAT_TO_INT (type, tcf::ROUND_TO_ZERO, type, x);
fun fbin_op op type (x, y) = f2i (type, op (type, i2f (type, x), i2f (type, y)));
fun funary_op op type (x) = f2i (type, op (type, i2f (type, x)));
fun fcmp fcc type (x, y) = tcf::FCMP (type, fcc, i2f (type, x), i2f (type, y));
fun getfcc type (e, cc) = tcf::FCMP (type, cc, i2f (type, e), i2f (type, tcf::QQQ));
fadd = fbin_op tcf::FADD;
fsub = fbin_op tcf::FSUB;
fmul = fbin_op tcf::FMUL;
fdiv = fbin_op tcf::FDIV;
fcopysign = fbin_op tcf::COPY_FLOAT_SIGN;
#
fneg = funary_op tcf::FNEG;
fabs = funary_op tcf::FABS;
fsqrt = funary_op tcf::FSQRT;
# See comments and table in
#
# src/lib/compiler/back/low/treecode/treecode-pith.api #
|?| = fcmp tcf::FUO;
|====| = fcmp tcf::FEQ;
|?=| = fcmp tcf::FEQU;
|<| = fcmp tcf::FLT;
|?<| = fcmp tcf::FLTU;
|<=| = fcmp tcf::FLE;
|?<=| = fcmp tcf::FLEU;
|>| = fcmp tcf::FGT;
|?>| = fcmp tcf::FGTU;
|>=| = fcmp tcf::FGE;
|?>=| = fcmp tcf::FGEU;
|<>| = fcmp tcf::FNE;
|<=>| = fcmp tcf::FGLE;
|?<>| = fcmp tcf::FNEU;
setfcc = fcmp tcf::SETFCC;
# Effects:
#
nop' = tcf::SEQ [];
fun jmp' type address
=
tcf::GOTO (address, []);
fun call' type address
=
tcf::CALL
{
funct => address,
targets => [],
defs => [],
uses => [],
region => tcf::rgn::memory,
pops => 0
};
ret' = tcf::RET [];
fun if' (tcf::TRUE, yes, no) => yes;
if' (tcf::FALSE, yes, no) => no;
#
if' (tcf::CMP (type, cc, x, y), tcf::SEQ [], no)
=>
tcf::IF (tcf::CMP (type, tcp::negate_cond cc, x, y), no, nop');
#
if' (a, b, c)
=>
tcf::IF (a, b, c);
end;
fun par' (tcf::SEQ [], y) => y;
par' (x, tcf::SEQ []) => x;
par' (tcf::SEQ xs, tcf::SEQ ys) => tcf::SEQ (xs @ ys);
#
par' (tcf::SEQ xs, y) => tcf::SEQ (xs @ [y]);
par' (x, tcf::SEQ ys) => tcf::SEQ (x ! ys);
par' (x, y) => tcf::SEQ [x, y];
end;
map = \\ _ = list::map;
end; # stipulate
}; # generic package rtl_build_g
end; # stipulate