## anormcode-junk.pkg
# Compiled by:
# src/lib/compiler/core.sublibpackage highcodeint_map
=
int_binary_map; # int_binary_map is from src/lib/src/int-binary-map.pkgstipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.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.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkgherein
api Anormcode_Junk {
#
rk_tuple: acf::Record_Kind;
make__make_exception_tag: hut::Uniqtype -> acf::Baseop;
make__wrap: hut::Uniqtype -> acf::Baseop;
make__unwrap: hut::Uniqtype -> acf::Baseop;
wrap_primop
:
( hut::Uniqtype,
List( acf::Value ),
tmp::Codetemp,
acf::Expression
)
->
acf::Expression;
unwrap_primop
:
( hut::Uniqtype,
List( acf::Value ),
tmp::Codetemp,
acf::Expression
)
->
acf::Expression;
get_etag_type: acf::Baseop -> hut::Uniqtype;
get_wrap_type: acf::Baseop -> hut::Uniqtype;
get_un_wrap_type: acf::Baseop -> hut::Uniqtype;
# Copy a Expression with alpha renaming.
# Free variables remain unchanged except for the renaming specified
# in the first (types) and second (values) argument */
copy:
List( (tmp::Codetemp, hut::Uniqtype) )
->
highcodeint_map::Map( tmp::Codetemp )
->
acf::Expression
->
acf::Expression;
copyfdec
:
acf::Function
->
acf::Function;
freevars
:
acf::Expression
->
int_red_black_set::Set;
valcon_eq
:
( acf::Valcon,
acf::Valcon
)
->
Bool;
}; # api Anormcode_Utilities
end; # stipulate
stipulate
package acf = anormcode_form; # anormcode_form is from src/lib/compiler/back/top/anormcode/anormcode-form.pkg package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.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 him = highcodeint_map; # highcodeint_map is from src/lib/compiler/back/top/anormcode/anormcode-junk.pkg package is = int_red_black_set; # int_red_black_set is from src/lib/src/int-red-black-set.pkg package lms = list_mergesort; # list_mergesort is from src/lib/src/list-mergesort.pkg package no = null_or; # null_or is from src/lib/std/src/null-or.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkg package vh = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkgherein
package anormcode_junk
: (weak) Anormcode_Junk # Anormcode_Junk is from src/lib/compiler/back/top/anormcode/anormcode-junk.pkg {
fun bug msg
=
err::impossible("anormcode_junk: " + msg);
my rk_tuple: acf::Record_Kind
=
acf::RK_TUPLE (hcf::useless_recordflag);
# A set of useful baseops used by highcode
#
tv0 = hcf::make_typevar_i_uniqtypoid 0;
btv0 = hcf::make_type_uniqtypoid (hcf::make_boxed_uniqtype (hcf::make_typevar_i_uniqtype 0));
etag_lty
=
hcf::make_lambdacode_typeagnostic_uniqtypoid
(
[ hcf::plaintype_uniqkind ],
#
hcf::make_arrow_uniqtypoid
(
hcf::rawraw_variable_calling_convention,
[ hcf::string_uniqtypoid ],
[ hcf::make_exception_tag_uniqtypoid tv0 ]
)
);
fun wrap_lty tc
=
hcf::make_type_uniqtypoid (hcf::make_arrow_uniqtype (hcf::fixed_calling_convention, [tc], [hcf::make_extensible_token_uniqtype tc]));
fun unwrap_lty tc
=
hcf::make_type_uniqtypoid (hcf::make_arrow_uniqtype (hcf::fixed_calling_convention, [hcf::make_extensible_token_uniqtype tc], [tc]));
fun make__make_exception_tag tc = (NULL, hbo::MAKE_EXCEPTION_TAG, etag_lty, [tc]);
fun make__wrap tc = (NULL, hbo::WRAP, wrap_lty tc, [] );
fun make__unwrap tc = (NULL, hbo::UNWRAP, unwrap_lty tc, [] );
fun wrap_primop (tc, vs, v, e) = acf::BASEOP ( make__wrap tc, vs, v, e);
fun unwrap_primop (tc, vs, v, e) = acf::BASEOP (make__unwrap tc, vs, v, e);
# The corresponding utility functions
# to recover the Uniqtype:
#
fun get_etag_type (_, _, lt, [tc])
=>
tc;
get_etag_type (_, _, lt, [])
=>
{ nt = hcf::unpack_type_uniqtypoid (#2 (hcf::unpack_lambdacode_arrow_uniqtypoid lt));
if (hcf::uniqtype_is_apply_typefun nt)
#
case (#2 (hcf::unpack_apply_typefun_uniqtype nt))
[x] => x;
_ => bug "unexpected case 1 in getEtagTypeConstructor";
esac;
else
hcf::truevoid_uniqtype;
fi;
};
get_etag_type _
=>
bug "unexpected case 2 in getEtagTypeConstructor";
end;
fun get_wrap_type (_, _, lt, []) => hcf::unpack_type_uniqtypoid (#1 (hcf::unpack_lambdacode_arrow_uniqtypoid lt));
#
get_wrap_type _ => bug "unexpected case in get_wrap_type";
end;
fun get_un_wrap_type (_, _, lt, []) => hcf::unpack_type_uniqtypoid (#2 (hcf::unpack_lambdacode_arrow_uniqtypoid lt));
#
get_un_wrap_type _ => bug "unexpected case in get_un_wrap_type";
end;
fun valcon_eq ((s1, c1, t1): acf::Valcon, (s2, c2, t2))
=
symbol::eq (s1, s2)
and (c1 == c2)
and hcf::same_uniqtypoid (t1, t2);
cplv = tmp::clone_highcode_codetemp;
# General alpha-conversion on Expression.
# Free variables remain unchanged
# except for the renaming specified in the first argument.
# my copy: him::intmap( tmp::Codetemp ) -> Function_Declaration -> Function_Declaration
#
fun copy ta alpha le
=
copy' (tmap_sort ta) alpha le
where
tc_subst = hcf::tc_nvar_subst_fn();
lt_subst = hcf::lt_nvar_subst_fn();
tmap_sort = lms::sort_list (\\ ((v1, _), (v2, _)) = v1 > v2);
fun substvar alpha lv
=
case (him::get (alpha, lv))
#
THE lv => lv;
noe => lv;
esac;
fun substval alpha (acf::VAR lv) => acf::VAR (substvar alpha lv);
substval alpha v => v;
end;
fun newv (lv, alpha)
=
{ nlv = cplv lv;
(nlv, him::set (alpha, lv, nlv));
};
fun newvs (lvs, alpha)
=
fold_backward
(\\ (lv, (lvs, alpha))
=
{ (newv (lv, alpha)) -> (nlv, nalpha);
#
(nlv ! lvs, nalpha);
}
)
([], alpha)
lvs;
fun cdcon ta alpha (s, ac, lambda_type)
=
( s,
case ac
#
vh::EXCEPTION (vh::HIGHCODE_VARIABLE lv) =>
vh::EXCEPTION (vh::HIGHCODE_VARIABLE (substvar alpha lv));
_ => ac;
esac,
lt_subst ta lambda_type
);
fun cpo ta alpha (dictionary, po, lambda_type, types)
=
( no::map
(\\ { default, table }
=
{ default => substvar alpha default,
table => map (\\ (types, lv)
=
( map (tc_subst ta) types,
substvar alpha lv
)
)
table
}
)
dictionary,
po,
lt_subst ta lambda_type,
map (tc_subst ta) types
);
fun cfk ta { loop_info=>THE (ltys, lk), private, inlining_hint, call_as }
=>
{ loop_info => THE (map (lt_subst ta) ltys, lk),
private,
inlining_hint,
call_as
};
cfk _ fk
=>
fk;
end;
fun crk ta (acf::RK_VECTOR type)
=>
acf::RK_VECTOR (tc_subst ta type);
crk _ rk
=>
rk;
end;
fun copy' ta alpha le
=
{ cpo = cpo ta alpha;
cdcon = cdcon ta alpha;
substvar = substvar alpha;
substval = substval alpha;
copy = copy' ta;
case le
#
acf::RET vs => acf::RET (map substval vs);
#
acf::LET (lvs, le, body)
=>
{ nle = copy alpha le;
my (nlvs, nalpha) = newvs (lvs, alpha);
acf::LET (nlvs, nle, copy nalpha body);
};
acf::MUTUALLY_RECURSIVE_FNS (fdecs, le)
=>
{ fun cfun alpha ((fk, f, args, body): acf::Function, nf)
=
{ (newvs (map #1 args, alpha)) -> (nargs, nalpha);
( cfk ta fk,
nf,
paired_lists::zip (nargs, (map (lt_subst ta o #2) args)),
copy nalpha body
);
};
(newvs (map #2 fdecs, alpha)) -> (nfs, nalpha);
nfdecs = paired_lists::map (cfun nalpha) (fdecs, nfs);
acf::MUTUALLY_RECURSIVE_FNS (nfdecs, copy nalpha le);
};
acf::APPLY (f, args)
=>
acf::APPLY (substval f, map substval args);
acf::TYPEFUN ((tfk, lv, args, body), le)
=>
# Don't forget to rename the tvar also:
#
{ my (nlv, nalpha) = newv (lv, alpha);
my (nargs, ialpha) = newvs (map #1 args, nalpha);
ita = tmap_sort ( (paired_lists::map
(\\ ((t, k), nt) = (t, hcf::make_named_typevar_uniqtype nt))
(args, nargs)
)
@
ta
);
acf::TYPEFUN
( ( tfk, nlv,
paired_lists::zip (nargs, map #2 args),
copy' ita ialpha body
),
copy nalpha le
);
};
acf::APPLY_TYPEFUN (f, types)
=>
acf::APPLY_TYPEFUN (substval f, map (tc_subst ta) types);
acf::SWITCH (v, ac, arms, def)
=>
acf::SWITCH
( substval v,
ac,
map carm arms,
null_or::map (copy alpha) def
)
where
fun carm (acf::VAL_CASETAG (dc, types, lv), le) # "carm" might be "compile [SWITCH] arm" or such...?
=>
{ (newv (lv, alpha)) -> (nlv, nalpha);
( acf::VAL_CASETAG (cdcon dc, map (tc_subst ta) types, nlv),
copy nalpha le
);
};
carm (con, le)
=> (con, copy alpha le);
end;
end;
acf::CONSTRUCTOR (dc, types, v, lv, le)
=>
{ my (nlv, nalpha) = newv (lv, alpha);
acf::CONSTRUCTOR (cdcon dc, map (tc_subst ta) types, substval v, nlv, copy nalpha le);
};
acf::RECORD (rk, vs, lv, le)
=>
{ my (nlv, nalpha) = newv (lv, alpha);
acf::RECORD (crk ta rk, map substval vs, nlv, copy nalpha le);
};
acf::GET_FIELD (v, i, lv, le)
=>
{ (newv (lv, alpha)) -> (nlv, nalpha);
#
acf::GET_FIELD (substval v, i, nlv, copy nalpha le);
};
acf::RAISE (v, ltys)
=>
acf::RAISE (substval v, map (lt_subst ta) ltys);
acf::EXCEPT (le, v)
=>
acf::EXCEPT (copy alpha le, substval v);
acf::BRANCH (po, vs, le1, le2)
=>
acf::BRANCH (cpo po, map substval vs, copy alpha le1, copy alpha le2);
acf::BASEOP (po, vs, lv, le)
=>
{ (newv (lv, alpha)) -> (nlv, nalpha);
acf::BASEOP (cpo po, map substval vs, nlv, copy nalpha le);
};
esac;
};
end;
fun copyfdec fdec
=
case (copy [] him::empty (acf::MUTUALLY_RECURSIVE_FNS([fdec], acf::RET [])))
#
acf::MUTUALLY_RECURSIVE_FNS ([new_fdec], acf::RET [])
=>
new_fdec;
_ => bug "copyfdec";
esac;
fun freevars lambda_expression
=
{ loop = freevars;
#
fun s_rmv (x, s)
=
is::drop (s, x);
fun addv (s, acf::VAR lv) => is::add (s, lv);
addv (s, _ ) => s;
end;
fun addvs (s, vs) = fold_forward (\\ (v, s) = addv (s, v)) s vs;
fun rmvs (s, lvs) = fold_forward (\\ (l, s) = s_rmv (l, s)) s lvs;
fun singleton (acf::VAR v) => is::singleton v;
singleton _ => is::empty;
end;
fun fpo (fv, (NULL: Null_Or( acf::Dictionary ), po, lambda_type, types))
=>
fv;
fpo (fv, (THE { default, table }, po, lambda_type, types))
=>
addvs (addv (fv, acf::VAR default), map (acf::VAR o #2) table);
end;
fun fdcon (fv, (s, varhome::EXCEPTION (varhome::HIGHCODE_VARIABLE lv), lambda_type))
=>
addv (fv, acf::VAR lv);
fdcon (fv, _)
=>
fv;
end;
case lambda_expression
#
acf::RET vs
=>
addvs (is::empty, vs);
acf::LET (lvs, body, le)
=>
is::union (rmvs (loop le, lvs), loop body);
acf::MUTUALLY_RECURSIVE_FNS (fdecs, le)
=>
rmvs ( (fold_forward
(\\ ((_, _, args, body), fv)
=
is::union (rmvs (loop body, map #1 args), fv)
)
(loop le)
fdecs
),
map #2 fdecs
);
acf::APPLY (f, args)
=>
addvs (is::empty, f ! args);
acf::TYPEFUN ((tfk, f, args, body), le)
=>
is::union (s_rmv (f, loop le), loop body);
acf::APPLY_TYPEFUN (f, args)
=>
singleton f;
acf::SWITCH (v, ac, arms, def)
=>
fold_forward farm fvs arms
where
fun farm ((dc, le), fv)
=
{ fvle = loop le;
is::union
(
fv,
case dc
acf::VAL_CASETAG (dc, _, lv) => fdcon (s_rmv (lv, fvle), dc);
_ => fvle;
esac
);
};
fvs = case def NULL => singleton v;
THE le => addv (loop le, v);
esac;
end;
acf::CONSTRUCTOR (dc, types, v, lv, le)
=>
fdcon (addv (s_rmv (lv, loop le), v), dc);
acf::RECORD (rk, vs, lv, le)
=>
addvs (s_rmv (lv, loop le), vs);
acf::GET_FIELD (v, i, lv, le)
=>
addv (s_rmv (lv, loop le), v);
acf::RAISE (v, ltys)
=>
singleton v;
acf::EXCEPT (le, v)
=>
addv (loop le, v);
acf::BRANCH (po, vs, le1, le2)
=>
fpo (addvs (is::union (loop le1, loop le2), vs), po);
acf::BASEOP (po, vs, lv, le)
=>
fpo (addvs (s_rmv (lv, loop le), vs), po);
esac;
}; # fun freevars
}; # package anormcode_junk
end; # stipulate