## recover-anormcode-type-info.pkg
## Recover the type information of a closed highcode program
# Compiled by:
# src/lib/compiler/core.sublib### "Honesty is for the most part
### less profitable than dishonesty."
###
### -- Plato
stipulate
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 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
api Recover_Anormcode_Type_Info {
#
recover_anormcode_type_info
:
( acf::Function,
Bool
)
->
{ get_uniqtypoid_for_anormcode_value: acf::Value -> hut::Uniqtypoid,
clean_up: Void -> Void,
add_lty: (tmp::Codetemp, hut::Uniqtypoid) -> Void
};
};
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 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 hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.pkgherein
package recover_anormcode_type_info
: (weak) Recover_Anormcode_Type_Info
{
fun bug s
=
error_message::impossible ("Recover_Type_Info: " + s);
fun lt_inst (lt, ts)
=
case (hcf::apply_typeagnostic_type_to_arglist (lt, ts))
#
[x] => x;
_ => bug "unexpected case in ltInst";
esac;
# These two functions are applicable to the types of primops and data
# constructors only (ZHONG)
fun arglty (lt, ts)
=
{ my (_, atys, _)
=
hcf::unpack_arrow_uniqtypoid (lt_inst (lt, ts));
case atys
#
[x] => x;
_ => bug "unexpected case in arglty";
esac;
};
fun reslty (lt, ts)
=
{ my (_, _, rtys)
=
hcf::unpack_arrow_uniqtypoid (lt_inst (lt, ts));
case rtys
#
[x] => x;
_ => bug "unexpected case in reslty";
esac;
};
exception RECOVER_LTY;
fun recover_anormcode_type_info
(
fdec: acf::Function,
post_rep: Bool
)
=
{ my zz: iht::Hashtable( hut::Uniqtypoid )
=
iht::make_hashtable { size_hint => 32, not_found_exception => RECOVER_LTY };
get = iht::get zz;
addv = iht::set zz;
fun addvs vts
=
apply addv vts;
fun get_uniqtypoid_for_anormcode_value (acf::VAR v ) => get v;
get_uniqtypoid_for_anormcode_value (acf::INT _ | acf::UNT _) => hcf::int_uniqtypoid;
get_uniqtypoid_for_anormcode_value (acf::INT1 _ | acf::UNT1 _) => hcf::int1_uniqtypoid;
get_uniqtypoid_for_anormcode_value (acf::FLOAT64 _) => hcf::float64_uniqtypoid;
get_uniqtypoid_for_anormcode_value (acf::STRING _) => hcf::string_uniqtypoid;
end;
lt_nvar_cvt = hcf::lt_nvar_cvt_fn();
# loop: depth -> Lambda_Expression -> List( Uniqtypoid )
#
fun loop e
=
lpe e
where
fun lpv u = get_uniqtypoid_for_anormcode_value u;
fun lpvs vs = map lpv vs;
fun lpd (fk, f, vts, e)
=
{ addvs vts;
addv (f, hcf::ltc_fkfun (fk, map #2 vts, lpe e));
}
also
fun lpds (fds as ((fk as { loop_info=>THE _, ... }, _, _, _) ! _))
=>
{ apply h fds
where
fun h ((fk as { loop_info=>THE (rts, _), ... }, f, vts, _): acf::Function)
=>
addv (f, hcf::ltc_fkfun (fk, map #2 vts, rts));
h _ => bug "unexpected case in lpds";
end;
end;
apply lpd fds;
};
lpds [fd] => lpd fd;
lpds _ => bug "unexpected case 2 in lpds";
end
also
fun lpc (acf::VAL_CASETAG((_, _, lt), ts, v), e)
=>
{ addv (v, arglty (lt, ts));
lpe e;
};
lpc (_, e)
=>
lpe e;
end
also
fun lpe (acf::RET vs)
=>
lpvs vs;
lpe (acf::LET (vs, e1, e2))
=>
{ addvs (paired_lists::zip (vs, lpe e1));
lpe e2;
};
lpe (acf::MUTUALLY_RECURSIVE_FNS (fdecs, e))
=>
{ lpds fdecs;
lpe e;
};
lpe (acf::APPLY (u, vs))
=>
#2 (hcf::ltd_fkfun (lpv u));
lpe (acf::TYPEFUN((tfk, v, tvks, e1), e2))
=>
{ addv (v, hcf::lt_nvpoly (tvks, loop e1));
lpe e2;
};
lpe (acf::APPLY_TYPEFUN (v, ts))
=>
hcf::apply_typeagnostic_type_to_arglist (lpv v, ts);
lpe (acf::RECORD (rk, vs, v, e))
=>
{ addv (v, hcf::ltc_rkind (rk, lpvs vs));
lpe e;
};
lpe (acf::GET_FIELD (u, i, v, e))
=>
{ addv (v, hcf::ltd_rkind (lpv u, i));
lpe e;
};
lpe (acf::CONSTRUCTOR((_, _, lt), ts, _, v, e))
=>
{ addv (v, reslty (lt, ts));
lpe e;
};
lpe (acf::SWITCH(_, _, ces, e))
=>
{ lts = map lpc ces;
case e NULL => head lts;
THE e => lpe e;
esac;
};
lpe (acf::RAISE (_, lts)) => lts;
lpe (acf::EXCEPT (e, _)) => lpe e;
lpe (acf::BRANCH (p, _, e1, e2))
=>
{ lpe e1;
lpe e2;
};
lpe (acf::BASEOP((_, hbo::WCAST, lt, []), _, v, e))
=>
if (post_rep)
#
case (hcf::unpack_generic_package_uniqtypoid lt)
#
([_],[r]) => { addv (v, r); lpe e;};
_ => bug "unexpected case for WCAST";
esac;
else
bug "unexpected baseop WCAST in recover_type_info";
fi;
lpe (acf::BASEOP((_, _, lt, ts), _, v, e))
=>
{ addv (v, reslty (lt, ts));
lpe e;
};
end;
end; # while (fun transform)
my (fkind, f, vts, e) = fdec;
addvs vts;
atys = map #2 vts;
rtys = loop e;
addv (f, hcf::ltc_fkfun (fkind, atys, rtys));
{ get_uniqtypoid_for_anormcode_value,
clean_up => \\ () = iht::clear zz,
add_lty => addv
};
}; # function recover_anormcode_type_info
}; # package recover_anormcode_type_info
end; # stipulate