## anormcode-runtime-type.pkg # "rttype.sml" in SML/NJ
#
# Support code used only in
#
# src/lib/compiler/back/top/forms/drop-types-from-anormcode-junk.pkg# Compiled by:
# src/lib/compiler/core.sublib# Runtime type support for the A-Normal Form
# compiler passes -- for context see the
# comments in
#
# src/lib/compiler/back/top/anormcode/anormcode-form.api### "Computers are useless.
### They can only give you answers."
###
### -- Pablo Picasso
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkgherein
api Anormcode_Runtime_Type {
#
Tcode;
#
tcode_truevoid: Tcode;
tcode_record: Tcode;
tcode_int1: Tcode;
tcode_pair: Tcode;
tcode_fpair: Tcode;
tcode_float64: Tcode;
tcode_real_n: Int -> Tcode;
#
tovalue: Tcode -> acf::Value;
};
end;
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkg package di = debruijn_index; # debruijn_index is from src/lib/compiler/front/typer/basics/debruijn-index.pkg package hbo = highcode_baseops; # highcode_baseops is from src/lib/compiler/back/top/highcode/highcode-baseops.pkg package hbt = highcode_basetypes; # highcode_basetypes is from src/lib/compiler/back/top/highcode/highcode-basetypes.pkg package hcf = highcode_form; # highcode_form is from src/lib/compiler/back/top/highcode/highcode-form.pkg package hct = highcode_type; # highcode_type is from src/lib/compiler/back/top/highcode/highcode-type.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkg package hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkgherein
package anormcode_runtime_type /* :> Anormcode_Runtime_Type */ { # XXX BUGGO FIXME why isn't this API used at present?
#
Tcode = Int;
fun bug s
=
error_message::impossible ("runtime_type: " + s);
fun say (string: String)
=
global_controls::print::say string;
fun make_var _
=
tmp::issue_highcode_codetemp();
ident = \\ le => le; end ;
fkfun = { loop_info=>NULL, private=>FALSE, inlining_hint=>acf::INLINE_WHENEVER_POSSIBLE, call_as => acf::CALL_AS_FUNCTION hcf::fixed_calling_convention };
fkfct = { loop_info=>NULL, private=>FALSE, inlining_hint=>acf::INLINE_IF_SIZE_SAFE, call_as => acf::CALL_AS_GENERIC_PACKAGE };
# fun mkarw (ts1, ts2)
# =
# hcf::make_arrow_uniqtype (hcf::fixed_calling_convention, ts1, ts2);
lt_arw = hcf::make_type_uniqtypoid o hcf::make_arrow_uniqtype;
stipulate
fun wrap_type tc = (NULL, hbo::WRAP, lt_arw (hcf::fixed_calling_convention, [tc], [hcf::truevoid_uniqtype]), []);
fun unwrap_type tc = (NULL, hbo::UNWRAP, lt_arw (hcf::fixed_calling_convention, [hcf::truevoid_uniqtype], [tc]), []);
herein
fun fu_wrap (tc, vs, v, e) = acf::BASEOP ( wrap_type tc, vs, v, e);
fun fu_unwrap (tc, vs, v, e) = acf::BASEOP (unwrap_type tc, vs, v, e);
end;
fu_rk_tuple
=
anormcode_junk::rk_tuple;
fun wrap_x (t, u)
=
{ v = make_var();
fu_wrap (t, [u], v, acf::RET [acf::VAR v]);
};
fun unwrap_x (t, u)
=
{ v = make_var();
fu_unwrap (t, [u], v, acf::RET [acf::VAR v]);
};
###############################################################################
# UTILITY FUNCTIONS AND CONSTANTS
###############################################################################
fun split (acf::RET [v])
=>
(v, ident);
split x
=>
{ v = make_var();
(acf::VAR v, \\ z = acf::LET([v], x, z));
};
end;
fun select_g (i, e)
=
{ my (v, header) = split e;
x = make_var();
header (acf::GET_FIELD (v, i, x, acf::RET [acf::VAR x]));
};
fun fn_g (vts, e)
=
{ f = make_var();
acf::MUTUALLY_RECURSIVE_FNS([(fkfun, f, vts, e)], acf::RET [acf::VAR f]);
};
fun select_v (i, u)
=
{ x = make_var();
acf::GET_FIELD (u, i, x, acf::RET [acf::VAR x]);
};
fun app_g (e1, e2)
=
{ my (v1, h1) = split e1;
my (v2, h2) = split e2;
h1 (h2 (acf::APPLY (v1, [v2])));
};
fun record_g es
=
f (es, [], ident)
where
fun f ([], vs, header)
=>
{ x = make_var();
header (acf::RECORD (fu_rk_tuple, reverse vs, x, acf::RET [acf::VAR x]));
};
f (e ! r, vs, header)
=>
{ my (v, h) = split e;
f (r, v ! vs, header o h);
};
end;
end;
fun srecord_g es
=
f (es, [], ident)
where
fun f ([], vs, header)
=>
{ x = make_var();
header (acf::RECORD (acf::RK_PACKAGE, reverse vs, x, acf::RET [acf::VAR x]));
};
f (e ! r, vs, header)
=>
{ (split e) -> (v, h);
#
f (r, v ! vs, header o h);
};
end;
end;
fun wrap_g (z, b, e)
=
{ (split e) -> (v, h);
#
h (wrap_x (z, v));
};
fun unwrap_g (z, b, e)
=
{ (split e) -> (v, h);
#
h (unwrap_x (z, v));
};
fun wrap_cast (z, b, e)
=
{ (split e) -> (v, h);
#
pt = hcf::make_arrow_uniqtypoid (hcf::fixed_calling_convention, [hcf::make_type_uniqtypoid z], [hcf::truevoid_uniqtypoid]);
pv = (NULL, hbo::CAST, pt,[]);
#
x = make_var ();
#
h (acf::BASEOP (pv, [v], x, acf::RET [acf::VAR x]));
};
fun unwrap_cast (z, b, e)
=
{ my (v, h) = split e;
pt = hcf::make_arrow_uniqtypoid (hcf::fixed_calling_convention, [hcf::truevoid_uniqtypoid], [hcf::make_type_uniqtypoid z]);
pv = (NULL, hbo::CAST, pt,[]);
x = make_var();
h (acf::BASEOP (pv, [v], x, acf::RET [acf::VAR x]));
};
fun switch_g (e, s, ce, d)
=
{ (split e) -> (v, h);
#
h (acf::SWITCH (v, s, ce, d));
};
fun cond (u, e1, e2)
=
u (e1, e2);
fun wrap_x (t, u)
=
{ v = make_var();
fu_wrap (t, [u], v, acf::RET [acf::VAR v]);
};
fun unwrap_x (t, u)
=
{ v = make_var();
fu_unwrap (t, [u], v, acf::RET [acf::VAR v]);
};
intty = hcf::int_uniqtypoid;
boolty = /* hcf::bool_uniqtypoid */ hcf::truevoid_uniqtypoid;
inteqty = hcf::make_arrow_uniqtypoid (hcf::fixed_calling_convention, [intty, intty], [boolty]);
intopty = hcf::make_arrow_uniqtypoid (hcf::fixed_calling_convention, [intty, intty], [intty]);
ieqprim = (NULL, hbo::ieql, inteqty, []);
iaddprim = (NULL, hbo::iadd, intopty, []);
fun ieq_lexp (e1, e2)
=
{ (split e1) -> (v1, h1);
(split e2) -> (v2, h2);
\\ (te, fe) => h1 (h2 (acf::BRANCH (ieqprim, [v1, v2], te, fe))); end ;
};
fun iadd_lexp (e1, e2)
=
{ (split e1) -> (v1, h1);
(split e2) -> (v2, h2);
x = make_var ();
h1 (h2 (acf::BASEOP (iaddprim, [v1, v2], x, acf::RET [acf::VAR x])));
};
tcode_truevoid = 0;
tcode_record = 1;
tcode_int1 = 2;
tcode_pair = 3;
tcode_fpair = 4;
tcode_float64 = 5;
fun tcode_real_n n
=
n * 5;
fun tovalue i
=
acf::INT i;
tolexp = \\ tcode = acf::RET [tovalue tcode];
my tcode_truevoid: acf::Expression = tolexp tcode_truevoid;
my tcode_record: acf::Expression = tolexp tcode_record;
my tcode_int1: acf::Expression = tolexp tcode_int1;
my tcode_pair: acf::Expression = tolexp tcode_pair;
my tcode_fpair: acf::Expression = tolexp tcode_fpair;
my tcode_float64: acf::Expression = tolexp tcode_float64;
my tcode_real_n: Int -> acf::Expression
=
\\ i = tolexp (tcode_real_n i);
Outcome
= YES
| NO
| MAYBE acf::Expression
;
##############################################################################
# KIND DICTIONARIES
##############################################################################
Kenv = List( ( List( tmp::Codetemp ),
List( hut::Uniqkind )
) );
init_ke = [];
fun add_ke (kenv, vs, ks)
=
(vs, ks) ! kenv;
fun vlook_ke (kenv, i, j)
=
{ my (vs, _)
=
list::nth (kenv, i - 1)
except
_ = bug "unexpected case1 in vlook_ke";
list::nth (vs, j)
except
_ = bug "unexpected case2 in vlook_ke";
};
fun klook_ke (kenv, i, j)
=
{ my (_, ks)
=
list::nth (kenv, i - 1)
except
_ = bug "unexpected case1 in klook_ke";
list::nth (ks, j)
except
_ = bug "unexpected case2 in klook_ke";
};
# my tk_abs_gen: kenv * List( Variable ) * List( Highcode_Kind ) * Variable * fkind
# -> kenv * ((acf::Expression * acf::Expression) -> acf::Expression)
#
fun tk_abs_fn (kenv, vs, ks, f, fk)
=
{ make_arg_type = case fk { call_as => acf::CALL_AS_FUNCTION _, ... } => hcf::make_tuple_uniqtypoid;
{ call_as => acf::CALL_AS_GENERIC_PACKAGE, ... } => hcf::make_package_uniqtypoid;
esac;
argt = make_arg_type (map hcf::uniqkind_to_uniqtypoid ks);
w = make_var();
fun h([], i, base) => base;
h (v ! r, i, base) => h (r, i+1, acf::GET_FIELD (acf::VAR w, i, v, base));
end;
fun header (e1, e2)
=
acf::MUTUALLY_RECURSIVE_FNS([(fk, f, [(w, argt)], h (vs, 0, e1))], e2);
(add_ke (kenv, vs, ks), header);
};
# my tk_abs: (Kenv, List(( tvar, Highcode_Kind ))) -> (Kenv, ((acf::Expression, acf::Expression) -> acf::Expression))
#
fun tk_abs (kenv, tvks, f)
=
{ my (vs, ks) = paired_lists::unzip tvks;
#
tk_abs_fn (kenv, vs, ks, f, fkfct);
};
# my tk_tfn: (Kenv, List( hct::Highcode_Kind )) -> (Kenv, (acf::Expression -> acf::Expression))
#
fun tk_tfn (kenv, ks)
=
{ vs = map (\\ _ = make_var ()) ks;
f = make_var();
#
my (nkenv, header) = tk_abs_fn (kenv, vs, ks, f, fkfun);
#
(nkenv, \\ e = header (e, acf::RET [acf::VAR f]));
};
# rt_lexr lvars, hut::type::BASETYPE to proper constants
# my rt_lexp: kenv -> Uniqtype -> rtype
#
fun rt_lexp # "rt" is probably "runtime"
(kenv: Kenv)
(tc: hut::Uniqtype)
=
loop tc
where
fun loop (x: hut::Uniqtype)
=
case (hut::uniqtype_to_type x)
#
hut::type::TYPEFUN (ks, tx)
=>
{ my (nenv, header) = tk_tfn (kenv, ks);
header (rt_lexp nenv tx);
};
hut::type::APPLY_TYPEFUN (tx, ts)
=>
case (hut::uniqtype_to_type tx)
#
( hut::type::APPLY_TYPEFUN _
| hut::type::ITH_IN_TYPESEQ _
| hut::type::DEBRUIJN_TYPEVAR _
)
=>
app_g (loop tx, tcs_lexp (kenv, ts));
_ => tcode_truevoid;
esac;
hut::type::TYPESEQ ts
=>
tcs_lexp (kenv, ts);
hut::type::ITH_IN_TYPESEQ (tx, i)
=>
select_g (i, loop tx);
hut::type::BASETYPE pt
=>
if (pt == hbt::basetype_float64) tcode_float64;
elif (pt == hbt::basetype_int1) tcode_int1;
else tcode_truevoid;
fi;
hut::type::DEBRUIJN_TYPEVAR (i, j)
=>
acf::RET [(acf::VAR (vlook_ke (kenv, i, j)))];
hut::type::TUPLE (_, [t1, t2])
=>
case (is_float (kenv, t1), is_float (kenv, t2))
#
(YES, YES)
=>
tcode_fpair;
((NO, _) | (_, NO))
=>
tcode_pair;
((MAYBE e, YES) | (YES, MAYBE e))
=>
{ test = ieq_lexp (e, tcode_float64);
#
cond (test, tcode_fpair, tcode_pair);
};
(MAYBE e1, MAYBE e2)
=>
{ e = iadd_lexp (e1, e2);
test = ieq_lexp (e, tcode_real_n 2);
cond (test, tcode_fpair, tcode_pair);
};
esac;
hut::type::TUPLE (_, []) => tcode_truevoid;
hut::type::TUPLE (_, ts) => tcode_record;
hut::type::ARROW (_, tc1, tc2) => tcode_truevoid;
hut::type::ABSTRACT tx => loop tx;
hut::type::EXTENSIBLE_TOKEN (_, tx) => loop tx;
hut::type::RECURSIVE ((n, tx, ts), i)
=>
{ ntx = case ts
#
[] => tx;
_ =>
case (hut::uniqtype_to_type tx)
#
hut::type::TYPEFUN(_, x) => x;
#
_ => bug "unexpected MUTUALLY_RECURSIVE_FNS 333 in rtLexp-loop";
esac;
esac;
tk = case (hut::uniqtype_to_type ntx)
#
hut::type::TYPEFUN (ks, _) => list::nth (ks, i);
#
_ => bug "unexpected MUTUALLY_RECURSIVE_FNS types in rtLexp-loop";
esac;
case (hut::uniqkind_to_kind tk)
#
hut::kind::KINDFUN (ks, _)
=>
{ (tk_tfn (kenv, ks)) -> (_, header);
#
header (tcode_truevoid);
};
_ => tcode_truevoid;
esac;
};
hut::type::NAMED_TYPEVAR v => acf::RET [acf::VAR v];
hut::type::SUM _ => bug "unexpected hut::type::SUM Uniqtype in rtLexp-loop";
hut::type::TYPE_CLOSURE _ => bug "unexpected hut::type::TYPE_CLOSURE Uniqtype in rtLexp-loop";
hut::type::FATE _ => bug "unexpected hut::type::FATE Uniqtype in rtLexp-loop";
hut::type::INDIRECT_TYPE_THUNK _ => bug "unexpected hut::type::INDIRECT_TYPE_THUNK Uniqtype in rtLexp-loop";
_ => bug "unexpected Uniqtype in rtLexp-loop";
esac;
end # fun rt_lexp
also
fun tcs_lexp (kenv, ts)
=
{ fun h tc = rt_lexp kenv tc;
#
record_g (map h ts);
}
also
fun ts_lexp (kenv, ts)
=
{ fun h tc = rt_lexp kenv tc;
#
srecord_g (map h ts);
}
also
fun is_float (kenv, tc)
=
loop tc
where
fun loop x
=
case (hut::uniqtype_to_type x)
#
hut::type::BASETYPE pt
=>
pt == hbt::basetype_float64
?? YES
:: NO;
hut::type::TUPLE (_, ts) => NO;
hut::type::ARROW (_, tc1, tc2) => NO;
hut::type::RECURSIVE(_, i) => NO;
hut::type::EXTENSIBLE_TOKEN(_, tx)
=>
loop tx;
hut::type::APPLY_TYPEFUN (tx, _)
=>
case (hut::uniqtype_to_type tx)
#
(hut::type::APPLY_TYPEFUN _ | hut::type::ITH_IN_TYPESEQ _ | hut::type::DEBRUIJN_TYPEVAR _)
=>
MAYBE (rt_lexp kenv x);
_ => NO;
esac;
# | (hut::type::ABSTRACT tx) => loop tx
hut::type::DEBRUIJN_TYPEVAR (i, j)
=>
{ k = klook_ke (kenv, i, j);
case (hut::uniqkind_to_kind k)
#
hut::kind::BOXEDTYPE => NO;
_ => MAYBE (rt_lexp kenv x);
esac;
};
_ => MAYBE (rt_lexp kenv x);
esac;
end;
fun is_pair (kenv, tc)
=
loop tc
where
fun loop x
=
case (hut::uniqtype_to_type x)
#
hut::type::TUPLE (_, [_, _]) => YES;
hut::type::TUPLE _ => NO;
hut::type::BASETYPE pt => NO;
hut::type::ARROW _ => NO;
hut::type::RECURSIVE(_, i) => NO;
hut::type::EXTENSIBLE_TOKEN(_, tx)
=>
loop tx;
hut::type::APPLY_TYPEFUN (tx, _)
=>
case (hut::uniqtype_to_type tx)
#
( hut::type::APPLY_TYPEFUN _
| hut::type::ITH_IN_TYPESEQ _
| hut::type::DEBRUIJN_TYPEVAR _
| hut::type::NAMED_TYPEVAR _
)
=>
MAYBE (rt_lexp kenv x);
_ => NO;
esac;
# | (hut::type::ABSTRACT tx) => loop tx
_ => MAYBE (rt_lexp kenv x);
esac;
end;
}; # package anormcode_runtime_type
end; # stipulate