## translate-lambdacode-to-anormcode.pkg
## monnier@cs.yale.edu
#
# Converting lambdacode_form::Lambdacode_Expression
# to anormcode_form::Function.
#
#
#
# CONTEXT:
#
# The Mythryl compiler code representations used are, in order:
#
# 1) Raw Syntax is the initial frontend code representation.
# 2) Deep Syntax is the second and final frontend code representation.
# 3) Lambdacode is the first backend code representation, used only transitionally.
# 4) Anormcode (A-Normal format, which preserves expression tree structure) is the second backend code representation, and the first used for optimization.
# 5) Nextcode ("continuation-passing style", a single-assignment basic-block-graph form where call and return are essentially the same) is the third and chief backend tophalf code representation.
# 6) Treecode is the backend tophalf/lowhalf transitional code representation. It is typically slightly specialized for each target architecture, e.g. Intel32 (x86).
# 7) Machcode abstracts the target architecture machine instructions. It gets specialized for each target architecture.
# 8) Execode is absolute executable binary machine instructions for the target architecture.
#
# Our task here is converting from the third to the fourth form.
#
#
#
# For lambdacode code format see: src/lib/compiler/back/top/lambdacode/lambdacode-form.api# For A-Normal code format see: src/lib/compiler/back/top/anormcode/anormcode-form.api# We get invoked (only) from: src/lib/compiler/toplevel/main/translate-raw-syntax-to-execode-g.pkg# Compiled by:
# src/lib/compiler/core.sublib### "Reading a translation is like examining
### the back of a piece of tapesty."
###
### -- Cervantes.
#DO set_control "compiler::trap_int_overflow" "TRUE";
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkg package lcf = lambdacode_form; # lambdacode_form is from src/lib/compiler/back/top/lambdacode/lambdacode-form.pkgherein
api Translate_Lambdacode_To_Anormcode {
#
translate_lambdacode_to_anormcode
:
lcf::Lambdacode_Expression
->
acf::Function;
};
end;
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkg package acj = anormcode_junk; # anormcode_junk is from src/lib/compiler/back/top/anormcode/anormcode-junk.pkg package di = debruijn_index; # debruijn_index is from src/lib/compiler/front/typer/basics/debruijn-index.pkg package m2m = convert_monoarg_to_multiarg_anormcode; # convert_monoarg_to_multiarg_anormcode is from src/lib/compiler/back/top/lambdacode/convert-monoarg-to-multiarg-anormcode.pkg package hbo = highcode_baseops; # highcode_baseops is from src/lib/compiler/back/top/highcode/highcode-baseops.pkg package hcf = highcode_form; # highcode_form is from src/lib/compiler/back/top/highcode/highcode-form.pkg package hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg package lcf = lambdacode_form; # lambdacode_form is from src/lib/compiler/back/top/lambdacode/lambdacode-form.pkg package mtt = more_type_types; # more_type_types is from src/lib/compiler/front/typer/types/more-type-types.pkg package plx = prettyprint_lambdacode_expression; # prettyprint_lambdacode_expression is from src/lib/compiler/back/top/lambdacode/prettyprint-lambdacode-expression.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkgherein
package translate_lambdacode_to_anormcode
: (weak) Translate_Lambdacode_To_Anormcode # Translate_Lambdacode_To_Anormcode is from src/lib/compiler/back/top/lambdacode/translate-lambdacode-to-anormcode.pkg {
say = control_print::say;
make_codetemp = highcode_codetemp::issue_highcode_codetemp;
ident = \\ le: lcf::Lambdacode_Expression
=
le;
my (iadd_prim, uadd_prim)
=
{ lt_int = hcf::int_uniqtypoid;
#
int_op_type = hcf::make_lambdacode_arrow_uniqtypoid (hcf::make_tuple_uniqtypoid [lt_int, lt_int], lt_int);
addu = hbo::ARITH { op=>hbo::ADD, overflow=>FALSE, kind_and_size=>hbo::UNT 31 };
( lcf::BASEOP (hbo::iadd, int_op_type, []),
lcf::BASEOP (addu, int_op_type, [])
);
};
fun bug msg
=
error_message::impossible("translate_lambdacode_to_anormcode: " + msg);
stipulate
my (true_valcon', false_valcon')
=
( h mtt::true_valcon,
h mtt::false_valcon
)
where
type = hcf::make_arrow_uniqtypoid # Highcode type "Void -> Bool".
(
hcf::rawraw_variable_calling_convention,
[ hcf::void_uniqtypoid ],
[ hcf::bool_uniqtypoid ]
);
fun h (tdt::VALCON { name, form, ... } )
=
(name, form, type);
end;
fun bool_lexp b
=
{ v = make_codetemp();
w = make_codetemp();
dc = if b true_valcon';
else false_valcon';
fi;
acf::RECORD (acj::rk_tuple, [], v,
acf::CONSTRUCTOR (dc, [], acf::VAR v, w, acf::RET [acf::VAR w]));
};
herein
fun highcode_baseop
( baseop # : acf::Baseop
as
( dictionary: Null_Or( acf::Dictionary ), # Map from types to matching make_foo fns.
op: hbo::Baseop, # Op to perform -- add, shift, fetch-from-vector, whatever.
op_type: hut::Uniqtypoid, # Result of op.
arg_types: List( hut::Uniqtype )
),
vs, # Arg vals
v, # Highcode var
e # c_lexp
)
=
case op
# Branch baseops get translated into acf::BRANCH:
#
( hbo::IS_BOXED | hbo::IS_UNBOXED | hbo::COMPARE _ | hbo::POINTER_EQL
| hbo::POINTER_NEQ | hbo::POLY_EQL | hbo::POLY_NEQ
)
=>
acf::LET( [v],
acf::BRANCH (baseop, vs, bool_lexp TRUE, bool_lexp FALSE),
e
);
# baseops that take zero arguments;
# argument types must be void
#
( hbo::GET_RUNTIME_ASM_PACKAGE_RECORD # This appears to be dead code.
| hbo::GET_EXCEPTION_HANDLER_REGISTER
| hbo::GET_CURRENT_MICROTHREAD_REGISTER
| hbo::DEFLVAR # This appears to be dead code.
)
=>
{ fun fix t
=
hcf::if_uniqtypoid_is_arrow_type
( t,
\\ (ff,[t1], ts2)
=>
if (hcf::same_uniqtype (t1, hcf::void_uniqtype))
#
hcf::make_type_uniqtypoid (hcf::make_arrow_uniqtype (ff, [], ts2));
else
bug "unexpected zero-args prims 1 in highcode_baseop";
fi;
_ => bug "highcodePrim: t1";
end,
\\ _ = bug "unexpected zero-args prims 2 in highcode_baseop"
);
new_op_type
=
hcf::if_uniqtypoid_is_lambdacode_typeagnostic
( op_type,
\\ (ks, t) = hcf::make_lambdacode_typeagnostic_uniqtypoid (ks, fix t),
\\ _ = fix op_type
);
acf::BASEOP ((dictionary, op, new_op_type, arg_types), [], v, e);
};
_ => acf::BASEOP (baseop, vs, v, e);
esac;
end; # stipulate highcode_baseop
# force_raw freezes the calling conventions of a data constructor;
# strictly used by the CON and VALCON only
#
fun force_raw pty
=
if (hcf::uniqtypoid_is_lambdacode_typeagnostic pty)
#
my (ks, body) = hcf::unpack_lambdacode_typeagnostic_uniqtypoid pty;
my (aty, rty) = hcf::unpack_lambdacode_arrow_uniqtypoid body;
hcf::make_lambdacode_typeagnostic_uniqtypoid
( ks,
hcf::make_arrow_uniqtypoid
(
hcf::rawraw_variable_calling_convention,
[ m2m::ltc_raw aty ],
[ m2m::ltc_raw rty ]
)
);
else
(hcf::unpack_lambdacode_arrow_uniqtypoid pty)
->
(aty, rty);
hcf::make_arrow_uniqtypoid
(
hcf::rawraw_variable_calling_convention,
[ m2m::ltc_raw aty ],
[ m2m::ltc_raw rty ]
);
fi; # function force_raw
fun to_con con
=
case con
#
lcf::INT_CASETAG x => acf::INT_CASETAG x;
lcf::INT1_CASETAG x => acf::INT1_CASETAG x;
lcf::UNT_CASETAG x => acf::UNT_CASETAG x;
lcf::UNT1_CASETAG x => acf::UNT1_CASETAG x;
lcf::FLOAT64_CASETAG x => acf::FLOAT64_CASETAG x;
lcf::STRING_CASETAG x => acf::STRING_CASETAG x;
lcf::VLEN_CASETAG x => acf::VLEN_CASETAG x;
#
lcf::INTEGER_CASETAG _ => bug "INTEGER_CASETAG" ;
lcf::VAL_CASETAG x => bug "unexpected case in to_con";
esac;
fun to_function_declaration
( venv, # Maps highcode variables to types; initially empty. "venv" == "variable environment".
d, # Debruijn depth; initially di::top.
f_lv, # Codetemp to serve as fn name.
arg_lv, # Arg for function.
arg_lty, # Type of arg for function.
body, # Body of function.
loop_info # Initially FALSE.
)
=
{
if *log::debugging printf "to_function_declaration/AAA -- translate-lambdacode-to-anormcode.pkg\n"; fi;
(to_lambda_expression (hcf::set_uniqtypoid_for_var (venv, arg_lv, arg_lty, d), d) body) # Translate the body (in the extended dictionary):
->
(body', body_lty);
if *log::debugging printf "to_function_declaration/BBB -- translate-lambdacode-to-anormcode.pkg\n"; fi;
(m2m::v_punflatten arg_lty) # Detuple the arg type.
->
((arg_is_raw, arg_ltys, _), unflatten);
if *log::debugging printf "to_function_declaration/CCC -- translate-lambdacode-to-anormcode.pkg\n"; fi;
(unflatten (arg_lv, body')) # Add tupling code at the beginning of the body.
->
(arg_lvs, body'');
if *log::debugging printf "to_function_declaration/DDD -- translate-lambdacode-to-anormcode.pkg\n"; fi;
(m2m::t_pflatten body_lty) # Construct the return type if necessary.
->
(body_is_raw, body_ltys, _);
if *log::debugging printf "to_function_declaration/EEE -- translate-lambdacode-to-anormcode.pkg\n"; fi;
rettype = if (not loop_info) NULL;
else THE (map m2m::ltc_raw body_ltys, acf::OTHER_LOOP);
fi;
if *log::debugging printf "to_function_declaration/FFF -- translate-lambdacode-to-anormcode.pkg\n"; fi;
my (f_lty, fkind)
=
if (hcf::uniqtypoid_is_type arg_lty and hcf::uniqtypoid_is_type body_lty)
# A function:
#
( hcf::make_lambdacode_arrow_uniqtypoid (arg_lty, body_lty),
{ loop_info => rettype,
private => FALSE,
inlining_hint => acf::INLINE_IF_SIZE_SAFE,
call_as => acf::CALL_AS_FUNCTION (hcf::make_variable_calling_convention { arg_is_raw, body_is_raw })
}
);
else
# A generic package:
#
( hcf::make_lambdacode_generic_package_uniqtypoid (arg_lty, body_lty),
{ loop_info => rettype,
private => FALSE,
inlining_hint => acf::INLINE_IF_SIZE_SAFE,
call_as => acf::CALL_AS_GENERIC_PACKAGE
}
);
fi;
if *log::debugging printf "to_function_declaration/ZZZ -- translate-lambdacode-to-anormcode.pkg\n"; fi;
( (fkind, f_lv, paired_lists::zip (arg_lvs, map m2m::ltc_raw arg_ltys), body''),
f_lty
);
}
# Translate expressions whose structure is the same
# in Anormcode as in lambdacode (either both naming or both non-naming)
# a fate is unnecessary:
#
also
fun to_lambda_expression (venv, d) lambda_expression
=
{ fun default_to_values ()
=
to_values
( venv,
d,
lambda_expression,
\\ (vals, lambda_type)
=
(acf::RET vals, lambda_type)
);
if *log::debugging printf "to_lambda_expression/AAA -- translate-lambdacode-to-anormcode.pkg\n";
# print (pp::prettyprint_to_string [] {.
# pp = #pp;
# plx::prettyprint_lambdacode_expression pp lambda_expression;
# });
# printf "end of lambda-exprettion/AAA printout -- translate-lambdacode-to-anormcode.pkg\n";
fi;
case lambda_expression
#
# lcf::APPLY (lcf::BASEOP _, arg) => default_to_values();
# lcf::APPLY (lcf::GENOP _, arg) => default_to_values();
lcf::APPLY (lcf::BASEOP _, arg) => {
if *log::debugging printf "to_lambda_expression/BASEOP -- translate-lambdacode-to-anormcode.pkg\n"; fi;
default_to_values();
};
lcf::APPLY (lcf::GENOP _, arg) => {
if *log::debugging printf "to_lambda_expression/GENOP -- translate-lambdacode-to-anormcode.pkg\n"; fi;
default_to_values();
};
lcf::APPLY (lcf::FN (arg_lv, arg_lty, body), arg_le)
=>
{
if *log::debugging printf "to_lambda_expression/APPLY -- translate-lambdacode-to-anormcode.pkg\n"; fi;
to_lambda_expression (venv, d) (lcf::LET (arg_lv, arg_le, body));
};
lcf::APPLY (f, arg)
=>
# First, evaluate f to a mere value:
#
{
if *log::debugging printf "to_lambda_expression/APPLY(2) -- translate-lambdacode-to-anormcode.pkg\n"; fi;
to_value
( venv,
d,
f,
\\ (f_val, f_lty)
=
# Then evaluate the argument:
#
{
if *log::debugging printf "to_lambda_expression/APPLY(2)/\\ -- translate-lambdacode-to-anormcode.pkg\n"; fi;
to_values
( venv,
d,
arg,
\\ (arg_vals, arg_lty)
=
# Now find the return type:
#
{
if *log::debugging printf "to_lambda_expression/APPLY(2)/fn2/AAA -- translate-lambdacode-to-anormcode.pkg\n"; fi;
my (_, r_lty)
=
hcf::uniqtypoid_is_lambdacode_generic_package f_lty
?? hcf::unpack_lambdacode_generic_package_uniqtypoid f_lty
:: hcf::unpack_lambdacode_arrow_uniqtypoid f_lty;
if *log::debugging printf "to_lambda_expression/APPLY(2)/fn2/ZZZ -- translate-lambdacode-to-anormcode.pkg\n"; fi;
# And finally do the call:
#
(acf::APPLY (f_val, arg_vals), r_lty);
}
)
; }
);
};
lcf::MUTUALLY_RECURSIVE_FNS (lvs, ltys, lexps, lambda_expression)
=>
{
if *log::debugging printf "to_lambda_expression/MUTUALLY_RECURSIVE_FNS -- translate-lambdacode-to-anormcode.pkg\n"; fi;
venv' = paired_lists::fold_forward # First, set up the enriched dictionary with those funs.
(\\ (lv, lambda_type, ve) = hcf::set_uniqtypoid_for_var (ve, lv, lambda_type, d))
venv
(lvs, ltys);
fun map3 _ ([], _, _) => [];
map3 _ (_, [], _) => [];
map3 _ (_, _, []) => [];
map3 f (x ! xs, y ! ys, z ! zs)
=>
f (x, y, z) ! map3 f (xs, ys, zs);
end;
funs = map3 \\ (f_lv, f_lty, lcf::FN (arg_lv, arg_lty, body)) # Then translate each function in turn.
=>
#1 (to_function_declaration (venv', d, f_lv, arg_lv, arg_lty, body, TRUE));
_ =>
bug "non-function in lcf::MUTUALLY_RECURSIVE_FNS";
end
(lvs, ltys, lexps);
(to_lambda_expression (venv', d) lambda_expression) # Finally, translate the Lambdacode_Expression.
->
(lambda_expression', lambda_type);
( acf::MUTUALLY_RECURSIVE_FNS (funs, lambda_expression'),
lambda_type
);
};
lcf::LET (highcode_variable, lambda_expression1, lambda_expression2)
=>
{
if *log::debugging printf "to_lambda_expression/LET -- translate-lambdacode-to-anormcode.pkg\n"; fi;
to_lvar
( venv,
d,
highcode_variable,
lambda_expression1,
\\ lambda_type1
=
to_lambda_expression
( hcf::set_uniqtypoid_for_var (venv, highcode_variable, lambda_type1, d),
d
)
lambda_expression2
);
};
lcf::RAISE (le, r_lty)
=>
{
if *log::debugging printf "to_lambda_expression/RAISE -- translate-lambdacode-to-anormcode.pkg\n"; fi;
to_value
( venv,
d,
le,
\\ (le_val, le_lty)
=
{ my (_, r_ltys, _)
=
m2m::t_pflatten r_lty;
( acf::RAISE (le_val, map m2m::ltc_raw r_ltys),
r_lty
);
}
);
};
lcf::EXCEPT (body, handler)
=>
{
if *log::debugging printf "to_lambda_expression/EXCEPT -- translate-lambdacode-to-anormcode.pkg\n"; fi;
to_value
( venv,
d,
handler,
\\ (h_val, h_lty)
=
{ (to_lambda_expression (venv, d) body)
->
(body', body_lty);
(acf::EXCEPT (body', h_val), body_lty);
}
);
};
lcf::SWITCH (le, acs,[], NULL)
=> bug "unexpected case in lcf::SWITCH";
# to_value (venv, d, le, \\ _ = (acf::RET[], []))
lcf::SWITCH (le, acs,[], THE lambda_expression)
=>
{
if *log::debugging printf "to_lambda_expression/SWITCH -- translate-lambdacode-to-anormcode.pkg\n"; fi;
to_value
( venv,
d,
le,
\\ (v, lambda_type)
=
to_lambda_expression
(venv, d)
lambda_expression
);
};
lcf::SWITCH (le, acs, conlexps, default)
=>
{
if *log::debugging printf "to_lambda_expression/SWITCH(2) -- translate-lambdacode-to-anormcode.pkg\n"; fi;
fun f (lcf::VAL_CASETAG((s, cr, lambda_type), types, highcode_variable), le)
=>
{ my (lv_lty, _)
=
hcf::unpack_lambdacode_arrow_uniqtypoid
(hcf::apply_typeagnostic_type_to_arglist_with_single_result
(lambda_type, types)
);
newvenv = hcf::set_uniqtypoid_for_var (venv, highcode_variable, lv_lty, d);
(to_lambda_expression (newvenv, d) le)
->
(le, le_lty);
( ( acf::VAL_CASETAG
( (s, cr, force_raw lambda_type),
map m2m::tcc_raw types,
highcode_variable
),
le
),
le_lty
);
};
f (con, le)
=>
{ (to_lambda_expression (venv, d) le) -> (lambda_expression, lambda_type);
#
((to_con con, lambda_expression), lambda_type);
};
end;
to_value
( venv,
d,
le,
\\ (v, lambda_type)
=
{ default = null_or::map (#1 o to_lambda_expression (venv, d)) default;
conlexps = map f conlexps;
lambda_type = #2 (list::head conlexps);
(acf::SWITCH (v, acs, map #1 conlexps, default), lambda_type);
}
);
};
# For mere values, use to_values:
#
_ => {
if *log::debugging printf "to_lambda_expression/_ -- translate-lambdacode-to-anormcode.pkg\n"; fi;
default_to_values ();
};
esac;
}
# tovalue: turns a lambdacode Lambdacode_Expression into a value+type and then calls
# the fate that will turn it into an Anormcode Lambdacode_Expression+type
# (ltyenv * debruijn_index * lcf::Lambdacode_Expression * ((value * Uniqtypoid) -> (acf::Lambdacode_Expression * Uniqtypoid list))) -> (acf::Lambdacode_Expression * Uniqtypoid)
#
# - venv is the type dictionary for values
# - conts is the fate
#
also
fun to_value (venv, d, lambda_expression, fate)
=
case lambda_expression
#
# For simple values, it's trivial:
#
lcf::VAR v
=>
fate (acf::VAR v, hcf::get_uniqtypoid_for_var (venv, v, d));
lcf::INT i
=>
{ i+i+2; # Maybe trigger OVERFLOW exception.
fate (acf::INT i, hcf::int_uniqtypoid);
}
except
OVERFLOW
=
{ z = i / 2;
ne = lcf::APPLY (iadd_prim, lcf::RECORD [lcf::INT z, lcf::INT (i-z)]);
to_value (venv, d, ne, fate);
};
lcf::UNT i
=>
{ max_unt = 0ux20000000;
if (unt::(<) (i, max_unt))
#
fate (acf::UNT i, hcf::int_uniqtypoid);
else
x1 = unt::(/) (i, 0u2);
x2 = unt::(-) (i, x1);
ne = lcf::APPLY (uadd_prim, lcf::RECORD [lcf::UNT x1, lcf::UNT x2]);
to_value (venv, d, ne, fate);
fi;
};
lcf::INT1 n => fate (acf::INT1 n, hcf::int1_uniqtypoid);
lcf::UNT1 n => fate (acf::UNT1 n, hcf::int1_uniqtypoid);
lcf::FLOAT64 x => fate (acf::FLOAT64 x, hcf::float64_uniqtypoid);
lcf::STRING s => fate (acf::STRING s, hcf::string_uniqtypoid);
# For cases where to_lvar is more convenient:
#
_ =>
{ lv = make_codetemp();
to_lvar
( venv,
d,
lv,
lambda_expression,
\\ lambda_type
=
fate (acf::VAR lv, lambda_type)
);
};
esac
# to_values: turns a lambdacode Lambdacode_Expression into a list of values and a list of types
# and then calls the fate that will turn it into an Anormcode Lambdacode_Expression+type
#
# ( ltyenv,
# debruijn_index,
# lcf::Lambdacode_Expression,
# ((List(value), List(Uniqtypoid)) -> (acf::Lambdacode_Expression, List(Uniqtypoid)))
# )
# -> (acf::Lambdacode_Expression, Uniqtypoid)
#
# - venv is the type dictionary for values
# - fate is the fate
#
also
fun to_values (venv, d, lambda_expression, fate)
=
case lambda_expression
#
lcf::RECORD lexps
=>
lexps2values
( venv,
d,
lexps,
\\ (vals, ltys)
=
{ lambda_type = hcf::make_tuple_uniqtypoid ltys;
#
(m2m::t_pflatten lambda_type)
->
(_, ltys, _);
# Detect the case where
# flattening is trivial:
#
if (hcf::same_uniqtypoid (lambda_type, hcf::make_tuple_uniqtypoid ltys) )
#
fate (vals, lambda_type);
else
lv = make_codetemp();
(m2m::v_pflatten lambda_type) -> (_, pflatten) ;
(pflatten (acf::VAR lv)) -> (vs, wrap) ;
(fate (vs, lambda_type)) -> (c_lexp, c_lty);
( acf::RECORD (acj::rk_tuple, vals, lv, wrap c_lexp),
c_lty
);
fi;
}
);
_ =>
to_value
( venv,
d,
lambda_expression,
\\ (v, lambda_type)
=
{ ((#2 (m2m::v_pflatten lambda_type)) v)
->
(vs, wrap);
(fate (vs, lambda_type))
->
(c_lexp, c_lty);
(wrap c_lexp, c_lty);
}
);
esac
# Evaluate each lambda_expression
# to a value:
#
also
fun lexps2values (venv, d, lexps, fate)
=
f lexps ([], [])
where
fun f [] (vals, ltys)
=>
fate (reverse vals, reverse ltys);
f (lambda_expression ! lexps) (vals, ltys)
=>
to_value
( venv,
d,
lambda_expression,
\\ (v, lambda_type)
=
f lexps (v ! vals, lambda_type ! ltys)
);
end;
end
# to_lvar: Same as to_value except that
# it binds the value of the lambdacode
# to the indicated Variable
# and passes just the type to the continuation:
#
also
fun to_lvar
( venv,
d,
highcode_variable,
lambda_expression,
fate
)
=
{ fun eta_expand (f, f_lty) # "eta-expansion" is the conversion f -> \\ x = f(x)
= # E.g., we do this to baseops because they are not legal function values in anormcode (unlike lambdacode).
{ lv = make_codetemp();
#
(hcf::unpack_lambdacode_arrow_uniqtypoid f_lty)
->
(arg_lty, ret_lty); # Arg type and return type of 'f'.
to_lvar
( venv,
d,
highcode_variable,
lcf::FN (lv, arg_lty, lcf::APPLY (f, lcf::VAR lv)),
fate
);
};
# inbetween to_lvar and to_value:
# it binds the lambda_expression
# to a variable but is free to choose
# the Variable and passes
# it to the continutation:
#
fun to_lvarvalue (venv, d, lambda_expression, fate)
=
to_value
( venv,
d,
lambda_expression,
\\ (v, lambda_type)
=
case v
#
acf::VAR lv
=>
fate (lv, lambda_type);
_ =>
{ lv = make_codetemp ();
#
(fate (lv, lambda_type))
->
(lambda_expression', lambda_type);
(acf::LET ([lv], acf::RET [v], lambda_expression'), lambda_type);
};
esac
);
fun baseop_helper (arg, f_lty, types, filler)
=
# Invariant: baseop's types are always fully closed.
#
{ # pty is the resulting highcode type of the underlying baseop,
# r_lty is the result lambdacode type of this baseop expression,
# and flatten_args indicates whether we should flatten the arguments or not.
# The results of baseops are never flattened.
#
my (pty, r_lty, flatten_args)
=
case (hcf::uniqtypoid_is_lambdacode_typeagnostic f_lty, types)
#
(TRUE, _) # Typeagnostic case.
=>
{ my (ks, lt ) = hcf::unpack_lambdacode_typeagnostic_uniqtypoid f_lty;
my (aty, rty) = hcf::unpack_lambdacode_arrow_uniqtypoid lt;
r_lty
=
hcf::apply_typeagnostic_type_to_arglist_with_single_result
( hcf::make_lambdacode_typeagnostic_uniqtypoid (ks, rty),
types
);
(m2m::t_pflatten aty) -> (_, atys, flatten_args);
# You really want to have a simpler # XXX SUCKO FIXME
# flattening heuristic here; in fact,
# baseop can have its own flattening
# strategy. The key is that baseop's
# type never escape outside.
atys = map m2m::ltc_raw atys;
nrty = m2m::ltc_raw rty;
pty = hcf::make_arrow_uniqtypoid
(
hcf::rawraw_variable_calling_convention,
atys,
[ nrty ]
);
( hcf::make_lambdacode_typeagnostic_uniqtypoid (ks, pty),
r_lty,
flatten_args
);
};
(FALSE, []) # Typelocked case.
=>
{ (hcf::unpack_lambdacode_arrow_uniqtypoid f_lty)
->
(aty, rty );
(m2m::t_pflatten aty)
->
(_, atys, flatten_args);
atys = map m2m::ltc_raw atys;
nrty = m2m::ltc_raw rty;
pty = hcf::make_arrow_uniqtypoid
(
hcf::rawraw_variable_calling_convention,
atys,
[nrty]
);
(pty, rty, flatten_args);
};
_ => bug "unexpected case in baseop_helper";
esac;
if flatten_args
#
# ZHONG asks: is the following definitely safe ? XXX QUERO FIXME
# what would happen if ltc_raw is not an identity function ?
#
to_values
( venv,
d,
arg,
\\ (arg_vals, arg_lty)
=
{ (fate (r_lty)) -> (c_lexp, c_lty);
#
(filler (arg_vals, pty, c_lexp), c_lty); # Put the filling inbetween.
}
);
else
to_value
( venv,
d,
arg,
\\ (arg_val, arg_lty)
=
{ (fate (r_lty)) -> (c_lexp, c_lty);
#
(filler([arg_val], pty, c_lexp), c_lty); # Put the filling inbetween.
}
);
fi;
}; # fun baseop_helper
fun default_tolexp ()
=
{ (to_lambda_expression (venv, d) lambda_expression)
->
(lambda_expression', lambda_type);
(fate (lambda_type)) -> (c_lexp, c_lty);
(m2m::v_punflatten lambda_type) -> (_, punflatten);
(punflatten (highcode_variable, c_lexp)) -> (lvs, c_lexp' );
(acf::LET (lvs, lambda_expression', c_lexp'), c_lty);
};
# fun default_to_value ()
# =
# to_value
# ( venv,
# d,
# lambda_expression,
# \\ (v, lambdaType)
# =
# { my (lambda_expression', ltys) = fate (lambdaType);
# (acf::LET([highcode_variable], acf::RET[v], lambda_expression'), ltys) ;
# }
# )
case lambda_expression
#
# baseops have to be eta-expanded (wrapped in functions) here because
# bare baseops are not valid function values in anormcode (unlike lambdacode):
lcf::BASEOP (_, lambda_type, types) => eta_expand (lambda_expression, hcf::apply_typeagnostic_type_to_arglist_with_single_result (lambda_type, types));
lcf::GENOP (_, _, lambda_type, types) => eta_expand (lambda_expression, hcf::apply_typeagnostic_type_to_arglist_with_single_result (lambda_type, types));
lcf::FN (arg_lv, arg_lty, body)
=>
# Translate the body with the extended
# dictionary into a Function_Declaration:
#
{ (to_function_declaration (venv, d, highcode_variable, arg_lv, arg_lty, body, FALSE))
->
(function_declaration as (fk, f_lv, args, body'), f_lty);
(fate f_lty)
->
(lambda_expression, lambda_type);
( acf::MUTUALLY_RECURSIVE_FNS ( [function_declaration], lambda_expression),
lambda_type
);
};
# This is were we really deal with baseops:
#
lcf::APPLY (lcf::BASEOP (baseop, f_lty, types), arg)
=>
baseop_helper
( arg,
f_lty,
types,
\\ (arg_vals, pty, c_lexp)
=
highcode_baseop
( (NULL, baseop, pty, map m2m::tcc_raw types),
arg_vals,
highcode_variable,
c_lexp
)
);
lcf::APPLY (lcf::GENOP( { default, table }, baseop, f_lty, types), arg)
=>
{ fun evaluate_table ([], result, fate)
=>
fate result;
evaluate_table ((types, le) ! t1, t2, fate)
=>
to_lvarvalue
( venv,
d,
le,
\\ (le_lv, le_lty)
=
evaluate_table (t1, (map m2m::tcc_raw types, le_lv) ! t2, fate)
);
end;
# First, evaluate default:
#
to_lvarvalue
( venv,
d,
default,
\\ (default_lv, default_lty)
=
# Then evaluate the table:
#
evaluate_table ( table,
[],
\\ table'
=
baseop_helper
( arg,
f_lty,
types,
\\ (arg_vals, pty, c_lexp)
=
highcode_baseop
( ( THE { default => default_lv,
table => table'
},
baseop,
pty,
map m2m::tcc_raw types
),
arg_vals,
highcode_variable,
c_lexp
)
)
)
);
};
lcf::TYPEFUN (tks, body)
=>
{ my (body', body_lty)
=
to_value
( venv,
di::next d,
body,
\\ (le_val, le_lty)
=
(acf::RET [le_val], le_lty)
);
lambda_type = hcf::make_lambdacode_typeagnostic_uniqtypoid (tks, body_lty);
(fate (lambda_type))
->
(lambda_expression', lambda_type);
args = map (\\ tk = (make_codetemp(), tk)) tks;
( acf::TYPEFUN
( ( { inlining_hint => acf::INLINE_IF_SIZE_SAFE },
highcode_variable,
args,
body'
),
lambda_expression'
),
lambda_type
);
};
lcf::APPLY_TYPEFUN (f, types)
=>
# Similar to APPLY:
#
to_value
( venv,
d,
f,
\\ (f_val, f_lty)
=
{ f_lty = hcf::apply_typeagnostic_type_to_arglist_with_single_result
(f_lty, types);
my (c_lexp, c_lty)
=
fate (f_lty);
( acf::LET( [highcode_variable],
acf::APPLY_TYPEFUN (f_val, map m2m::tcc_raw types),
c_lexp
),
c_lty
);
}
);
lcf::EXCEPTION_TAG (le, lambda_type)
=>
to_value
( venv,
d,
le,
\\ (le_lv, le_lty)
=
{ (fate (hcf::make_exception_tag_uniqtypoid lambda_type))
->
(c_lexp, c_lty);
make_exception_tag
=
acj::make__make_exception_tag
#
(m2m::tcc_raw (hcf::unpack_type_uniqtypoid lambda_type));
( highcode_baseop (make_exception_tag, [le_lv], highcode_variable, c_lexp),
c_lty
);
}
);
lcf::CONSTRUCTOR ((s, cr, lambda_type), types, le)
=>
to_value
( venv,
d,
le,
\\ (v, _)
=
{ r_lty = hcf::apply_typeagnostic_type_to_arglist_with_single_result
#
(lambda_type, types);
(hcf::unpack_lambdacode_arrow_uniqtypoid r_lty) -> (_, v_lty);
(fate v_lty) -> (c_lexp, c_lty);
( acf::CONSTRUCTOR
( (s, cr, force_raw lambda_type),
map m2m::tcc_raw types,
v,
highcode_variable,
c_lexp
),
c_lty
);
}
);
lcf::VECTOR (lexps, type)
=>
lexps2values
( venv,
d,
lexps,
\\ (vals, ltys)
=
{ lambda_type
=
hcf::make_type_uniqtypoid
#
(hcf::make_ro_vector_uniqtype type);
(fate (lambda_type)) -> (c_lexp, c_lty);
( acf::RECORD
( acf::RK_VECTOR (m2m::tcc_raw type),
vals,
highcode_variable,
c_lexp
),
c_lty
);
}
);
lcf::RECORD lexps
=>
lexps2values
( venv,
d,
lexps,
\\ (vals, ltys)
=
{ lambda_type = hcf::make_tuple_uniqtypoid ltys;
#
(fate lambda_type) -> (c_lexp, c_lty);
(acf::RECORD (acj::rk_tuple, vals, highcode_variable, c_lexp), c_lty);
}
);
lcf::PACKAGE_RECORD lexps
=>
lexps2values
( venv,
d,
lexps,
\\ (vals, ltys)
=
{ lambda_type = hcf::make_package_uniqtypoid ltys;
#
(fate lambda_type) -> (c_lexp, c_lty);
( acf::RECORD
( acf::RK_PACKAGE,
vals,
highcode_variable,
c_lexp
),
c_lty
);
}
);
lcf::GET_FIELD (n, lambda_expression)
=>
to_value
( venv,
d,
lambda_expression,
\\ (v, lambda_type)
=
{ lambda_type = (hcf::lt_get_field (lambda_type, n));
#
(fate lambda_type) -> (c_lexp, c_lty);
( acf::GET_FIELD (v, n, highcode_variable, c_lexp),
c_lty
);
}
);
lcf::PACK (lambda_type, otypes, ntypes, lambda_expression)
=>
bug "PACK is not currently supported";
/*
to_value (venv, d, lambda_expression,
\\ (v, v_lty) =>
let nlty = hcf::pmacroExpandPolymorephicLambdaTypeOrHOC (lambdaType, ntypes)
my (c_lexp, c_lty) = fate (nlty)
in (acf::PACK (lambdaType,
map m2m::tcc_raw otypes,
map m2m::tcc_raw ntypes,
v, highcode_variable, c_lexp),
c_lty)
end)
*/
# these ones shouldn't matter because they shouldn't appear
# | lcf::WRAP _ => bug "unexpected WRAP in plambda"
# | lcf::UNWRAP _ => bug "unexpected UNWRAP in plambda"
_ => default_tolexp ();
esac;
};
# We get invoked (only) from:
#
# src/lib/compiler/toplevel/main/translate-raw-syntax-to-execode-g.pkg #
fun translate_lambdacode_to_anormcode (lambda_expression as lcf::FN (arg_lv, arg_lty, body)) # PUBLIC.
=>
#1 (to_function_declaration (hcf::empty_highcode_variable_to_uniqtypoid_map, di::top, make_codetemp(), arg_lv, arg_lty, body, FALSE))
except
x = raise exception x;
translate_lambdacode_to_anormcode _
=>
bug "unexpected toplevel Lambdacode_Expression";
end;
}; # package translate_lambdacode_to_anormcode
end; # toplevel stipulate