Module: DFMC-Typist
Author: Steve Rowley
Synopsis: Inference of the types in the typist.
Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
All rights reserved.
License: Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
///
/// Minimal static type inference: recurse until you ground out on data.
///
///
/// A few tools.
///
// *** Dependency: on the return, or last instruction?
define function type-estimate-body(body-first :: <computation>,
cache :: <type-cache>,
#key before) => (te :: <type-estimate>)
// Type the computations in a body (i.e., sequence of DFM instructions).
// Goes up to the next ender, or before: if supplied. The purpose of the
// latter is to find an <end-exit-block>, which is not an <end>.
walk-computations(rcurry(type-estimate-in-cache, cache), body-first, before);
type-estimate-in-cache(case
before => previous-computation(before); // <end-exit-block>
otherwise => final-computation(body-first); // has an <end>
end,
cache)
end;
///
/// Machine to figure out the return value type(s) from a function type.
///
define generic function-valtype (fntype, cache :: <type-cache>)
// Figure out values type for this function type.
=> (valtype :: <type-estimate>);
define method function-valtype (fntype :: <type-estimate-limited-function>,
cache :: <type-cache>)
=> (valtype :: <type-estimate>);
// Easy to extract values type from a limited function
type-estimate-values(fntype)
end;
define method function-valtype (fntype :: <type-estimate-limited-instance>,
cache :: <type-cache>)
=> (valtype :: <type-estimate>);
// Coerce singleton to limited function & try again.
let fn = type-estimate-singleton(fntype);
if (instance?(fn, <&callable-object>))
// It's guaranteed to be some kind of function
let (sig, cl, body) =
select (fn by instance?)
<&lambda> => values(^function-signature(fn),
&object-class(fn),
// body(fn)
#f);
<&code> => values(^function-signature(function(fn)),
&object-class(fn),
// body(function(fn))
#f);
<&function> => values(^function-signature(fn),
&object-class(fn),
#f);
<&primitive> => values(primitive-signature(fn),
&object-class(fn),
#f);
end;
function-valtype(type-estimate-function-from-signature(sig, cl, cache,
body: body),
cache)
else
// It's not a callable thing; you'll never return.
make(<type-estimate-bottom>)
end
end;
define method function-valtype (fntype :: <type-estimate-union>,
cache :: <type-cache>)
=> (valtype :: <type-estimate>);
// Unions of function objects get processed recursively.
make(<type-estimate-union>,
unionees: map(rcurry(function-valtype, cache),
type-estimate-unionees(fntype)))
end;
define method function-valtype (fntype :: <object>, cache :: <type-cache>)
=> (valtype :: <type-estimate>);
// Anything else just punts to the general case. E.g., class <function>
// goes here. We could try to check for disjointness from <callable-object>,
// but that happense in the rest of the compiler
// (see optimization/dispatch.dylan).
make(<type-estimate-values>)
end;
///
/// Manipulating values and unions of values.
///
define generic single-value?(vtype) => (single? :: <boolean>);
define method single-value?(vtype :: <type-estimate-values>)
=> (single? :: <boolean>)
// Is this really only 1 return value?
size(type-estimate-fixed-values(vtype)) = 1 &
type-estimate-rest-values(vtype) == #f
end;
define method single-value?(vtype :: <type-estimate-union>)
=> (single? :: <boolean>)
// Is this a union of single-value types?
every?(single-value?, type-estimate-unionees(vtype))
end;
define generic first-value(vtype) => (first :: <type-estimate>);
define method first-value(vtype :: <type-estimate-values>)
=> (val :: <type-estimate>)
// First value of a multiple value type.
case
size(type-estimate-fixed-values(vtype)) ~== 0
=> type-estimate-fixed-values(vtype)[0]; // First fixed value
type-estimate-rest-values(vtype)
=> type-estimate-rest-values(vtype); // No fixed value; use rest
otherwise
=> make(<type-estimate-limited-instance>, singleton: &false)
end
end;
define method first-value(vtype :: <type-estimate-union>)
=> (val :: <type-estimate>)
// Union of first values of components.
make(<type-estimate-union>,
unionees: map-as(<unionee-sequence>,
first-value,
type-estimate-unionees(vtype)))
end;
///
/// How to type-estimate a call.
///
define inline function type-estimate-call-stupidly-from-fn
(call :: <call>, fn, cache :: <type-cache>)
=> (te :: false-or(<type-estimate>))
// Type of function-object.
let fntype = type-estimate-in-cache(fn, cache);
function-valtype(fntype, cache); // Values type or union thereof.
end function;
define method type-estimate-call-from-site(call :: <function-call>,
cache :: <type-cache>)
=> (te :: false-or(<type-estimate>))
let (constant?, fn) = constant-value?(call.function);
if (instance?(fn, <&generic-function>))
select (fn)
dylan-value(#"make") =>
let (c?, arg-type)
= constant-value?(first(arguments(call)));
let type
= if (c? & ^instance?(arg-type, dylan-value(#"<type>")))
arg-type
else
dylan-value(#"<object>")
end if;
make(<type-estimate-values>,
fixed: vector(as(<type-estimate>, type)));
dylan-value(#"element"), dylan-value(#"element-no-bounds-check") =>
let collection-te = type-estimate(first(arguments(call)));
if (instance?(collection-te, <type-estimate-limited-collection>))
make(<type-estimate-values>,
fixed: vector(as(<type-estimate>, type-estimate-of(collection-te))))
else
type-estimate-call-stupidly-from-fn(call, function(call), cache)
end if;
dylan-value(#"element-setter"), dylan-value(#"element-no-bounds-check-setter") =>
let collection-te = type-estimate(second(arguments(call)));
if (instance?(collection-te, <type-estimate-limited-collection>))
make(<type-estimate-values>,
fixed: vector(as(<type-estimate>, type-estimate-of(collection-te))))
else
type-estimate-call-stupidly-from-fn(call, function(call), cache)
end if;
otherwise =>
type-estimate-call-stupidly-from-fn(call, function(call), cache)
end select;
else
type-estimate-call-stupidly-from-fn(call, function(call), cache)
end if;
end method;
define method ^make-return-class-from-signature
(fn :: <&method>) => (res :: false-or(<&class>))
let sig = ^function-signature(fn);
let rtype = first(^signature-required(sig));
let vtype = first(^signature-values(sig));
let class = select (rtype by instance?)
<&singleton> => ^singleton-object(rtype);
<&subclass> => ^subclass-class(rtype);
otherwise => #f;
end select;
if (class & ~^subtype?(vtype, class))
class
else
vtype
end if
end method;
define method ^make-method? (fn :: <&method>) => (well? :: <boolean>)
let binding = model-variable-binding(fn);
binding & binding == dylan-binding(#"make")
end method;
define method ^make-method? (fn) => (well? :: <boolean>)
#f
end method;
define method ^element-method? (fn :: <&method>) => (well? :: <boolean>)
let binding = model-variable-binding(fn);
binding
& (binding == dylan-binding(#"element")
| binding == dylan-binding(#"element-no-bounds-check"))
end method;
define method ^element-setter-method? (fn :: <&method>) => (well? :: <boolean>)
let binding = model-variable-binding(fn);
binding
& (binding == dylan-binding(#"element-setter")
| binding == dylan-binding(#"element-no-bounds-check-setter"))
end method;
define method type-estimate-call-from-site(call :: <method-call>,
cache :: <type-cache>)
=> (te :: false-or(<type-estimate>))
let (constant?, fn) = constant-value?(call.function);
if (instance?(fn, <&method>))
if (^make-method?(fn))
let sig-class
= ^make-return-class-from-signature(fn);
let (c?, arg-type)
= constant-value?(first(arguments(call)));
let type
= if (c? & ^subtype?(arg-type, sig-class))
arg-type
else
sig-class
end if;
make(<type-estimate-values>,
fixed: vector(as(<type-estimate>, type)))
elseif (^element-method?(fn))
let collection-te = type-estimate(first(arguments(call)));
if (instance?(collection-te, <type-estimate-limited-collection>))
make(<type-estimate-values>,
fixed: vector(as(<type-estimate>, type-estimate-of(collection-te))))
else
next-method()
end if
elseif (^element-setter-method?(fn))
let collection-te = type-estimate(second(arguments(call)));
if (instance?(collection-te, <type-estimate-limited-collection>))
make(<type-estimate-values>,
fixed: vector(as(<type-estimate>, type-estimate-of(collection-te))))
else
next-method()
end if
else
next-method()
end if;
else
next-method()
end if;
end method;
define method type-estimate-call-from-site(call :: <primitive-call>,
cache :: <type-cache>)
=> (te :: false-or(<type-estimate>))
let fn = primitive(call);
block (return)
// special cases
when (fn == dylan-value(#"primitive-object-allocate-filled"))
// type returned is actually contained in second argument
let (c?, wrapper) = constant-value?(second(arguments(call)));
when (c?)
let iclass = ^mm-wrapper-implementation-class(wrapper);
let class = ^iclass-class(iclass);
return(make(<type-estimate-values>,
fixed: vector(as(<type-estimate>, class))))
end when
end when;
type-estimate-call-stupidly-from-fn(call, fn, cache)
end block;
end method;
// *** Dependency: on return value.
define function type-estimate-call-stupidly(call :: <call>, cache :: <type-cache>)
=> (te :: <type-estimate>)
if (temporary(call))
// Just look at the values declaration in the thing being called.
let valtype = type-estimate-call-from-site(call, cache);
if (multiple-values?(temporary(call)))
// Takes multiple values.
valtype
else
first-value(valtype)
end
else
// call value not used -- no one cares what the result type is
make(<type-estimate-values>)
end
end;
///
/// Coercing a <&signature> to a <type-estimate-limited-function>.
///
/// TODO: GET THIS TO WORK WITH LIMITED VECTORS
define constant <&types> = <simple-object-vector>;
// = limited(<vector>, of: <&type>);
define constant <type-estimates> = <simple-object-vector>;
// = limited(<vector>, of: <type-estimate>);
define function type-estimate-function-from-signature
(sig :: <&signature>, class :: <&class>, cache :: <type-cache>, #key body)
=> (te :: <type-estimate>)
// Construct a limited function type-estimate based on the model signature
local method lift (x :: <&type>) => (te :: <type-estimate>)
as(<type-estimate>, x)
end,
method lift-sequence
(x :: <&types>, number-required :: <integer>)
=> (te* :: <type-estimates>)
let requireds :: <simple-object-vector>
= make(<type-estimates>, size: number-required);
for (e in x, i :: <integer> from 0 below number-required)
requireds[i] := lift(e)
end for;
requireds
end;
make(<type-estimate-limited-function>,
class: class,
requireds: lift-sequence(as(<&types>, ^signature-required(sig)),
^signature-number-required(sig)),
rest?: ^signature-rest?(sig),
// ^signature-keys? = #t iff accepts keys
// ^signature-keys is nonempty iff there are local keys.
// (remember #key #all-keys takes keys but none locally)
// *** Redundancy in <signature> among keys, keys?, and all-keys? ?
keys: when (~empty?(^signature-keys(sig)))
let tbl = make(<object-table>);
for (key in ^signature-keys(sig))
// *** NB: key types not recorded in signatures, for
// reasons that are obscure to me!
tbl[key] := as(<type-estimate>, dylan-value(#"<object>"));
end;
tbl
end,
all-keys?: ^signature-all-keys?(sig),
vals: if (body)
// Prefer body to values in signature
type-estimate-body(body, cache)
else
make(<type-estimate-values>,
// Could also do type-estimate-body,
// if function body is available (e.g., <&lambda>).
fixed: lift-sequence(^signature-values(sig),
^signature-number-values(sig)),
rest: when (^signature-rest-value(sig))
lift(^signature-rest-value(sig))
end)
end)
end;
define function type-estimate-datum (obj) => (te :: <type-estimate>)
// Make a singleton out of obj.
make(<type-estimate-limited-instance>, singleton: obj)
end;
define function lift-model-named(name :: <symbol>) => (te :: <type-estimate>)
// Evaluate name in Dylan, lift resulting model type as type-estimate.
as(<type-estimate>, dylan-value(name))
end;
///
/// The type inference rule compiler.
///
///
/// Rule syntax: (nonterminals in UPPER-CASE, {... | ...} for alternatives)
///
/// RULE-FORM ::= define type-inference-rules RULE-GROUP TYPE-RULES end;
/// RULE-GROUP ::= NAME
/// TYPE-RULES ::= TYPE-RULE; ... (ok, actually 0 or more)
//
/// TYPE-RULE ::= LHS CONNECTIVE RHS
///
/// CONNECTIVE ::= == | <- | <-*
///
/// LHS ::= OBJ :: DFM-TYPE
/// OBJ ::= NAME
/// DFM-TYPE ::= NAME
///
/// RHS ::= EXPRESSION | EXPRESSION, RHS
///
/// Rule semantics:
///
/// * On the LHS:
///
/// - OBJ is a symbol, which will go into the arglist of a method. The rest
/// of the type-rule is in its scope. It is the object whose type is
/// being inferred.
///
/// - DFM-TYPE is a type of some kind of object in the DFM, i.e., a subtype
/// of <dfm-ref>.
///
/// - The LHS advertises a way to compute the type of OBJ, given the knowledge
/// that its representation in the DFM is of type DFM-TYPE. E.g.,
///
/// pcall :: <primitive-call> == ...rhs involving pcall...
///
/// purports to tell you how to compute the type of a <primitive-call>
/// computation, to be referred to as pcall in the rhs.
///
/// * The LHS is the trigger of the rule, i.e., the thing to be matched before
/// the rule can fire. If the LHS is OBJ :: DFM-TYPE, then the rule defines
/// a method with signature:
///
/// type-estimate-infer(OBJ :: DFM-TYPE, cache :: <type-cache>).
///
/// * There are two types of connectives between the LHS and RHS:
///
/// - A rule of the form:
///
/// OBJ :: DFM-TYPE == ...rhs...
///
/// defines a "basis rule" which calculates directly the type of OBJ. The
/// RHS should return a <type-estimate> which will be union'd with what's
/// already known in the cache about OBJ.
///
/// To keep the justification semantics straight, the RHS really should be
/// a single expression that just constructes a <type-estimate>, and which
/// does not call type-estimate &c in the process.
///
/// E.g., the type of an <&object> is some class <stype>:
///
/// x :: <&object> == make(<type-estimate-class>, class: &object-class(x))
///
/// - A rule of the form:
///
/// OBJ :: DFM-TYPE <- ...rhs...
///
/// defines an "induction rule" in which the typist recurses. The RHS
/// should be a new DFM object, on which type-estimate-in-cache(_, _)
/// will be called recursively to produce the type of OBJ. Thus OBJ defers
/// to some other object to determine its own type.
///
/// The RHS can be a ,-separated sequence of objects, in which case the
/// type generated is the union of the types of each of them.
///
/// E.g., the type of an <method-reference> is the type of the object
/// to which it refers:
///
/// obj-ref :: <method-reference> <- value(obj-ref);
///
/// The other kind of induction rule uses the connective <-*. In this case,
/// the last RHS object is assumed to be a list. Kind of like apply.
///
/// E.g., the type of a <merge> is the union of the sources:
///
/// merge :: <merge> <-* sources(merge);
///
/// In either case, the RHS can refer to the variable cache, which contains
/// the current state of the mapping from objects to types.
///
// For desperate debugging mode.
// define thread variable *step-depth* :: <integer> = -1;
define thread variable *tracing-infer?* :: <boolean> = #f; // Show type inference
define thread variable *stepping-infer?* :: <boolean> = #f; // Show + single-step
define macro with-infer-stepping
{ with-infer-stepping (?dfm-type:name) ?forms:body end }
// => { with-infer-stepping-internal(?dfm-type, method () ?forms end) }
=> { ?forms }
end;
/*
define function with-infer-stepping-internal(dfm-type, body-fn :: <function>)
=> (te :: <type-estimate>)
// Trace the inference rules, waiting for a character at each rule entry.
if (*stepping-infer?* | *tracing-infer?*)
local method step-indent () => ()
format-out("\n");
for (i from 0 below *step-depth*)
write-element(*standard-output*, '|')
end
end,
method step-infer-in (dfm-type) => ()
step-indent();
format-out("%= :: %=", *current-lhs*, dfm-type);
when (*stepping-infer?*)
read(*standard-input*, 1)
end
end,
method step-infer-out (answer) => ()
step-indent();
format-out("answer: %=", answer)
end;
dynamic-bind (*step-depth* = *step-depth* + 1)
step-infer-in(dfm-type);
let answer = body-fn();
step-infer-out(answer);
answer
end
else
body-fn()
end
end;
*/
define inline function type-union-with-sources
(start-type :: <type-estimate>, sources :: <sequence>, cache :: <type-cache>)
=> (te :: <type-estimate>)
// Start from start-type, and union in types of all the other sources.
// Good for combining <merge> sources, variable assignments, etc.
reduce(method (so-far, next-rhs)
*current-rhs* := add!(*current-rhs*, next-rhs);
type-estimate-union(so-far, type-estimate-in-cache(next-rhs, cache))
end,
start-type,
sources)
end;
define macro type-infer-rhs
// Either execute rhs code (basis rule) or recurse (induction rule).
{ type-infer-rhs(ET, ?rhs:expression) } // Basis rule.
=> { ?rhs }
{ type-infer-rhs(LT, ?rhs:expression) } // Induction rule (1).
=> { let the-rhs = ?rhs;
*current-rhs* := add!(*current-rhs*, the-rhs);
type-estimate-in-cache(the-rhs, ?=cache) }
{ type-infer-rhs(LT, ?rhs1:expression, ?rhs-more:*) } // Induction rule (2).
=> { type-estimate-union(type-infer-rhs(LT, ?rhs1),
type-infer-rhs(LT, ?rhs-more)) }
{ type-infer-rhs(LTS, ?rhs:expression) } // Induction rule (3).
=> { type-union-with-sources(make(<type-estimate-bottom>), ?rhs, ?=cache) }
{ type-infer-rhs(LTS, ?rhs1:expression, ?rhs-more:*) }// Induction rule (4).
=> { type-estimate-union(type-infer-rhs(LT, ?rhs1),
type-infer-rhs(LTS, ?rhs-more)) }
end;
// define type-inference-rules empty-rule-set end; // Empty Test case
define macro type-inference-rules-definer
// Dispatch on form of first rule, generating code; recurse on rest.
{ define type-inference-rules ?rule-group:name end } => { } // No rules
{ define type-inference-rules ?rule-group:name
?lhs:name :: ?dfm-type:name ?op-and-rhs; // First rule
?more-rules:* // More rules
end }
=> { define method type-estimate-infer // Expand first
(?lhs :: ?dfm-type, ?=cache :: <type-cache>) => (te :: <type-estimate>)
dynamic-bind (?=*current-rule* = ?#"rule-group",// Rule currently firing
?=*current-lhs* = ?lhs, // Trigger pattern on lhs
?=*current-rhs* = #()) // Precious bodily fluids
with-infer-stepping (?dfm-type)
let answer = type-infer-rhs(?op-and-rhs); // Compute type
type-estimate-update-cache(?lhs, ?=cache, answer); // Update cache
answer // Return type
end
end
end;
define type-inference-rules ?rule-group // Expand rest
?more-rules
end }
op-and-rhs: // ?#"op" blows up for some obscure reason
{ == ?rhs } => { ET, ?rhs } // Basis rule
{ <-* ?rhs } => { LTS, ?rhs } // Induction rule, last rhs is a sequence
{ <- ?rhs } => { LT, ?rhs } // Induction rule
rhs: // ,-separated expressions Should be able to do: { ??item:expression, ... }
{ } => { }
{ ?item:expression } => { ?item }
{ ?item:expression, ?rhs } => { ?item, ?rhs }
end;
///
/// Type inference rules. Twisted way to do abstract semantic interpretation!
///
define type-inference-rules type-infer-punt
// Rules which punt on roots of DFM heterarchy. Anything else will error.
// <nop>, <if>, some <end>s, <bind>, return no values in
// any reasonable sense, so they have no type.
ignore :: <dfm-ref> == make(<type-estimate-bottom>) // Bottom is punt type
end;
///
/// Type inference for DFM instructions. There should be a rule here to
/// trigger on every type of <computation>, or else use the punt rule above.
///
define type-inference-rules type-infer-references
// Rules about reference-like instructions.
var-ref :: <variable-reference> <- referenced-binding(var-ref); // Defer to var
int-ref :: <interactor-binding-reference> <- referenced-binding(int-ref); // Defer to var
clo-ref :: <make-closure> == if (computation-signature-value(clo-ref))
// *** ? use signature?
lift-model-named(#"<method>")
else
let m = computation-closure-method(clo-ref);
*current-rhs* := add!(*current-rhs*, m);
type-estimate-in-cache(m, cache);
end;
end;
define type-inference-rules type-infer-assigns
// Rules about assignment-like instructions.
assign :: <assignment> <- computation-value(assign); // Defer to RHS
update :: <conditional-update!> == lift-model-named(#"<boolean>");
txfer :: <temporary-transfer-computation>
<- computation-value(txfer); // Defer to value
// <definition> and <set!> are both <assignment>s.
// <multiple-value-spill> & <multiple-value-unspill> are txfers.
end;
define type-inference-rules type-infer-merges
// Rules about <merge> & <if> instructions.
// <if> is pure control, so it gets bottom via the punt rule.
// "It's the <merge>, stupid." (With apologies to James Carville.)
// Unary merges all do some sort of inference, so they have heir own rules.
merge :: <binary-merge> <- merge-left-value(merge), merge-right-value(merge)
end;
define type-inference-rules type-infer-calls
// Rules about the various kinds of call instructions.
// Type of call is return-type of callee, _if_ it returns. Can't infer arg
// types before call, since it might signal a run-time <type-error>. _Can_
// infer post-call arg types, though, when we do flow-dependent types.
// The real version of this will use function templates.
// *** <primitive-indirect-call>
call :: <c-variable-pointer-call> == lift-model-named(#"<raw-pointer>");
call :: <call> == type-estimate-call-stupidly(call, cache); // ***
call :: <stack-vector> == lift-model-named(#"<simple-object-vector>");
call :: <loop-call> == make(<type-estimate-bottom>);
call :: <any-slot-value>
== as(<type-estimate>, ^slot-type(computation-slot-descriptor(call)));
call :: <any-repeated-slot-value>
== begin
let instance-te = type-estimate(computation-instance(call));
if (instance?(instance-te, <type-estimate-limited-collection>))
type-estimate-of(instance-te)
else
as(<type-estimate>,
repeated-representation
(^slot-type(computation-slot-descriptor(call))))
end if
end
end;
/* [gts, 2/98, wait until harp backend ready]
define type-inference-rules type-infer-c-ffi
call :: <begin-with-stack-structure> == lift-model-named(#"<raw-pointer>");
end;
*/
define type-inference-rules type-infer-blocks
// Various concrete subclasses of <block>.
// * A <bind-exit>'s <temporary> these days contains only the result of a call
// to the escape continuation; the body result is explicitly merged after
// the <end-exit-block>, so it'll get typed on demand. Used to type the
// body here, but there were problems with type-estimate-body using the
// <end-exit-block> as a guard -- couldn't take previous-computation of it.
// * An <unwind-protect>'s <temporary> is there, but ununsed. Use a
// side-effect to fill the cache with the body & cleanups.
b-x :: <bind-exit> <-* exits(entry-state(b-x)); // *** Escaped?
u-p :: <unwind-protect> == type-estimate-body(body(u-p), cache); // ***
end;
define type-inference-rules type-infer-ends
// Various kinds of terminating computations, and related things.
// NB: the method on <end-block> overrides the one on <end> since the <e*b>s
// are built on (<end-block>, <end>) in that order.
ndr :: <end> <- computation-value(ndr); // <return>, <exit>
ebl :: <end-block> == make(<type-estimate-bottom>); // <eeb>, <epb>, <ecb>
ebl :: <end-loop> == make(<type-estimate-bottom>);
ext :: <exit> ==
begin // *** Dependency!
let value-type = type-estimate-in-cache(computation-value(ext), cache);
if (instance?(value-type, <type-estimate-limited-collection>))
make(<type-estimate-values>, rest: type-estimate-of(value-type))
else
make(<type-estimate-values>) // values(#rest <object>).
end
end;
end;
///
/// Guiding principles re <bottom> and multiple values:
///
/// * values(#rest <bottom>), or "bottoms all the way down," is the maximally
/// undefined return value. No matter which value you try to look at, you get
/// <bottom>. Even the ones you don't look at are <bottom>.
///
/// * values(...anything..., <bottom>, ...anything...) normalizes to
/// values(#rest <bottom>).
///
/// * Extracting a value from values(#rest <bottom>) always gives <bottom>, not
/// <bottom> union singleton(#f), since if you never return, you never default
/// the return value.
///
/// * Adjusting a values(#rest <bottom>) stays at values(#rest <bottom>), so
/// no matter what value you later try to extract, you get <bottom>.
///
define function type-estimate-values-element-subtype?
(values-te :: <type-estimate>, index :: <integer>, te :: <type-estimate>)
=> (subtype? :: <boolean>)
// Is the indexth value of values-te a subtype of te? Slightly complex
// because values-te could be a union of values type-estimates.
local method single-value-subtype? (values-te :: <type-estimate-values>)
=> (indexth-te-subtype? :: <boolean>)
let fixed-te* = type-estimate-fixed-values(values-te);
let rest-te = type-estimate-rest-values(values-te);
let single-te =
if (index < size(fixed-te*))
// The value extraction is guaranteed to succeed with type:
fixed-te*[index]
elseif (~rest-te)
// No rest type, so must default to #f.
make(<type-estimate-limited-instance>, singleton: &false)
elseif (instance?(rest-te, <type-estimate-bottom>))
// values(#rest <bottom>), can't default #f because never return
make(<type-estimate-bottom>)
else
// TODO: Where does value padding happen? If in this
// instruction, the inferred type should be the rest type
// (if present) union singleton(#f). That's what I've done
// here to be conservative.
// The value extraction may succeed, or be defaulted,
// resulting in type:
type-estimate-union(rest-te,
make(<type-estimate-limited-instance>,
singleton: &false))
end;
type-estimate-subtype?(single-te, te)
end;
select (values-te by instance?)
<type-estimate-bottom> => #t; // *** Not strictly <boolean>.
<type-estimate-values> => single-value-subtype?(values-te);
<type-estimate-union> => every?(single-value-subtype?,
type-estimate-unionees(values-te));
end
end;
define function type-estimate-values-rest-subtype?
(values-te :: <type-estimate>, index :: <integer>, te :: <type-estimate>)
=> (subtype? :: <boolean>)
// Is every value of values-te after index a subtype of te? Slightly complex
// because values-te could be a union of values type-estimates.
local method single-rest-subtype? (values-te :: <type-estimate-values>)
let fixed-te* = type-estimate-fixed-values(values-te);
let rest-te = type-estimate-rest-values(values-te);
(~rest-te | type-estimate-subtype?(rest-te, te)) &
// every type between index and size must be a subtype
block (exit)
for (i from index below size(fixed-te*))
unless (type-estimate-subtype?(fixed-te*[i], te))
exit(#f)
end
end;
#t
end
end;
select (values-te by instance?)
<type-estimate-bottom> => #t;
<type-estimate-values> => single-rest-subtype?(values-te);
<type-estimate-union> => every?(single-rest-subtype?,
type-estimate-unionees(values-te));
end
end;
/* Save this for use in <extract-rest-value> type inference below.
define method type-estimate-rest-value (te :: <type-estimate-values>,
index :: <integer>)
=> (rest-value-te :: false-or(<type-estimate>))
let fixed-te* = type-estimate-fixed-values(te);
let rest-te = type-estimate-rest-values(te);
if (index < size(fixed-te*))
// The value extraction is guaranteed to succeed with type:
// TODO? This does too much consing. I assume it almost never
// happens, so it shouldn't matter.
let fixed-type-estimates :: <type-variables>
= copy-sequence(fixed-te*, start: index);
make(<type-estimate-union>,
unionees: if (rest-te)
add!(rest-te, fixed-type-estimates)
else
fixed-type-estimates
end)
else
rest-te
end
end;
define method type-estimate-rest-value (te :: <type-estimate-union>,
index :: <integer>)
=> (rest-value-te :: false-or(<type-estimate>))
// this assumes that all unionees are <type-estimate-values>
// probably it's an error if that's not true
// this conses too much, but #rest values aren't used much
let unionees :: <unionee-sequence>
= map(rcurry(type-estimate-rest-value, index),
type-estimate-unionees(te));
if (every?(\~, unionees))
#f
else
make(<type-estimate-union>,
unionees: remove(unionees, #f))
end
end;
*/
define method type-estimate-of (te :: <type-estimate-class>)
let class = type-estimate-class(te);
if (^subtype?(class, dylan-value(#"<collection>")))
make(<type-estimate-class>, class: dylan-value(#"<object>"))
else
error("Trying to take type-estimate-of on a non-collection %=", te);
end if
end method;
// *** Dependencies!
define type-inference-rules type-infer-multiple-values
val :: <values> == make(<type-estimate-values>,
fixed: map(rcurry(type-estimate-in-cache, cache),
fixed-values(val)),
rest: when (rest-value(val))
type-estimate-of
(type-estimate-in-cache(rest-value(val), cache))
end);
xsv :: <extract-single-value> ==
begin
let values-te = type-estimate-in-cache(computation-value(xsv), cache);
let index = index(xsv);
local method estimate-single-value (te :: <type-estimate-values>)
=> (indexth-te :: <type-estimate>)
// *** Share with type-estimate-values-element-subtype?, above.
let fixed-te* = type-estimate-fixed-values(te);
let rest-te = type-estimate-rest-values(te);
if (index < size(fixed-te*))
// The value extraction is guaranteed to succeed with type:
fixed-te*[index];
elseif (~rest-te)
// No #rest value, so default to #f
make(<type-estimate-limited-instance>, singleton: &false)
elseif (instance?(rest-te, <type-estimate-bottom>))
// Something like values(#rest <bottom>), so result is bottom
// because it can't be defaulted to #f.
make(<type-estimate-bottom>)
else
// TODO: Where does value padding happen? If in this
// instruction, the inferred type should be the rest type
// (if present) union singleton(#f). That's what I've done
// here to be conservative.
// The value extraction may succeed, or be defaulted,
// resulting in type:
type-estimate-union(rest-te,
make(<type-estimate-limited-instance>,
singleton: &false))
end
end;
select (values-te by instance?)
<type-estimate-bottom> => values-te;
<type-estimate-values> => estimate-single-value(values-te);
<type-estimate-union> => make(<type-estimate-union>,
unionees: map(estimate-single-value,
type-estimate-unionees(
values-te)));
end
end;
xrv :: <extract-rest-value>
== // We're accessing a rest vector, but there's no point in
// doing anything flash until limited collections are really
// flying in the typist, hence the following.
// TODO: Make this a limited vector of type when possible.
lift-model-named(#"<simple-object-vector>");
// <multiple-value-spill> & <multiple-value-unspill> are txfers.
end;
define type-inference-rules type-infer-adjust-multiple-values
adj :: <adjust-multiple-values> ==
begin
let values-te = type-estimate-in-cache(computation-value(adj), cache);
let n = number-of-required-values(adj);
local method adjust-mv (te :: <type-estimate-values>)
// Ensure there are EXACTLY n values.
let fixed-te* = type-estimate-fixed-values(te);
let rest-te = type-estimate-rest-values(te);
let values-fixed-size = size(fixed-te*);
if (values-fixed-size = n)
// Fixed values supply exactly as many as we want
if (rest-te)
// Lose the rest value
make(<type-estimate-values>, fixed: fixed-te*, rest: #f)
else
// No rest value to lose, so no change.
te
end
elseif (n < values-fixed-size)
// Fixed values supply more than needed; lose rest & some fixed.
make(<type-estimate-values>,
fixed: copy-sequence(fixed-te*, end: n),
rest: #f)
else
// n > values-fixed-size, so fixed values insufficient for our
// needs. Fill with rest value or singleton(#f).
let fill-te =
if (~rest-te)
// No rest arg, so fill is singleton(#f).
make(<type-estimate-limited-instance>, singleton: &false)
elseif (instance?(rest-te, <type-estimate-bottom>))
// values(#rest <bottom>), so stay bottom!
make(<type-estimate-bottom>)
else
// Use rest value union singleton(#f).
type-estimate-union(rest-te,
make(<type-estimate-limited-instance>,
singleton: &false))
end;
make(<type-estimate-values>,
fixed: concatenate(fixed-te*,
make(<list>,
size: n - values-fixed-size,
fill: fill-te)),
rest: #f)
end
end;
select (values-te by instance?)
<type-estimate-bottom> => values-te;
<type-estimate-values> => adjust-mv(values-te);
<type-estimate-union> => make(<type-estimate-union>,
unionees: map(adjust-mv,
type-estimate-unionees(
values-te)));
end
end;
adj :: <adjust-multiple-values-rest> ==
begin
let values-te = type-estimate-in-cache(computation-value(adj), cache);
let n = number-of-required-values(adj);
local method adjust-mv (te :: <type-estimate-values>)
// Ensure there are at LEAST n fixed values.
let fixed-te* = type-estimate-fixed-values(te);
let rest-te = type-estimate-rest-values(te);
let values-fixed-size = size(fixed-te*);
if (values-fixed-size >= n)
// Fixed values will suffice for our needs.
te
else
// Need to pad out fixed values with rest or #f.
let fill-te =
if (~rest-te)
// No rest type, so pad with #f
make(<type-estimate-limited-instance>, singleton: &false)
elseif (instance?(rest-te, <type-estimate-bottom>))
// Sucked into the values(#rest <bottom>) black hole.
make(<type-estimate-bottom>)
else
// Otherwise use rest type union singleton(#f).
type-estimate-union(rest-te,
make(<type-estimate-limited-instance>,
singleton: &false))
end;
make(<type-estimate-values>,
fixed: concatenate(fixed-te*,
make(<list>,
size: n - values-fixed-size,
fill: fill-te)),
rest: rest-te)
end
end;
select (values-te by instance?)
<type-estimate-bottom> => values-te;
<type-estimate-values> => adjust-mv(values-te);
<type-estimate-union> => make(<type-estimate-union>,
unionees: map(adjust-mv,
type-estimate-unionees(
values-te)));
end
end;
end;
define generic constant-value? (ref)
=> (constant? :: <boolean>, value :: <object>);
define method constant-value?
(ref :: <object-reference>)
=> (constant-value? :: <boolean>, constant-value)
// Extract the constant from an <object-reference>.
values(#t, reference-value(ref))
end method;
define method constant-value?
(ref :: <defined-constant-reference>)
=> (constant-value? :: <boolean>, constant-value)
// Extract the constant from an <defined-constant-reference>.
// TODO: DOESN'T HANDLE FALSE
let value = computation-value(ref);
if (value)
let (inlineable?, inline-value) = inlineable?(value);
if (inlineable?)
values(#t, inline-value)
else
values(#f, #f)
end if
else
values(#f, #f)
end if;
end method;
define method constant-value?
(ref :: <temporary>) => (constant-value? :: <boolean>, constant-value)
// If this temporary is estimated as a singleton, extract the constant.
let type = type-estimate(ref);
if (instance?(type, <type-estimate-limited-instance>))
values(#t, type-estimate-singleton(type))
else
values(#f, #f)
end
end method;
define method constant-value?
(ref :: <value-reference>) => (constant-value? :: <boolean>, constant-value)
// Other kinds of <value-reference>s are not constants.
values(#f, #f)
end method;
define method constant-value-in-cache?
(ref :: <value-reference>, cache)
=> (constant? :: <boolean>, value :: <object>);
constant-value?(ref)
end method;
define method constant-value-in-cache?
(ref :: <temporary>, cache)
=> (constant? :: <boolean>, value :: <object>);
let type = type-estimate-in-cache(ref, cache);
if (instance?(type, <type-estimate-limited-instance>))
values(#t, type-estimate-singleton(type))
else
values(#f, #f)
end
end method;
define function poor-mans-check-type-intersection
(value-type :: <type-estimate>, temp :: false-or(<value-reference>),
cache :: <type-cache>)
=> (intersection :: <type-estimate>)
// TODO: take intersection of value type and checked type
// for now, do a poor-man's intersection
if (temp)
let (the-type-constant?, the-type) = constant-value-in-cache?(temp, cache);
if (the-type-constant? & instance?(the-type, <&type>))
let checked-type = as(<type-estimate>, the-type);
if (type-estimate-subtype?(value-type, checked-type))
// Value-type is more specific
value-type
else
// Checked-type is more specific
checked-type
end
else
// don't know the type being checked at compile time
value-type
end
else
// optimizer has determined that type check is superfluous
value-type
end
end;
define type-inference-rules type-infer-checks
// <check-type>s are a type check + temporary transfer
ct :: <check-type> ==
poor-mans-check-type-intersection(type-estimate-in-cache(computation-value(ct), cache),
type(ct),
cache);
// <constrain-type>s are a constraint + temporary transfer
// See description in optimization/assignment for motivation.
ct :: <constrain-type> ==
begin
let values-te = type-estimate-in-cache(computation-value(ct), cache);
let pruned-values-te =
if (ct.type)
poor-mans-check-type-intersection(values-te, ct.type, cache)
else
let false
= make(<type-estimate-limited-instance>, singleton: &false);
type-difference(values-te, false) | false;
end;
/*
unless (type-estimate-subtype?(values-te, pruned-values-te))
format-out(">>> Pruning type for %=:\n Before %=\n After %=\n",
computation-value(ct), values-te, pruned-values-te);
end;
*/
pruned-values-te
end;
ct :: <multiple-value-check-type> ==
begin
let values-te = type-estimate-in-cache(computation-value(ct), cache);
let checked-types = types(ct);
let checked-fixed-size = size(checked-types);
local method mv-intersection (te :: <type-estimate-values>)
// Intersect te elements with checked-types, in order. Make sure
// we have exactly that many values, trimming #rest type.
let fixed-te* = type-estimate-fixed-values(te);
let values-fixed-size = size(fixed-te*);
let result-fixed = make(<vector>, size: checked-fixed-size);
// Fill result-fixed w/intersection of inferred & checked types.
map-into(result-fixed,
rcurry(poor-mans-check-type-intersection, cache),
fixed-te*, checked-types);
when (values-fixed-size < checked-fixed-size)
// Insufficient fixed values, so pad with rest value.
let rest-te = type-estimate-rest-values(te);
let rest-values-type =
if (~rest-te)
// No rest type, so use default #f.
make(<type-estimate-limited-instance>, singleton: &false)
elseif (instance?(rest-te, <type-estimate-bottom>))
// <bottom> contagion
make(<type-estimate-bottom>)
else
// Union rest-te with singleton(#f).
type-estimate-union(rest-te,
make(<type-estimate-limited-instance>,
singleton: &false))
end;
for (i from values-fixed-size below checked-fixed-size)
// Pad out checked types with intersection of checked
// type and the fill type.
result-fixed[i] :=
poor-mans-check-type-intersection(rest-values-type,
checked-types[i],
cache)
end
end;
// Result-fixed now contains the types we want.
make(<type-estimate-values>,
fixed: as(<list>, result-fixed), // Someday use <sequence>...
rest: #f)
end;
select (values-te by instance?)
<type-estimate-bottom> => values-te;
<type-estimate-values> => mv-intersection(values-te);
<type-estimate-union> => make(<type-estimate-union>,
unionees: map(mv-intersection,
type-estimate-unionees(
values-te)));
end
end;
ct :: <multiple-value-check-type-rest> ==
begin
let values-te = type-estimate-in-cache(computation-value(ct), cache);
let checked-types = types(ct);
let checked-fixed-size = size(checked-types);
local method mv-intersection (te :: <type-estimate-values>)
// Intersect te elements with checked-types, in order. Make sure
// we have AT LEAST that many values, preserving #rest type.
let fixed-te* = type-estimate-fixed-values(te);
let values-fixed-size = size(fixed-te*);
let result-fixed = make(<vector>,
size: max(values-fixed-size,
checked-fixed-size));
// Fill result-fixed w/ intersection of inferred & checked types.
map-into(result-fixed,
rcurry(poor-mans-check-type-intersection, cache),
fixed-te*, checked-types);
let rest-te = type-estimate-rest-values(te);
when (values-fixed-size < checked-fixed-size)
// Insufficient fixed values, so pad with rest value.
let rest-values-type =
if (~rest-te)
// No rest type, so default to singleton(#f).
make(<type-estimate-limited-instance>, singleton: &false)
elseif (instance?(rest-te, <type-estimate-bottom>))
// <bottom> contagion
make(<type-estimate-bottom>)
else
// Use rest type union singleton(#f)
type-estimate-union(rest-te,
make(<type-estimate-limited-instance>,
singleton: &false))
end;
for (i from values-fixed-size below checked-fixed-size)
// Pad out checked types with intersection of checked
// type and the fill type.
result-fixed[i] :=
poor-mans-check-type-intersection(rest-values-type,
checked-types[i],
cache)
end
end;
// Now make sure rest of fixed types, if any, are compatible
// with checked-rest-type.
let checked-rest-type = rest-type(ct);
for (i from checked-fixed-size below values-fixed-size)
result-fixed[i] :=
poor-mans-check-type-intersection(fixed-te*[i],
checked-rest-type,
cache)
end;
// Result-fixed now contains the fixed types. Also need to
// check if the rest type, if any, is compatible.
make(<type-estimate-values>,
fixed: as(<list>, result-fixed),
rest: rest-te &
poor-mans-check-type-intersection(rest-te,
checked-rest-type,
cache))
end;
select (values-te by instance?)
<type-estimate-bottom> => values-te;
<type-estimate-values> => mv-intersection(values-te);
<type-estimate-union> => make(<type-estimate-union>,
unionees: map(mv-intersection,
type-estimate-unionees(
values-te)));
end
end;
end;
// Assume except is just singleton(#f) for now!
define method type-difference
(type :: <type-estimate>, except :: <type-estimate-limited-instance>)
type
end;
define method type-difference
(type :: <type-estimate-class>, except :: <type-estimate-limited-instance>)
if (type.type-estimate-class == dylan-value(#"<boolean>"))
make(<type-estimate-limited-instance>, singleton: &true);
else
type
end
end;
define method type-difference
(type :: <type-estimate-union>, except :: <type-estimate-limited-instance>)
collecting (unionees)
for (te :: <type-estimate> in type-estimate-unionees(type))
let pruned-te = type-difference(te, except);
if (pruned-te) collect-into(unionees, pruned-te) end;
end;
let unionees :: <simple-object-vector>
= as(<simple-object-vector>, collected(unionees));
select (unionees.size)
0 => #f;
1 => unionees[0];
otherwise => make(<type-estimate-union>, unionees: unionees)
end;
end collecting;
end;
define method type-difference
(type :: <type-estimate-limited-instance>,
except :: <type-estimate-limited-instance>)
if (type-estimate-singleton(type) == type-estimate-singleton(except))
#f
else
type
end;
end method;
define type-inference-rules type-infer-cells
// The Marquess of Queensbury Rules.
//
// By popular demand, boxes have the same type as their contents.
// This is a storage issue instead of a type issue, and the compiler is the
// one generating all the boxes, so elaborating a boxed type would just check
// for compiler code-generation bugs anyway.
//
// Readers of the box get a type from original value + all assigns. (reflow)
// Writers of the box get a type from what they write there.
mb :: <make-cell>
<- computation-value(mb);
gv :: <get-cell-value>
<-* generator(computation-cell(gv)), assignments(temporary(generator(computation-cell(gv))));
sv :: <set-cell-value!>
<- computation-value(sv);
end;
define type-inference-rules type-infer-guarantee-type
gt :: <guarantee-type> ==
begin
let static-type = static-guaranteed-type(gt);
if (static-type)
as(<type-estimate>, static-type)
else
poor-mans-check-type-intersection(type-estimate-in-cache(computation-value(gt),
cache),
guaranteed-type(gt),
cache)
end
end;
end;
///
/// Type inference on variables (subclasses of <binding> and <temporary>).
///
define type-inference-rules type-infer-variables
// Rules about variable-like things:
// <temporary>, <multiple-value-temporary>, <entry-state>
// <binding>, <module-binding>, <lexical-required-variable>,
// <lexical-keyword-variable>, <lexical-rest-variable>,
// <lexical-specialized-variable>.
// Note that any <temporary> with a generator is handled by type-infer, now.
mb :: <module-binding>
== case
constant?(mb) // module constant
=> let (val, computed?)
= binding-constant-model-object(mb, error-if-circular?: #f);
case
// Initializer has been computed, so use its result type.
computed? & inlineable?(val)
=> *current-rhs* := add!(*current-rhs*, val);
type-estimate-in-cache(val, cache);
computed? & ^instance?(val, dylan-value(#"<object>"))
// Not inlineable, but might be able to extract a type from val.
// Also not a raw type, which would cause problems.
=> // This does what type-estimate would have done with val,
// but using ^object-class rather than a singleton type.
*current-rhs* := add!(*current-rhs*, val);
cache[val] := make(<type-variable>);
let answer = as(<type-estimate>, ^object-class(val));
type-estimate-update-cache(val, cache, answer);
answer;
// Initializer not computed, so have to punt to declared type.
otherwise
=> type-infer-using-declared-type(cache, mb);
end;
// Otherwise a module variable: type from decls, initializer, assigns.
// NB: Raw variables REQUIRE decls, since they're not <object>s!
// Exported: must believe decl (can't find all assigns).
// TODO: SMARTNESS: This queries exported/created from the module,
// not the library. The test should be a test for escaping the
// library, not the module.
// TODO: Module variables can also escape a library by being named
// in a macro.
exported?(mb)
=> type-infer-using-declared-type(cache, mb);
otherwise
=> type-infer-using-declared-type(cache, mb);
/*
// Unexported module variable: take union of all assigns (including
// initializer), which is the "real" type. NB: type-safety with
// the declared type is enforced with assignment type checks, so
// there's no need to try to intersect them here.
// Further weirdness: optimizers might have removed an assignment,
// leaving behind a model object. So initial type should be type of
// model object or bottom if none.
let model = binding-model-object(mb, default: not-found(),
error-if-circular?: #f);
type-union-with-sources(case
found?(model) =>
*current-rhs* := add!(*current-rhs*, model);
type-estimate-in-cache(model, cache);
otherwise => make(<type-estimate-bottom>);
end,
map(computation-value, assignments(mb)),
cache);
*/
end;
// A fallback for lexical variables which are a subclasses of <temporary>, but
// don't always have their generator set, until all particular cases are
// filled in.
// N.B. - any <temporary> with a generator is filtered out before here
lv :: <lexical-variable> == lift-model-named(#"<object>");
lsv :: <lexical-specialized-variable> // includes required & local vars
== type-union-with-sources
(begin
let spec = specializer(lsv); // Start @ decl
select (spec by instance?)
<&type> => as(<type-estimate>, spec);
otherwise => lift-model-named(#"<object>"); // Dynamic?
end
end,
assignments(lsv),
cache);
// lkv :: <lexical-keyword-variable> == ***;
lrv :: <lexical-rest-variable>
== lift-model-named(#"<simple-object-vector>");
// We know nothing...
ib :: <interactor-binding>
== lift-model-named(#"<object>");
end;
define function type-infer-using-declared-type
(cache, mb :: <module-binding>) => (answer :: <type-estimate>)
let (type-val, computed?)
= binding-constant-type-model-object
(mb, error-if-circular?: #f);
if (computed?)
as(<type-estimate>, type-val);
else
lift-model-named(#"<object>");
end;
end function;
///
/// Type inference on various kinds of data (subclasses of <&object>).
///
define type-inference-rules type-infer-data
// Rules about data objects.
obj :: <&top> == type-estimate-datum(obj);
obj :: <heap-deferred-model> == type-estimate-datum(obj);
// *** All of these are because of mapped types, which are implemented
// directly in the compiler (hence not under <&object>), and because
// the emulator doesn't do type-unions meaningfully.
obj :: <number> == type-estimate-datum(obj);
obj :: <boolean> == type-estimate-datum(obj);
obj :: <character> == type-estimate-datum(obj);
obj :: <string> == type-estimate-datum(obj);
obj :: <symbol> == type-estimate-datum(obj);
obj :: <vector> == type-estimate-datum(obj);
obj :: <list> == type-estimate-datum(obj);
obj :: <mapped-unbound> == type-estimate-datum(obj);
end;