## polyequal.pkg
# Compiled by:
# src/lib/compiler/core.sublib### "Those whose work and pleasures are one
### are fortune's favorite children."
###
### -- Sir Winston Churchill
stipulate
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 syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkgherein
api Polyequal {
To_Tc_Lt = ( tdt::Typoid -> hut::Uniqtype,
tdt::Typoid -> hut::Uniqtypoid
);
# Constructing generic equality functions; the current version will
# use runtime polyequal function to deal with abstract types. (ZHONG)
equal: ( { get_string_eq: Void -> lcf::Lambdacode_Expression,
get_integer_eq: Void -> lcf::Lambdacode_Expression,
get_poly_eq: Void -> lcf::Lambdacode_Expression
},
syx::Symbolmapstack
)
->
(tdt::Typoid, tdt::Typoid, To_Tc_Lt)
->
lcf::Lambdacode_Expression;
debugging: Ref( Bool );
};
end;
stipulate
package mtt = more_type_types; # more_type_types is from src/lib/compiler/front/typer/types/more-type-types.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 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.pkg package lcf = lambdacode_form; # lambdacode_form is from src/lib/compiler/back/top/lambdacode/lambdacode-form.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.pkg package tyj = type_junk; # type_junk is from src/lib/compiler/front/typer-stuff/types/type-junk.pkg package ut = unparse_type; # unparse_type is from src/lib/compiler/front/typer/print/unparse-type.pkg package vh = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkgherein
package polyequal
: (weak) Polyequal # Polyequal is from src/lib/compiler/back/top/translate/polyequal.pkg {
debugging = REF FALSE;
fun bug msg = err::impossible("Equal: " + msg);
say = global_controls::print::say;
To_Tc_Lt = ( tdt::Typoid -> hut::Uniqtype,
tdt::Typoid -> hut::Uniqtypoid
);
my --> = mtt::(-->);
infix my --> ;
# MAJOR CLEANUP REQUIRED ! The function make_var is currently directly taken
# from the highcode_codetemp module; I think it should be taken from the
# "comp_info". Similarly, should we replace all make_lambda_variable in the backend
# with the make_var in "comp_info" ? (ZHONG) XXX BUGGO FIXME
#
make_var
=
tmp::issue_highcode_codetemp;
# Translating the type field in VALCON
# into Uniqtypoid; constant valcons
# will take void_uniqtypoid as the argument
#
fun to_valcon_lty (to_type, to_lambda_type) type
=
case type
#
tdt::TYPESCHEME_TYPOID { typescheme_eqflags=>an_api, typescheme=>tdt::TYPESCHEME { arity, body }}
=>
if (mtt::is_arrow_type body)
to_lambda_type type;
else to_lambda_type (tdt::TYPESCHEME_TYPOID { typescheme_eqflags => an_api,
typescheme => tdt::TYPESCHEME { arity, body => mtt::(-->) (mtt::void_typoid, body) }
}
);
fi;
_ => if (mtt::is_arrow_type type) to_lambda_type type;
else to_lambda_type (mtt::(-->)(mtt::void_typoid, type));
fi;
esac;
# Is tyj::sumtype_to_typoid necessary, or could a variant of transTyLty that
# just takes Type and domain be used in transDcon???
#
fun trans_valcon (type, { name, form, domain }, to_tc_lt)
=
(name, form, to_valcon_lty to_tc_lt (tyj::sumtype_to_typoid (type, domain)));
my (true_valcon', false_valcon')
=
( h mtt::true_valcon,
h mtt::false_valcon
)
where
lt = hcf::make_lambdacode_arrow_uniqtypoid (hcf::void_uniqtypoid, hcf::bool_uniqtypoid); # Highcode type "Void -> Bool".
#
fun h (tdt::VALCON { name, form, ... } )
=
(name, form, lt);
end;
#
fun cond (a, b, c)
=
lcf::SWITCH
(
a,
mtt::bool_signature,
[ (lcf::VAL_CASETAG (true_valcon', [], make_var()), b),
(lcf::VAL_CASETAG (false_valcon', [], make_var()), c)
],
NULL
);
my (true_lexp, false_lexp)
=
{ unit_lexp = lcf::RECORD [];
( lcf::CONSTRUCTOR (true_valcon', [], unit_lexp),
lcf::CONSTRUCTOR (false_valcon', [], unit_lexp)
);
};
#
fun arg_type (domain, [])
=>
domain;
arg_type (domain, args)
=>
tyj::apply_typescheme (tdt::TYPESCHEME { arity=>length args, body=>domain }, args);
end;
#
fun reduce_typoid type
=
case (tyj::head_reduce_typoid type)
#
tdt::TYPESCHEME_TYPOID { typescheme => tdt::TYPESCHEME { body, ... }, ... } => reduce_typoid body;
#
other => other;
esac;
# Given a list of data constructors; return its api and a list
# of value-carrying data constructors
#
fun get_csig dcons
=
{ fun is_const (vh::CONSTANT _) => TRUE;
is_const (vh::LISTNIL) => TRUE;
is_const _ => FALSE;
end;
h (dcons, 0, 0, [])
where
fun h ([], c, v, rds)
=>
(vh::CONSTRUCTOR_SIGNATURE (v, c), reverse rds);
h ((dc as { form=>a, domain, name } ) ! r, c, v, rds)
=>
if (is_const a) h (r, c+1, v, rds);
else h (r, c, v+1, dc ! rds);
fi;
end;
end;
};
#
fun expand_rec (family as { members: Vector( tdt::Sumtype_Member ), ... }, stamps, free_types)
=
f
where
fun g (tdt::RECURSIVE_TYPE i)
=>
{ (vector::get (members, i))
->
{ name_symbol, valcons, arity, is_eqtype, is_lazy, an_api };
s = vector::get (stamps, i);
tdt::SUM_TYPE
{
stamp => s,
arity,
is_eqtype => REF( tdt::e::YES ),
namepath => inverse_path::INVERSE_PATH [ name_symbol ],
stub => NULL,
kind => tdt::SUMTYPE
{
index => i,
family,
root => NULL,
stamps,
free_types
}
};
};
g (tdt::FREE_TYPE i)
=>
list::nth (free_types, i);
g x => x;
end;
#
fun f (tdt::TYPCON_TYPOID (type, tyl))
=>
tdt::TYPCON_TYPOID (g type, map f tyl);
f (x as tdt::TYPESCHEME_ARG _)
=>
x;
f _ => bug "unexpected type in expandREC";
end;
end;
exception POLY;
#
fun equiv_typoid (typoid, typoid')
=
eq ( tyj::drop_resolved_typevars typoid,
tyj::drop_resolved_typevars typoid'
)
where
fun eq (typoid as tdt::TYPCON_TYPOID (type, args), typoid' as tdt::TYPCON_TYPOID (type', args'))
=>
( if (tyj::types_are_equal (type, type'))
#
paired_lists::all equiv_typoid (args, args');
else
equiv_typoid (tyj::reduce_typoid typoid, typoid')
except
bad_type_reduction
=
( equiv_typoid (typoid, tyj::reduce_typoid typoid')
except
bad_type_reduction = FALSE
);
fi
);
eq(tdt::TYPEVAR_REF _, _) => raise exception POLY;
eq(_, tdt::TYPEVAR_REF _) => raise exception POLY;
eq(tdt::TYPESCHEME_TYPOID _, _) => raise exception POLY;
eq(_, tdt::TYPESCHEME_TYPOID _) => raise exception POLY;
eq _ => FALSE;
end;
end;
/****************************************************************************
* Commonly-used Lambda Types *
****************************************************************************/
boolty = hcf::bool_uniqtypoid;
fun eq_lty lt = hcf::make_lambdacode_arrow_uniqtypoid (hcf::make_tuple_uniqtypoid [lt, lt], boolty);
inteqty = eq_lty hcf::int_uniqtypoid;
int1eqty = eq_lty hcf::int1_uniqtypoid;
booleqty = eq_lty hcf::bool_uniqtypoid;
realeqty = eq_lty hcf::float64_uniqtypoid;
exception NOT_FOUND;
/****************************************************************************
* equal --- the equality function generator *
****************************************************************************/
fun equal ( { get_string_eq, get_integer_eq, get_poly_eq }, symbolmapstack)
(poly_eq_type: tdt::Typoid, concrete_type: tdt::Typoid, to_tc_lc as (to_type, to_lambda_type))
=
{ my cache: Ref( List ((tdt::Typoid, lcf::Lambdacode_Expression, Ref( lcf::Lambdacode_Expression )) ) )
= REF NIL;
#
fun enter typoid
=
{ v = lcf::VAR (make_var());
r = REF v;
if *debugging
#
pp::with_standard_prettyprinter
#
(err::default_plaint_sink()) []
#
(\\ pp: pp::Prettyprinter
=
{ pp.lit "enter: ";
ut::reset_unparse_type();
ut::unparse_typoid symbolmapstack pp typoid;
}
);
fi;
cache := (typoid, v, r) ! *cache;
(v, r);
};
#
fun find typoid
=
{ fun f ((t, v, e) ! r)
=>
if (equiv_typoid (typoid, t)) v;
else f r;
fi;
f [] => { if *debugging
say "equal.pkg-find-notfound\n";
fi;
raise exception NOT_FOUND;
};
end;
if *debugging
#
pp::with_standard_prettyprinter
#
(err::default_plaint_sink()) []
#
(\\ pp: pp::Prettyprinter
=
{ pp.lit "find: ";
ut::reset_unparse_type ();
ut::unparse_typoid symbolmapstack pp typoid;
}
);
fi;
f *cache;
};
#
fun eq_type type = eq_lty (to_lambda_type type);
fun ptr_eq (p, type) = lcf::BASEOP (p, eq_type type, []);
fun prim (p, lt) = lcf::BASEOP (p, lt, []);
#
fun atomeq (type, typoid)
=
if (tyj::type_equality (type, mtt::int_type )) prim (hbo::ieql, inteqty);
elif (tyj::type_equality (type, mtt::int1_type )) prim (hbo::ieql, int1eqty);
elif (tyj::type_equality (type, mtt::unt_type )) prim (hbo::ieql, inteqty);
elif (tyj::type_equality (type, mtt::unt8_type )) prim (hbo::ieql, inteqty);
elif (tyj::type_equality (type, mtt::char_type )) prim (hbo::ieql, inteqty);
elif (tyj::type_equality (type, mtt::unt1_type )) prim (hbo::ieql, int1eqty);
elif (tyj::type_equality (type, mtt::bool_type )) prim (hbo::ieql, booleqty);
elif (tyj::type_equality (type, mtt::float64_type )) prim (hbo::feqld, realeqty);
elif (tyj::type_equality (type, mtt::string_type )) get_string_eq();
elif (tyj::type_equality (type, mtt::multiword_int_type)) get_integer_eq();
elif (tyj::type_equality (type, mtt::ref_type )) ptr_eq (hbo::POINTER_EQL, typoid);
/**********************
* For arrays under the new rw_vector representation, we need to compare
* the data pointers for equality. polyequal does this comparison
* correctly, so use it as the fallback. (John H Reppy)
*
else if tyj::type_equality (type, mtt::array_type) then ptrEq (hbo::POINTER_EQL, typoid)
else if tyj::type_equality (type, mtt::word8array_type) then ptrEq (hbo::POINTER_EQL, typoid)
else if tyj::type_equality (type, mtt::real64array_type) then ptrEq (hbo::POINTER_EQL, typoid)
**********************/
else raise exception POLY;
fi;
#
fun test (typoid, 0)
=>
raise exception POLY;
test (typoid, depth)
=>
{ if *debugging
#
pp::with_standard_prettyprinter
#
(err::default_plaint_sink ()) []
#
(\\ pp: pp::Prettyprinter
=
{ pp.lit "test: ";
ut::reset_unparse_type ();
ut::unparse_typoid symbolmapstack pp typoid;
}
);
fi;
case typoid
#
tdt::TYPEVAR_REF { id, ref_typevar => REF (tdt::RESOLVED_TYPEVAR t) }
=>
test (t, depth);
tdt::TYPCON_TYPOID (tdt::NAMED_TYPE _, _)
=>
test (tyj::reduce_typoid typoid, depth);
tdt::TYPCON_TYPOID (tdt::RECORD_TYPE _, tyl)
=>
find typoid
except
notfound
=
{ v = make_var();
x = make_var();
y = make_var();
my (eqv, patch) = enter typoid;
#
fun loop (n, [typoid])
=>
lcf::APPLY (test (typoid, depth), lcf::RECORD [lcf::GET_FIELD (n, lcf::VAR x),
lcf::GET_FIELD (n, lcf::VAR y)]);
loop (n, typoid ! r)
=>
cond (loop (n,[typoid]), loop (n+1, r), false_lexp);
loop(_, NIL)
=>
true_lexp;
end;
lt = to_lambda_type typoid;
patch := lcf::FN (v, hcf::make_tuple_uniqtypoid [lt, lt],
lcf::LET (x, lcf::GET_FIELD (0, lcf::VAR v),
lcf::LET (y, lcf::GET_FIELD (1, lcf::VAR v),
loop (0, tyl))));
eqv;
};
tdt::TYPCON_TYPOID (type as tdt::SUM_TYPE { kind, is_eqtype, stamp, arity, namepath, ... }, tyl)
=>
case (*is_eqtype, kind)
#
(tdt::e::YES, tdt::BASE _)
=>
atomeq (type, typoid);
(tdt::e::YES, tdt::ABSTRACT type')
=>
test (tdt::TYPCON_TYPOID (type', tyl), depth);
# Assume that an equality enum has been converted
# to an abstract type in an abstype declaration:
#
( _,
tdt::SUMTYPE { index,
family as { members, ... },
free_types,
stamps,
...
}
)
=>
{ my { valcons => dcons0, ... }
=
vector::get (members, index);
#
fun expand_recdcon { domain=>THE x, form, name }
=>
{ domain => THE (expand_rec (family, stamps, free_types) x),
form,
name
};
expand_recdcon z
=>
z;
end;
case (map expand_recdcon dcons0)
#
[ { form => ref_rep, ... } ]
=>
atomeq (type, typoid);
dcons
=>
find typoid
except
notfound
=>
{ v = make_var ();
x = make_var ();
y = make_var ();
my (eqv, patch)
=
enter typoid;
#
fun inside ( { name, form, domain }, ww, uu)
=
case domain
#
NULL => true_lexp;
#
THE dom
=>
case (reduce_typoid dom)
#
tdt::TYPCON_TYPOID (tdt::RECORD_TYPE [], _)
=>
true_lexp;
_ =>
{ argt = arg_type (dom, tyl);
#
lcf::APPLY (test (argt, depth - 1),
lcf::RECORD [ lcf::VAR ww, lcf::VAR uu ]
);
};
esac;
esac;
lt = to_lambda_type typoid;
argty = hcf::make_tuple_uniqtypoid [lt, lt];
pty = hcf::make_lambdacode_arrow_uniqtypoid (argty, boolty);
body =
case dcons
#
[] => bug "empty data types";
# [valcon] => inside valcon;
_ =>
{ (get_csig dcons)
->
(an_api, ndcons);
#
fun concase valcon
=
{ tcs = map to_type tyl;
#
ww = make_var ();
uu = make_var ();
dc = trans_valcon (type, valcon, to_tc_lc);
dconx = lcf::VAL_CASETAG (dc, tcs, ww);
dcony = lcf::VAL_CASETAG (dc, tcs, uu);
( dconx,
#
lcf::SWITCH ( lcf::VAR y,
an_api,
[ ( dcony,
inside (valcon, ww, uu)
)
],
THE (false_lexp)
)
);
};
case an_api
#
vh::CONSTRUCTOR_SIGNATURE (0, _)
=>
false_lexp;
vh::CONSTRUCTOR_SIGNATURE (_, 0)
=>
lcf::SWITCH ( lcf::VAR x,
an_api,
map concase ndcons,
NULL
);
_ =>
lcf::SWITCH ( lcf::VAR x,
an_api,
map concase ndcons,
THE false_lexp
);
esac;
};
esac;
root = lcf::APPLY ( lcf::BASEOP (hbo::POINTER_EQL, pty, []),
lcf::RECORD [lcf::VAR x, lcf::VAR y]
);
nbody = cond (root, true_lexp, body);
patch := lcf::FN (v, argty,
lcf::LET (x, lcf::GET_FIELD (0, lcf::VAR v),
lcf::LET (y, lcf::GET_FIELD (1, lcf::VAR v), nbody)));
eqv;
};
end;
esac;
};
_ => raise exception POLY;
esac;
_ => raise exception POLY;
esac;
};
end; # fun test
body = test (concrete_type, 10);
fl = *cache;
case fl
#
[] => body;
_ =>
{ fun g ((typoid, lcf::VAR v, e), (vs, ts, es))
=>
( v ! vs,
(eq_type typoid) ! ts,
*e ! es
);
g _ => bug "unexpected equality cache value";
end;
(fold_backward g ([], [], []) fl)
->
(vs, ts, es);
lcf::MUTUALLY_RECURSIVE_FNS (vs, ts, es, body);
};
esac;
} # fun equal
except
POLY =
lcf::GENOP
( { default => get_poly_eq (),
table => [ ( [ hcf::string_uniqtype ], # Might want to include integer in this table,
get_string_eq () # although we need an integer_uniqtype for that...
)
]
},
hbo::POLY_EQL,
to_lambda_type poly_eq_type,
[ to_type concrete_type ]
);
}; # package equal
end; # toplevel stipulate