## make-anormcode-coercion-fn.pkg
#
# "In order to support coercion of data objects
# from one representation to another, we define
# a 'coerce' operation on our lambda language
# [ ... ]
# 'coerce' is a compile-time operation; given
# two [Uniqtypoid]s t1 and t2, coerce(t1,t2)
# returns a coercion function that coerces one
# expression with type t1 into another expression
# with type t2..."
#
# -- Page 40 from Zhong Shao's PhD thesis:
# Compiling Standard ML for Efficient Execution on Modern Machines
# http://flint.cs.yale.edu/flint/publications/zsh-thesis.html
#
# We're invoked only from:
#
# src/lib/compiler/back/top/forms/insert-anormcode-boxing-and-coercion-code.pkg# Compiled by:
# src/lib/compiler/core.sublib### "All men dream: but not equally. Those who dream
### by night in the dusty recesses of their minds
### wake in the day to find that it was vanity: but
### the dreamers of the day are dangerous men, for
### they may act their dream with open eyes, to make
### it possible."
###
### -- T. E. Lawrence
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 hct = highcode_type; # highcode_type is from src/lib/compiler/back/top/highcode/highcode-type.pkg package hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkgherein
api Make_Anormcode_Coercion_Fn {
#
Wrapper_Dictionary;
empty_wrapper_dictionary: Void -> Wrapper_Dictionary;
wp_new: (Wrapper_Dictionary, di::Debruijn_Depth)
-> Wrapper_Dictionary;
wp_build: (Wrapper_Dictionary, acf::Expression)
-> acf::Expression;
unwrap_op: (Wrapper_Dictionary,
List( hut::Uniqtypoid ),
List( hut::Uniqtypoid ),
di::Debruijn_Depth)
-> Null_Or( List( acf::Value ) -> acf::Expression );
wrap_op: ( Wrapper_Dictionary,
List( hut::Uniqtypoid ),
List( hut::Uniqtypoid ),
di::Debruijn_Depth
)
-> Null_Or( List( acf::Value ) -> acf::Expression );
};
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 hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.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 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 prl = paired_lists; # paired_lists is from src/lib/std/src/paired-lists.pkgherein
package make_anormcode_coercion_fn
: (weak) Make_Anormcode_Coercion_Fn # Make_Anormcode_Coercion_Fn is from src/lib/compiler/back/top/forms/make-anormcode-coercion-fn.pkg {
#############################################################################
# Support fns and constants
#############################################################################
fun bug s
=
error_message::impossible ("Coerce: " + s);
fun say (s: String)
=
global_controls::print::say s;
fun make_var _ = tmp::issue_highcode_codetemp ();
ident = \\ le = le;
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 };
tfk = { inlining_hint => acf::INLINE_WHENEVER_POSSIBLE };
fun fromto (i, j)
=
i < j ?? i ! fromto (i+1, j)
:: [];
fun op_list (NULL ! r) => op_list r;
op_list ((THE _) ! r) => TRUE;
op_list [] => FALSE;
end;
fun wrap_primop (t, u, kont)
=
{ v = make_var ();
acj::wrap_primop (t, [u], v, kont (acf::VAR v));
};
fun unwrap_primop (t, u, kont)
=
{ v = make_var ();
#
acj::unwrap_primop (t, [u], v, kont (acf::VAR v));
};
fun retv (v) = acf::RET [v];
#############################################################################
# Wrapper caches and dictionaries
#############################################################################
Hdr = acf::Value -> acf::Expression;
Hdr_Option = Null_Or( Hdr );
Wrapper_Cache
=
int_red_black_map::Map( List( (hut::Uniqtypoid, Hdr_Option)) );
Wrapper_Dictionary
=
List ((Ref( List( acf::Function )), Ref (Wrapper_Cache)) );
my empty_wrapper_cache: Wrapper_Cache
=
int_red_black_map::empty;
fun empty_wrapper_dictionary ()
=
[(REF [], REF empty_wrapper_cache)];
fun wc_enter ([], t, x)
=>
bug "unexpected wenv in wc_enter";
wc_enter((_, z as REF m) ! _, t, x)
=>
{ h = hut::hash_uniqtypoid t;
z := int_red_black_map::set
(m, h, (t, x) ! (null_or::the_else (int_red_black_map::get (m, h), NIL)));
};
end;
fun wc_look ([], t)
=>
bug "unexpected wenv in wc_look";
wc_look((_, z as REF m) ! _, t)
=>
{ fun loop ((t', x) ! rest)
=>
hut::same_uniqtypoid (t, t')
?? THE x
:: loop rest;
loop []
=>
NULL;
end;
case (int_red_black_map::get (m, hut::hash_uniqtypoid t))
#
THE x => loop x;
NULL => NULL;
esac;
};
end;
fun wp_new (wrapper_dictionary, d)
=
{ od = length wrapper_dictionary;
# Sanity check:
#
if (d+1 != od) bug "inconsistent state in wpNew"; fi;
(REF [], REF empty_wrapper_cache) ! wrapper_dictionary;
};
fun wp_build ([], base)
=>
base;
wp_build ((wref, _) ! _, base)
=>
fold_forward
(\\ (fd, b) = acf::MUTUALLY_RECURSIVE_FNS([fd], b))
base
*wref;
end;
fun add_wrappers (wenv, p, d)
=
{ # The d value is ignored now but
# we may use it in the future
my (wref, _)
=
head wenv # (list::nth (wenv, d))
except
_ = bug "unexpected cases in add_wrappers";
wref := (p ! *wref);
};
# apply_wraps:
# ( List( hdr_option ),
# List( value ),
# (List( value ) -> acf::Expression)
# )
# ->
# acf::Expression
#
fun apply_wraps (wps, vs, fate)
=
g (wps, vs, ident, [])
where
fun g (NULL ! ws, v ! vs, header, nvs)
=>
g (ws, vs, header, v ! nvs);
g ((THE f) ! ws, v ! vs, header, nvs)
=>
{ nv = make_var();
g ( ws,
vs,
\\ le = header (acf::LET([nv], f v, le)),
(acf::VAR nv) ! nvs
);
};
g ([], [], header, nvs)
=>
header (fate (reverse nvs));
g _ => bug "unexpected cases in apply_wraps";
end;
end; # fun apply_wraps
# apply_wraps_with_filler does the same thing
# as apply_wraps except that it also fills in
# proper coercions when there are mismatches
# between the original values.
#
# Occurs strictly only for hut::type::ARROW case.
# The filler is generated by the
# Convert_Monoarg_To_Multiarg_Anormcode::v_coerce function.
#
# The boolean flag indicates whether the
# the filler should be applied before
# wrapping or after wrapping.
#
# apply_wraps_with_filler:
# Bool -> { filler: Null_Or( List( value ) -> (List( value ), (acf::Expression -> acf::Expression))),
# wps: List( hdr_option ), args: List( value ), fate: (List( value ) -> lex) }
# -> acf::Expression
#
fun apply_wraps_with_filler wrap_before { filler=>NULL, wps, args, fate }
=>
apply_wraps (wps, args, fate);
apply_wraps_with_filler wrap_before { filler=>THE ff, wps, args, fate }
=>
{ my ((nargs, nhdr), ncont)
=
if wrap_before
(ff args, fate);
else ((args, ident),
\\ vs = { my (nvs, h) = ff vs;
h (fate (nvs));
}
);
fi;
nhdr (apply_wraps (wps, nargs, ncont));
};
end;
#############################################################################
# Main Functions
#############################################################################
fun wrapper_fn (wflag, sflag) (wenv, nts, ots, d)
=
{ do_wrap = if sflag
\\ (w, fdec) = { add_wrappers (wenv, fdec, d);
\\ u = acf::APPLY (acf::VAR w, [u]);
};
else
\\ (w, fdec) = (\\ u = acf::MUTUALLY_RECURSIVE_FNS([fdec], acf::APPLY (acf::VAR w, [u])));
fi;
fun get_wrapper_type (wflag, nx, ox, do_it)
=
if (hut::same_uniqtype (nx, ox))
#
NULL;
else
if (not sflag)
#
do_it (hut::uniqtype_to_type nx, hut::uniqtype_to_type ox);
else
mark = if wflag hcf::int_uniqtypoid;
else hcf::float64_uniqtypoid;
fi; # hack
key = hcf::make_package_uniqtypoid [hcf::make_type_uniqtypoid nx, hcf::make_type_uniqtypoid ox, mark];
case (wc_look (wenv, key))
#
THE x => x;
#
NULL => { result = do_it (hut::uniqtype_to_type nx, hut::uniqtype_to_type ox);
wc_enter (wenv, key, result); result;
};
esac;
fi;
fi;
fun get_wrapper_lambda_type (wflag, nx, ox, do_it)
=
if (hut::same_uniqtypoid (nx, ox))
#
NULL;
#
elif (not sflag)
do_it ( hut::uniqtypoid_to_typoid nx,
hut::uniqtypoid_to_typoid ox
);
else
# We could always force the sharing here
#
mark = wflag ?? hcf::int_uniqtypoid
:: hcf::float64_uniqtypoid; # hack
key = hcf::make_package_uniqtypoid [nx, ox, mark];
case (wc_look (wenv, key))
#
THE x => x;
#
NULL =>
{ result = do_it ( hut::uniqtypoid_to_typoid nx,
hut::uniqtypoid_to_typoid ox
);
wc_enter (wenv, key, result);
result;
};
esac;
fi;
fun type_loop wflag (nx, ox)
=
get_wrapper_type
( wflag,
nx,
ox,
\\ (hut::type::EXTENSIBLE_TOKEN (_, nz), _) # sanity check: make_extensible_token_uniqtype (ox) = nx
=>
if (hcf::uniqtype_is_extensible_token nx)
#
my (ax, act)
=
if wflag (ox, wrap_primop);
else (nx, unwrap_primop);
fi;
if (hcf::uniqtype_is_basetype ox)
#
THE (\\ u = act (ox, u, retv));
else
wp = type_loop wflag (nz, ox);
f = make_var();
v = make_var();
my (tx, kont, u, header)
=
case wp
#
NULL =>
(ox, retv, acf::VAR v, ident);
THE hh
=>
if wflag
z = make_var();
(nz, retv, acf::VAR z, \\ e = acf::LET([z], hh (acf::VAR v), e));
else
(nz, hh, acf::VAR v, ident);
fi;
esac;
fdec = (fkfun, f, [(v, hcf::make_type_uniqtypoid ax)],
header (act (tx, u, kont)));
THE (do_wrap (f, fdec));
fi;
else
bug "unexpected hut::type::EXTENSIBLE_TOKEN in typeConstructorLoop";
fi;
(hut::type::TUPLE (nrf, nxs), hut::type::TUPLE (orf, oxs))
=>
{ wps = prl::map (type_loop wflag) (nxs, oxs);
if (op_list wps)
f = make_var();
v = make_var();
nl = fromto (0, length nxs);
u = acf::VAR v;
my (nvs, header) # Take out all the fields.
=
fold_backward
(\\ (i, (z, h))
=
{ x = make_var();
( (acf::VAR x) ! z,
\\ le = acf::GET_FIELD (u, i, x, h le)
);
}
)
([], ident)
nl;
my (ax, rf)
=
wflag ?? (hcf::make_type_uniqtypoid ox, nrf)
:: (hcf::make_type_uniqtypoid nx, orf);
fun fate nvs
=
{ z = make_var();
acf::RECORD (acf::RK_TUPLE rf, nvs, z, acf::RET [acf::VAR z]);
};
body = header (apply_wraps (wps, nvs, fate));
fdec = (fkfun, f, [(v, ax)], body);
THE (do_wrap (f, fdec));
else
NULL;
fi;
};
(hut::type::ARROW (_, nxs1, nxs2), hut::type::ARROW (_, oxs1, oxs2))
=>
{ my (awflag, rwflag) = (not wflag, wflag); # Polarity.
my (oxs1', filler1) = m2m::v_coerce (awflag, nxs1, oxs1);
wps1 = prl::map (type_loop awflag) (nxs1, oxs1');
my (oxs2', filler2) = m2m::v_coerce (rwflag, nxs2, oxs2);
wps2 = prl::map (type_loop rwflag) (nxs2, oxs2');
case (op_list wps1, op_list wps2, filler1, filler2)
#
(FALSE, FALSE, NULL, NULL)
=>
NULL;
_ =>
{ wf = make_var();
f = make_var();
rf = make_var();
my (ax, rxs1, rxs2)
=
if wflag (hcf::make_type_uniqtypoid ox, nxs1, oxs2);
else (hcf::make_type_uniqtypoid nx, oxs1, nxs2);fi;
parameters
=
map (\\ t = (make_var(), hcf::make_type_uniqtypoid t))
rxs1;
avs = map (\\ (x, _) = acf::VAR x)
parameters;
rvs = map make_var rxs2;
rbody
=
acf::LET
( rvs,
apply_wraps_with_filler
awflag
{ filler => filler1,
wps => wps1,
args => avs,
fate => (\\ wvs = acf::APPLY (acf::VAR f, wvs))
},
apply_wraps_with_filler
rwflag
{ filler => filler2,
wps => wps2,
args => map acf::VAR rvs, fate=>acf::RET
}
);
rfdec = (fkfun, rf, parameters, rbody);
body = acf::MUTUALLY_RECURSIVE_FNS([rfdec], acf::RET [acf::VAR rf]);
fdec = (fkfun, wf, [(f, ax)], body);
THE (do_wrap (wf, fdec));
};
esac;
};
(_, _)
=>
if (hcf::similar_uniqtypes (nx, ox))
#
NULL;
else
say " Type nx is: \n"; say (hcf::uniqtype_to_string nx);
say "\n Type ox is: \n"; say (hcf::uniqtype_to_string ox); say "\n";
bug "unexpected other types in typeConstructorLoop";
fi;
end # fn
); # fun type_loop
fun lambda_type_loop wflag (nx, ox)
=
get_wrapper_lambda_type (wflag, nx, ox, fn)
where
fun fn ( hut::typoid::TYPE nz,
hut::typoid::TYPE oz
)
=>
type_loop wflag (nz, oz);
fn( hut::typoid::PACKAGE nxs,
hut::typoid::PACKAGE oxs
)
=>
{ wps = prl::map (lambda_type_loop wflag) (nxs, oxs);
if (op_list wps)
f = make_var();
v = make_var();
nl = fromto (0, length nxs);
u = acf::VAR v;
my (nvs, header) # Take out all the fields
=
fold_backward
(\\ (i, (z, h))
=
{ x = make_var();
( (acf::VAR x) ! z,
\\ le = acf::GET_FIELD (u, i, x, h le)
);
}
)
([], ident)
nl;
fun fate nvs
=
{ z = make_var();
acf::RECORD (acf::RK_PACKAGE, nvs, z, acf::RET [acf::VAR z]);
};
body = header (apply_wraps (wps, nvs, fate));
ax = wflag ?? ox
:: nx;
fdec = (fkfct, f, [(v, ax)], body);
THE (do_wrap (f, fdec));
else
NULL;
fi;
};
fn( hut::typoid::GENERIC_PACKAGE (nxs1, nxs2),
hut::typoid::GENERIC_PACKAGE (oxs1, oxs2)
)
=>
{ wps1 = prl::map (lambda_type_loop (not wflag)) (nxs1, oxs1);
wps2 = prl::map (lambda_type_loop wflag) (nxs2, oxs2);
case (op_list wps1, op_list wps2)
#
(FALSE, FALSE)
=>
NULL;
_ =>
{ wf = make_var();
f = make_var();
rf = make_var();
my (ax, rxs1, rxs2)
=
wflag ?? (ox, nxs1, oxs2)
:: (nx, oxs1, nxs2);
parameters
=
map (\\ t = (make_var(), t))
rxs1;
avs = map (\\ (x, _) = acf::VAR x) parameters;
rvs = map make_var rxs2;
rbody
=
acf::LET ( rvs,
apply_wraps (wps1, avs, \\ wvs = acf::APPLY (acf::VAR f, wvs)),
apply_wraps (wps2, map acf::VAR rvs, \\ wvs = acf::RET wvs )
);
rfdec = (fkfct, rf, parameters, rbody);
body = acf::MUTUALLY_RECURSIVE_FNS( [rfdec], acf::RET [acf::VAR rf]);
fdec = (fkfct, wf, [(f, ax)], body);
THE (do_wrap (wf, fdec));
};
esac;
};
fn( hut::typoid::TYPEAGNOSTIC (nks, nzs),
hut::typoid::TYPEAGNOSTIC (oks, ozs)
)
=>
{ nwenv = wp_new (wenv, d);
wp = wrapper_fn (wflag, sflag) (nwenv, nzs, ozs, di::next d);
case wp
#
NULL => NULL;
THE (header: List( acf::Value ) -> acf::Expression)
=>
{ wf = make_var();
f = make_var();
rf = make_var();
my (ax, aks, rxs)
=
wflag ?? (ox, nks, ozs)
:: (nx, oks, nzs);
nl = fromto (0, length nks);
ts = map (\\ i = hcf::make_debruijn_typevar_uniqtype (di::innermost, i)) nl;
avs = map make_var rxs;
rbody = acf::LET (avs, acf::APPLY_TYPEFUN (acf::VAR f, ts), header (map acf::VAR avs));
nrbody = wp_build (nwenv, rbody);
atvks = map (\\ k = (tmp::issue_highcode_codetemp(), k)) aks;
body = acf::TYPEFUN((tfk, rf, atvks, nrbody), acf::RET [acf::VAR rf]);
fdec = (fkfct, wf, [(f, ax)], body);
THE (do_wrap (wf, fdec));
};
esac;
};
fn _
=>
{ say " Type nx is: \n"; say (hcf::uniqtypoid_to_string nx);
say "\n Type ox is: \n"; say (hcf::uniqtypoid_to_string ox);
say "\n";
bug "unexpected other ltys in lambdaTypeLoop";
};
end; # fun fn
end;
wps = prl::map (lambda_type_loop wflag) (nts, ots);
op_list wps
?? THE (\\ vs = apply_wraps (wps, vs, acf::RET))
:: NULL;
}; # fun wrapper_fn
fun unwrap_op (wenv, nts, ots, d)
=
{ nts' = map hut::reduce_uniqtypoid_to_normal_form nts;
ots' = map hut::reduce_uniqtypoid_to_normal_form ots;
sflag = *global_controls::highcode::sharewrap;
wrapper_fn
(FALSE, sflag)
(wenv, nts', ots', d);
};
fun wrap_op (wenv, nts, ots, d)
=
{ nts' = map hut::reduce_uniqtypoid_to_normal_form nts;
ots' = map hut::reduce_uniqtypoid_to_normal_form ots;
sflag = *global_controls::highcode::sharewrap;
wrapper_fn (TRUE, sflag) (wenv, nts', ots', d);
};
}; # package make_anormcode_coercion_fn
end; # stipulate