discrimination.dylan

language: infix-dylan
module: dispatch-engine-internal
Copyright:    Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
              All rights reserved.
License:      See License.txt in this distribution for details.
Warranty:     Distributed WITHOUT WARRANTY OF ANY KIND


define function compute-headed-methods (ds :: <dispatch-state>)
 => ()
  let headed-methods :: <pair> = pair(#f, #());
  for (m in generic-function-methods(%ds-gf(ds)), ptr :: <pair> = headed-methods then tail(ptr))
    tail(ptr) := pair(m, #())
  end for;
  %ds-headed-methods(ds) := headed-methods;
end function;





define function prune-methods-by-known-class
    (argnum :: <integer>, cls :: <class>, ds :: <dispatch-state>)
 => (all-accounted-for? :: <boolean>);
  let headed-methods :: <pair> = %ds-headed-methods(ds);
  local method loop (prev :: <pair>, subl :: <list>, allall?)
          if (subl == #())
            allall?
          else
            let meth :: <method> = primitive-the(<method>, head(subl));
            let nxt :: <list> = %proper-list-tail(subl);
            let (some?, all?) = grounded-has-instances?(cls, %method-specializer(meth, argnum));
            if (some?)
              loop(subl, nxt, all? & allall?)
            else
              tail(prev) := nxt;
              loop(prev, nxt, allall?)
            end if
          end if
        end method;
  let the-methods :: <list> = %proper-list-tail(headed-methods);
  loop(headed-methods, the-methods, #t)
end function;




define function consider-arg-discriminated (ds :: <dispatch-state>, argnum :: <integer>, arg)
 => ()
  local method loop (prev :: <pair>, subl :: <list>)
          if (subl == #())
            %ds-add-argnum(argnum, ds)
          else
            let meth :: <method> = primitive-the(<method>, head(subl));
            if (grounded-instance?(arg, %method-specializer(meth, argnum)))
              loop(subl, %proper-list-tail(subl))
            else
              let nxt :: <list> = %proper-list-tail(subl);
              tail(prev) := nxt;
              loop(prev, nxt)
            end if
          end if
        end method;
  let headed-methods :: <pair> = %ds-headed-methods(ds);
  let the-methods :: <list> = %proper-list-tail(headed-methods);
  loop(headed-methods, the-methods)
end function;



define function compute-dispatch-engine (ds :: <dispatch-state>)
 => (new-engine)

  // Now, we have to figure out how to deal with various combinations of
  // cache-header-engine-nodes and caches.

  let cache = %ds-cache(ds);
  let parent :: <dispatch-starter> = %ds-parent(ds);

  if (~*call-site-caches-enabled?*)
    select (parent by instance?)
      <common-root-cache-header-engine-node> =>
        handle-simple-call-site-cache-head(ds, cache, parent);
      <cache-header-engine-node> =>
        cache-header-punt(ds, cache, parent);
      otherwise =>
        handle-standard-dispatch-miss(ds, cache, parent)
    end select
  else
    select (parent by instance?)
      <generic-function> =>
        handle-standard-dispatch-miss(ds, cache, parent);
      <simple-typechecked-cache-header-engine-node> =>
        handle-simple-typechecked-cache-head(ds, cache, parent);
      <common-root-cache-header-engine-node> =>
        handle-simple-call-site-cache-head(ds, cache, parent);
      <simple-call-site-cache-header-engine-node> =>
        handle-simple-call-site-cache-head(ds, cache, parent);
      <profiling-call-site-cache-header-engine-node> =>
        handle-profiling-call-site-cache-head(ds, cache, parent);
      <cache-header-engine-node> =>
        handle-unknown-cache-head(ds, cache, parent);
    end select
  end if
end function;



//// Handle ordinary dispatch miss.

define function handle-standard-dispatch-miss (ds :: <dispatch-state>, cache, parent)
 => (root-engine);
  compute-headed-methods(ds);
  compute-argument-precheck-mask(ds, cache);
  let parent :: <dispatch-starter> = %ds-parent(ds);
  compute-dispatch-from-root(ds, parent);
end function;


define function compute-dispatch-from-root (ds :: <dispatch-state>, parent :: <dispatch-starter>)
 => (root-engine)
  let oengine = dispatch-start(parent);
  let nengine = walk-existing-dispatch-engine(ds, oengine, walk-existing-dispatch-engine);
  if (oengine ~== nengine)
    subst-engine-node(nengine, oengine, ds);
    dispatch-start(parent) := nengine;
  end if;
  nengine
end function;



define inline function subst-engine-node (new-engine-node, old-engine-node, ds :: <dispatch-state>)
 => ()
  if (~pointer-id?(new-engine-node, old-engine-node)
        & old-engine-node ~== $absent-engine-node)
    subst-engine-node-1(new-engine-node, old-engine-node, ds)
  end if
end function;


define macro engine-node-subster
  { engine-node-subster(?new:expression, ?old:expression, ?place:expression) }
    =>
    { begin
        let _new_ = ?new;
        let _old_ = ?old;
        let _v_ = ?place;
        if (pointer-id?(_old_, _v_))
          ?place := _new_
        else
          subst-engine-node-2(_new_, _old_, _v_)
        end if
      end
       }
end macro;

define function subst-engine-node-1 (new-e, old-e, ds :: <dispatch-state>) => ()
  let cache = %ds-cache(ds);
  select (cache by instance?)
    <simple-typechecked-gf-cache-info> =>
      // For these guys, we short-circuit walking all the cache-headers by
      // just walking the entries, since all cache header contents should just
      // be pointing to these.  Then we just update the 'next' pointers of the
      // cache-headers in case a top-level entry has changed.
      let cache :: <simple-typechecked-gf-cache-info> = cache;
      let vec :: <simple-object-vector> = simple-typechecked-gf-cache-info-entries(cache);
      for (i :: <integer> from 0 below size(vec))
        engine-node-subster(new-e, old-e, vector-element(vec, i))
      end for;
      for (e :: false-or(<cache-header-engine-node>)
             in gf-cache-info-users(cache),
           while: e)
        if (pointer-id?(cache-header-engine-node-next(e), old-e))
          cache-header-engine-node-next(e) := new-e
        end if
      end for;
    <gf-cache-info> =>
      // By default, walk/replace in all the cache header users of the g.f.
      let cache :: <gf-cache-info> = cache;
      let vec :: <simple-object-vector> = gf-cache-info-users(cache);
      for (i :: <integer> from 0 below size(vec))
        engine-node-subster(new-e, old-e, vector-element(vec, i));
      end for;
    otherwise => #f;
  end select;
end function;


define function subst-engine-node-2 (new-e, old-e, e) => ()
  select (e by instance?)
    <monomorphic-by-class-discriminator> =>
      let e :: <monomorphic-by-class-discriminator> = e;
      engine-node-subster(new-e, old-e, monomorphic-by-class-discriminator-next(e));
    <class-keyed-discriminator> =>
      let e :: <class-keyed-discriminator> = e;
      for (i :: <integer> from 1 below ckd-size(e) by 2)
        engine-node-subster(new-e, old-e, ckd-ref(e, i))
      end for;
      engine-node-subster(new-e, old-e, grounded-class-keyed-discriminator-default(e));
    <if-type-discriminator> =>
      let e :: <if-type-discriminator> = e;
      engine-node-subster(new-e, old-e, if-type-discriminator-then(e));
      engine-node-subster(new-e, old-e, if-type-discriminator-else(e));
    <typecheck-discriminator> =>
      let e :: <typecheck-discriminator> = e;
      engine-node-subster(new-e, old-e, typecheck-discriminator-next(e));
    <singleton-discriminator> =>
      let e :: <singleton-discriminator> = e;
      let tab :: <simple-object-vector> = singleton-discriminator-table(e);
      for (i from 1 below size(tab) by 2)
        engine-node-subster(new-e, old-e, vector-element(tab, i))
      end for;
      engine-node-subster(new-e, old-e, singleton-discriminator-default(e));
    <discriminator> =>
      error("Unhandled discriminator in substitution: %=", e);
    otherwise => #f;
  end select
end function;



//define function find-low-bit-index (m :: <integer>)
//  local method loop (i :: <integer>, m :: <integer>)
//          if (m == 0)
//            error("select-next-arg-for-discrimination got lost?")
//          elseif (logbit?(0, m))
//            i
//          else
//            loop(i + 1, ash(m, -1))
//          end if
//        end method;
//  loop(0, m)
//end function;


define function select-next-arg-for-discrimination (ds :: <dispatch-state>)
  => (arg);
  let argnum-set :: <argnum-set> = %ds-argnum-set(ds);
  local method loop ()
          let a :: <list> = %ds-args-to-check-first(ds);
          if (a == #())
            let nrequired :: <integer> = %gf-number-required(%ds-gf(ds));
            let next-unchecked-arg :: <integer> = next-free-argnum(-1, argnum-set);
            if (next-unchecked-arg < nrequired)
              next-unchecked-arg
            else
              #f
            end if
          else
            let m :: <integer> = head(a);
            local method moop (m :: <integer>, i :: <integer>)
                    if (m == 0)
                      let nxt :: <list> = %proper-list-tail(a);
                      %ds-args-to-check-first(ds) := nxt;
                      loop()
                    elseif (logbit?(0, m) & ~argnum-considered?(i, argnum-set))
                      head(a) := ash(m, i);
                      i
                    else
                      moop(ash(m, -1), i + 1)
                    end if
                  end method;
            moop(m, 0)
          end if
        end method;
  loop()
end function;


define function walk-existing-dispatch-engine (ds :: <dispatch-state>, e, recurse :: <function>)
  => (e :: <object>);
  select (e by instance?)
    <by-class-discriminator> =>
      let e :: <by-class-discriminator> = e;
      // This one is handled a little differently than all the other discriminators, because
      // it doesn't always finish the discrimination step on the given arg position.
      let argnum :: <integer> = discriminator-argnum(e);
      dbg("walk-existing-dispatch-engine, arg %=: %=", argnum, e);
      let thisarg = vector-element(%ds-args(ds), argnum);
      let argclass :: <class> = object-class(thisarg);
      let all-accounted-for? = prune-methods-by-known-class(argnum, argclass, ds);
      let key :: <integer> = object-class-unique-key(thisarg);
      let next-e = ckd-lookup(key, e);
      let new-e = if (all-accounted-for? | ~instance?(next-e, <absent-engine-node>))
                    %ds-add-argnum(argnum, ds);
                    consider-arg-discriminated(ds, argnum, thisarg);
                    recurse(ds, next-e, recurse)
                  elseif (recurse ~== walk-existing-dispatch-engine)
                    error("Hey, you're not supposed to get here!")
                  else
                    compute-subdiscriminator-for-arg(ds, argnum, thisarg, argclass)
                  end if;
      if (next-e ~== new-e)
        dbg("  ... arg %=:  new class key %=", argnum, key);
        subst-engine-node(new-e, next-e, ds);
        ckd-add!(e, key, new-e)
      else e
      end if;
    <discriminator> =>              // Existing discrimination code.
      let e :: <discriminator> = e;
      let argnum :: <integer> = discriminator-argnum(e);
      dbg("walk-existing-dispatch-engine, arg %=: %=", argnum, e);
      let thisarg = vector-element(%ds-args(ds), argnum);
      consider-arg-discriminated(ds, argnum, thisarg);
      select (e by instance?)
        <class-keyed-discriminator> =>
          let e :: <class-keyed-discriminator> = e;
          let key = if (instance?(e, <by-class-discriminator>))
                      object-class-unique-key(thisarg)
                    else
                      class-unique-key(thisarg)
                    end if;
          let next-e = ckd-lookup(key, e);
          let new-e = recurse(ds, next-e, recurse);
          if (next-e ~== new-e)
            dbg("  ... arg %=:  new class key %=", argnum, key);
            subst-engine-node(new-e, next-e, ds);
            ckd-add!(e, key, new-e)
          else e
          end if;
        <if-type-discriminator> =>
          let e :: <if-type-discriminator> = e;
          let testp = primitive-instance?(thisarg, if-type-discriminator-type(e));
          let next-e = if (testp) if-type-discriminator-then(e) else if-type-discriminator-else(e) end;
          let new-e = recurse(ds, next-e, recurse);
          unless (next-e == new-e)
            subst-engine-node(new-e, next-e, ds);
            if (testp)
              dbg("  ... arg %=:  new `then'", argnum);
              if-type-discriminator-then(e) := new-e
            else
              dbg("  ... arg %=:  new `else'", argnum);
              if-type-discriminator-else(e) := new-e
            end if
          end unless;
          e;
        <typecheck-discriminator> =>
          let e :: <typecheck-discriminator> = e;
          if (primitive-instance?(thisarg, typecheck-discriminator-type(e)))
            let next-e = typecheck-discriminator-next(e);
            let new-e = recurse(ds, next-e, recurse);
            unless (next-e == new-e)
              dbg("  ... arg %=:  typecheck discriminator extended.", argnum);
              subst-engine-node(new-e, next-e, ds);
              typecheck-discriminator-next(e) := new-e
            end unless;
            e
          else
            error("Method list incorrectly pruned?")
          end if;
        <singleton-discriminator> =>
          let e :: <singleton-discriminator> = e;
          let key = vector-element(%ds-args(ds), argnum);
          let lookup = singleton-discriminator-element(e, key, #f);
          let next-e = lookup | singleton-discriminator-default(e);
          let new-e = recurse(ds, next-e, recurse);
          if (next-e ~== new-e)
            subst-engine-node(new-e, next-e, ds);
            if (lookup)
              dbg("  ... arg %=:  new entry for singleton key %=", argnum, key);
              singleton-discriminator-element(e, key) := new-e
            else
              dbg("  ... arg %=:  new entry for singleton table default %=", argnum);
              singleton-discriminator-default(e) := new-e
            end if
          end if;
          e;
      end select;
    <cache-header-engine-node> =>
      let e :: <cache-header-engine-node> = e;
      let nxt = cache-header-engine-node-next(e);
      let new = recurse(ds, nxt, recurse);
      if (nxt ~== new)
        subst-engine-node(new, nxt, ds);
        install-cache-header-engine-node-next(new, e, %ds-gf(ds));
      end if;
      e;
    <method>, <terminal-engine-node> =>
      // We are here either because the engine-node is $absent-engine-node -- and we need
      // to fill it in -- or because of a race condition and it's already been filled in --
      // or because something is broken and we are looping or infinitely recursing.
      // Note that once we are in here, there is no more race condition because the g.f.
      // is locked.
      if (recurse ~== walk-existing-dispatch-engine)
        error("Hey, you're not supposed to get here!")
      elseif (e == $absent-engine-node)
        compute-more-dispatch-engine(ds)
      else
        // If there was no multithreading, we shouldn't get here. If there is,
        // it's possible for another thread to have filled this in ahead of us, so
        // we should just quietly give in.
        e
      end if;
  end select
end function;


define function compute-more-dispatch-engine
    (ds :: <dispatch-state>)
 => (engine :: <object> /* union(<method>, <engine-node>) */);
  let argnum? = select-next-arg-for-discrimination(ds);
  if (~ argnum?)
    compute-terminal-engine-node(ds)
  else
    let argnum :: <integer> = argnum?;
    compute-discriminator-for-arg(argnum, ds)
  end if
end function;


// This is the interesting part, where we figure out how we must do
// discrimination on the next argument.
define function compute-subdiscriminator-for-arg
  (ds :: <dispatch-state>, argnum :: <integer>,
   thisarg, thisargclass :: <class>)
  dbg("compute-subdiscriminator-for-arg %=", argnum);
  local method ponder-this-arg (methods :: <list>, subclass-p, singletons :: <list>, others :: <list>)
        if (methods == #())
          consider-arg-discriminated(ds, argnum, thisarg);
          let nextd = compute-more-dispatch-engine(ds);
          let gf :: <generic-function> = %ds-gf(ds);
          if (subclass-p | (singletons ~== #() & subtype?(thisargclass, <class>)))
            ckd-add!(make-by-singleton-class-discriminator(argnum, gf, 4, $absent-engine-node),
                     class-unique-key(thisarg), nextd)
          elseif (singletons ~== #())
            let d = make-single-class-singleton-discriminator(singletons, argnum, gf);
            local method poo (l :: <list>)
                    if (l == #())
                      dbg("... arg %=:  singletons (default)", argnum);
                      singleton-discriminator-default(d)
                        := compute-default-subdiscriminator(argnum, gf, thisarg, others, nextd)
                    elseif (thisarg == head(l))
                      dbg("... arg %=:  singletons, key = %=", argnum, thisarg);
                      singleton-discriminator-element(d, thisarg) := nextd
                    else
                      poo(tail(l))
                    end if
                  end method;
            poo(singletons);
            d
          else
            compute-default-subdiscriminator(argnum, gf, thisarg, others, nextd)
          end if
        else
          let meth :: <method> = head(methods);
          let spec :: <type> = %method-specializer(meth, argnum);
          let (subclass-p, singletons :: <list>, others :: <list>)
            = ponder-a-specializer(spec, thisargclass, subclass-p, singletons, others);
          ponder-this-arg(tail(methods), subclass-p, singletons, others)
        end if
      end method;
  let methlist :: <list> = %proper-list-tail(%ds-headed-methods(ds));
  ponder-this-arg(methlist, #f, #(), #())
end function;


define function ponder-a-specializer
    (spec :: <type>, thisargclass :: <class>, subclass-p, singletons :: <list>, others :: <list>)
 => (subclass-p, singletons :: <list>, others :: <list>);
  select (spec by instance?)
    <class> =>
      values(subclass-p, singletons, others);
    <singleton> =>
      let spec :: <singleton> = spec;
      let obj = spec.singleton-object;
      let singletons :: <list>
        = if (object-class(obj) == thisargclass) pair(obj, singletons) else singletons end;
      values(subclass-p, singletons, others);
    <subclass> =>
      // values(subclass-p | grounded-subtype?(thisargclass, <class>), singletons, others);
      // @@@@@@
      // this would get triggered with limited collection types -- jb 31MAR99
      // debug-assert(grounded-subtype?(thisargclass, <class>),
      //               "ponder-a-specializer: %= was expected to be a subtype of <class>", thisargclass);
      values(#t, singletons, others);
    <union> =>
      let spec :: <union> = spec;
      let (subclass-p, singletons :: <list>, others :: <list>)
        = ponder-a-specializer(union-type1(spec), thisargclass, subclass-p, singletons, others);
      ponder-a-specializer(union-type2(spec), thisargclass, subclass-p, singletons, others);
    <limited-type> =>
      values(subclass-p, singletons,
             if (grounded-has-instances?(thisargclass, spec)) pair(spec, others) else others end);
  end select
end function;


define function compute-default-subdiscriminator
    (argnum :: <integer>, gf :: <generic-function>, thisarg, specs :: <list>, nextd)
  local method subsumed?(t :: <type>, l :: <list>)
          if (l == #())
            #f
          elseif (grounded-subtype?(t, head(l)))
            #t
          else
            subsumed?(t, tail(l))
          end if
        end method;
  local method foo (specs :: <list>, truelist :: <list>, falselist :: <list>, nextd)
          if (specs == #())
            nextd
          else
            let spec :: <type> = head(specs);
            let nextspecs :: <list> = %proper-list-tail(specs);
            let (thend, elsed) = if (nextd == $absent-engine-node)
                                   values(nextd, nextd)
                                 elseif (primitive-instance?(thisarg, spec))
                                   values(nextd, $absent-engine-node)
                                 else
                                   values($absent-engine-node, nextd)
                                 end if;
            if (subsumed?(spec, truelist))
              foo(nextspecs, truelist, falselist, thend)
            elseif (subsumed?(spec, falselist))
              foo(nextspecs, truelist, falselist, elsed)
            else
              make-if-type-discriminator(argnum, gf, spec,
                                         foo(nextspecs, pair(spec, truelist), falselist, thend),
                                         foo(nextspecs, truelist, pair(spec, falselist), elsed))
            end if
          end if
        end method;
  foo(specs, #(), #(), nextd)
end function;



define function compute-discriminator-for-arg (argnum :: <integer>, ds :: <dispatch-state>)
 => (engine)
  let thisarg = vector-element(%ds-args(ds), argnum);
  let thisargclass = object-class(thisarg);
  if (tail(%ds-headed-methods(ds)) == #())
    // No specializers (the methods list was empty).
    dispinapplicable(ds)
  else
    let (secondary-p :: <boolean>, force-blowup-p :: <boolean>,
         all-subtypes-p :: <boolean>, some-subtypes-p :: <boolean>,
         subtype-exception :: false-or(<type>))
      = ponder-this-arg (ds, thisarg, thisargclass, argnum);
    if (~force-blowup-p & all-subtypes-p)
      // No discrimination needed:  the known arg type is a subtype of all specializers.
      consider-arg-discriminated(ds, argnum, thisarg);
      compute-more-dispatch-engine(ds)
    else
      let gf :: <generic-function> = %ds-gf(ds);
      if (force-blowup-p | ~subtype-exception)
        let nextd
          = if (secondary-p)
              prune-methods-by-known-class(argnum, thisargclass, ds);
              compute-subdiscriminator-for-arg(ds, argnum, thisarg, thisargclass)
            else
              consider-arg-discriminated(ds, argnum, thisarg);
              compute-more-dispatch-engine(ds)
            end if;
        ckd-add!(make-by-class-discriminator(argnum, gf, 1),
                 class-unique-key(thisargclass), nextd)
      else
        consider-arg-discriminated(ds, argnum, thisarg);
        let nextd = compute-more-dispatch-engine(ds);
        if (some-subtypes-p)
          // We have to distinguish between one specializer and the rest.
          let (thend, elsed) = if (primitive-instance?(thisarg, subtype-exception))
                                 values(nextd, $absent-engine-node)
                               else
                                 values($absent-engine-node, nextd)
                               end if;
          make-if-type-discriminator(argnum, gf, subtype-exception, thend, elsed)
        else
          // There is only one specializer, but we don't have type info for it.
          make-typecheck-discriminator(argnum, gf, subtype-exception, nextd)
        end if
      end if
    end if
  end if
end function;


define function secondary-dispatch-specializer? (spec :: <type>, thisargclass :: <class>)
 => (secondary-p :: <boolean>)
  if (instance?(spec, <union>))
    let spec :: <union> = spec;
    secondary-dispatch-specializer?(spec.union-type1, thisargclass)
      | secondary-dispatch-specializer?(spec.union-type2, thisargclass)
  else
    let (some?, all?) = grounded-has-instances?(thisargclass, spec);
    some? & (~ all?)
  end if
end function;


define function ponder-this-arg (ds :: <dispatch-state>, thisarg,
                                 thisargclass :: <class>, argnum :: <integer>)
 => (secondary-p :: <boolean>, force-blowup-p :: <boolean>,
     all-subtypes-p :: <boolean>, some-subtypes-p :: <boolean>,
     subtype-exception :: false-or(<type>))

  let methods :: <list> = %proper-list-tail(%ds-headed-methods(ds));
  let gf :: <generic-function> = %ds-gf(ds);
  let knownargtype :: <type> = %ds-argtype(ds, argnum);
  local method loop (methods :: <list>, secondary-p :: <boolean>, force-blowup-p :: <boolean>,
                     all-subtypes-p :: <boolean>, some-subtypes-p :: <boolean>, subtype-exception)
         // TODO: TYPIST CAN'T PROVE THIS AND THEN THIS BLOWS TAIL CALLS
         // => (secondary-p :: <boolean>, force-blowup-p :: <boolean>,
         //     all-subtypes-p :: <boolean>, some-subtypes-p :: <boolean>,
         //     subtype-exception :: false-or(<type>));
          if (methods == #())
            values(secondary-p, force-blowup-p, all-subtypes-p, some-subtypes-p,
                   subtype-exception ~== #t & subtype-exception)
          else
            let meth :: <method> = head(methods);
            let spec :: <type> = %method-specializer(meth, argnum);
            let secondary-p :: <boolean>
              = secondary-p | secondary-dispatch-specializer?(spec, thisargclass);
            let force-blowup-p :: <boolean>
              = force-blowup-p | slot-method-requiring-class-discrimination?(meth, argnum);
            let methods :: <list> = %proper-list-tail(methods);
            if (concrete-subtype?(knownargtype, spec, gf))
              loop(methods, secondary-p, force-blowup-p, all-subtypes-p, #t, subtype-exception)
            else
              loop(methods, secondary-p, force-blowup-p, #f, some-subtypes-p,
                   if (subtype-exception)
                     if (subtype-exception == #t | ~same-specializer?(subtype-exception, spec))
                       #t
                     else
                       spec
                     end if
                   else
                     spec
                   end if)
            end if
          end if
        end method;
  loop(methods, #f, #f, #t, #f, #f)
end function;



define function determine-call-keywords (gf :: <generic-function>, methods :: <list>)
  let sig :: <signature> = function-signature(gf);
  if (signature-all-keys?(sig))
    #t
  elseif (signature-key?(sig))
    local method outer (meths :: <list>, ans :: <list>, nans :: <integer>)
            if (meths == #())
              let v :: <simple-object-vector> = make(<simple-object-vector>, size: nans);
              for (i :: <integer> from 0, x in ans) vector-element(v, i) := x end;
              v
            else
              let m :: <method> = head(meths);
              if (signature-all-keys?(function-signature(m)))
                #t
              else
                let keys :: <simple-object-vector> = keyword-specifiers(m);
                let n :: <integer> = size(keys);
                local method inner (i :: <integer>, ans :: <list>, nans :: <integer>)
                        if (i == n)
                          outer(tail(meths), ans, nans)
                        else
                          let k = vector-element(keys, i);
                          if (member?(k, ans))
                            inner(i + 2, ans, nans)
                          else
                            inner(i + 2, pair(k, ans), nans + 1)
                          end if
                        end if
                      end method;
                inner(0, ans, nans)
              end if
            end if
          end method;
    outer(methods, #(), 0)
  else
    #f
  end if
end function;

define function compute-terminal-engine-node (ds :: <dispatch-state>)
  => (terminal-thing :: <object> /* union(<method>, <engine-node>) */);
  let methlist :: <list> = %proper-list-tail(%ds-headed-methods(ds));
  let keys = determine-call-keywords(%ds-gf(ds), methlist);
  let (ordered :: <list>, ambig :: <list>) = sort-applicable-methods(methlist, %ds-args(ds));
  dbg("Terminal engine node:  ordered methods = %=, ambig = %=", ordered, ambig);
  let ans = transmogrify-method-list-grounded
    (ds, ordered, ambig, keys,
     *gracefully-dispatch-to-ambiguous-methods*);
  dbg("Terminal engine node = %=", ans);
  let parent
    = %ds-parent(ds);
  let profiling-parent
    = if (instance?(parent, <cache-header-engine-node>))
        cache-header-engine-node-parent(parent)
      else
        parent
      end if;
  if (*profile-all-terminal-engine-nodes?*
        | instance?(profiling-parent, <profiling-call-site-cache-header-engine-node>))
    let new :: <profiling-call-site-cache-header-engine-node>
      = bootstrap-typed-allocate-engine-node(<profiling-call-site-cache-header-engine-node>,
                                             engine-node$k-profiling-cache-header,
                                             0);
    cache-header-engine-node-parent(new) := parent;
    primitive-initialize-engine-node(new);
    %profile-count-low(new)  := as(<machine-word>, 0);
    %profile-count-high(new) := as(<machine-word>, 0);
    install-cache-header-engine-node-next(new, ans, %ds-gf(ds));
    new
  else
    ans
  end if
end function;


// Produce an engine-node for a method.
define function transmogrify-method-list-grounded
    (ds :: <dispatch-state>, ordered :: <list>, ambig :: <list>, keyspec, kludge?)
 => (frob :: <object> /* union(<engine-node>, <method>) */);
  let gf :: <generic-function> = %ds-gf(ds);
  let args :: <simple-object-vector> = %ds-args(ds);
  if (ordered == #())
    if (ambig == #())
      dbg("No applicable methods, punting...");
      dispinapplicable(ds)
    elseif (kludge?)
      dbg("Trying to salvage ambiguous methods");
      let (nordered :: <list>, nambig :: <list>)
        = sort-applicable-methods-desperately(ambig, args);
      unless (nordered == #())
        let args = reconstruct-args-from-mepargs(gf, args);
        dispwarn(make(<ambiguous-methods-warning>,
                      generic: gf, arguments: args, ambiguous: ambig,
                      format-string:
                        "Method specificity of unorderable methods %= applying %= to %= "
                        "was determined with arbitrary and capricious rules.",
                      format-arguments: vector(ambig, gf, args)),
                 ds)
      end unless;
      transmogrify-method-list-grounded(ds, nordered, nambig, keyspec, #f)
    else
      dbg("No orderable methods, making ambiguous-method engine node.");
      make-ambiguous-methods-engine-node(ordered, ambig)
    end if
  else
    let m :: <method> = head(ordered);
    select (m by instance?)
      <accessor-method> =>
        let m :: <accessor-method> = m;
        make-slot-access-engine-node(m, ds);
      otherwise =>
        let nextp = function-next?(m);
        let more
          = if (nextp)
              let moremeths :: <list> = %proper-list-tail(ordered);
              transmogrify-method-list-tail-grounded(ds, ordered, moremeths, ambig, kludge?)
            else #()
            end if;
        if (~more)
          $absent-engine-node
        elseif (~nextp & more == #() & (keyspec == #t | keyspec == #f)
                  & primitive-callable-as-engine-node?(m))
          m
        else
          make-single-method-engine-node(m, data: more, keys: keyspec)
        end if
    end select
  end if
end function;

// Recursively generate the next-method chain.
define function transmogrify-method-list-tail-grounded
    (ds :: <dispatch-state>, ordered :: <list>, subordered :: <list>,
     ambig :: <list>, kludge? :: <boolean>)
 => (frob :: <list>);
  if (subordered == #())
    if (ambig == #())
      #()
    elseif (kludge?)
      dbg("Trying to salvage ambiguous method list tail");
      let args :: <simple-object-vector> = %ds-args(ds);
      let (nordered :: <list>, nambig :: <list>)
        = sort-applicable-methods-desperately(ambig, args);
      unless (nordered == #())
        let gf = %ds-gf(ds);
        let args = reconstruct-args-from-mepargs(gf, args);
        dispwarn(make(<ambiguous-methods-warning>,
                      generic: gf, arguments: args,
                      ordered: ordered, ambiguous: ambig,
                      format-string:
                        "Applying %= to %=, ambiguous method ordering of group %= after "
                        "successfully ordered methods %= "
                        "was determined with arbitrary and capricious rules.",
                      format-arguments: vector(gf, args, ambig, ordered)),
                 ds)
      end unless;
      transmogrify-method-list-tail-grounded(ds, ordered, nordered, nambig, #f)
    else
      make-ambiguous-methods-next-method(ordered, ambig, %ds-gf(ds))
    end if
  else
    let m :: <method> = head(subordered);
    let more
      = if (function-next?(m))
          let othermeths :: <list> = %proper-list-tail(subordered);
          transmogrify-method-list-tail-grounded(ds, ordered, othermeths,
                                                 ambig,  kludge?);
        else
          #()
        end if;
    more & select (m by instance?)
             <accessor-method> =>
               let m :: <accessor-method> = m;
               make-slot-accessing-next-method-chain(ds, m);
             <method>      => pair(m, more);
           end select
  end if
end function;

define function %method-applicable?
    (meth :: <method>, args :: <simple-object-vector>)
 => (answer :: <boolean>);
  let n :: <integer> = size(args);
  local method loop (i :: <integer>)
          if (i == n)
            #t
          elseif (primitive-instance?(vector-element(args, i), %method-specializer(meth, i)))
            loop(i + 1)
          else
            #f
          end if
        end method;
  loop(0)
end function;

define inline-only function sort-applicable-methods
  (methlist :: <list>, args :: <simple-object-vector>)
      => (ordered-unambiguous :: <list>, unordered-ambiguous :: <list>);
  compute-sorted-applicable-methods-1(methlist, args, %order-methods);
end function;


define inline-only function sort-applicable-methods-desperately
  (methlist :: <list>, args :: <simple-object-vector>)
      => (ordered-unambiguous :: <list>, unordered-ambiguous :: <list>);
  compute-sorted-applicable-methods-1(methlist, args, %order-methods-desperately);
end function;



define function compute-sorted-applicable-methods
    (gf :: <generic-function>, args :: <simple-object-vector>)
 => (ordered :: <list>, ambig :: <list>);
  compute-sorted-applicable-methods-1(for (ans = #() then if (%method-applicable?(m, args)) pair(m, ans) else ans end,
                                           m in generic-function-methods(gf))
                                      finally ans
                                      end for,
                                      args, %order-methods)
end function;


define function compute-sorted-applicable-methods-1
    (methlist :: <list>, args :: <simple-object-vector>, order-the-methods :: <method>)
 => (ordered :: <list>, ambig :: <list>);
  let ohead :: <pair> = pair(#f, #());
  let ahead :: <pair> = pair(#f, #());
  local method loop (methlist :: <list>) => ()
          unless (methlist == #())
            let meth :: <method> = head(methlist);
            local method make-ambiguous (headed-list :: <pair>) => ();
                    local method loop (l :: <list>)
                            unless (l == #())
                              let t1 :: <list> = %proper-list-tail(l);
                              tail(l) := tail(ahead);
                              tail(ahead) := l;
                              loop(t1)
                            end unless
                          end method;
                    loop(tail(headed-list));
                    tail(headed-list) := #();
                    tail(ahead) := pair(meth, tail(ahead))
                  end method;
            local method precedes-all? (l :: <list>)
                    local method loop (l :: <list>)
                            if (l == #())
                              #t
                            elseif (order-the-methods(meth, head(l), args) ~== #"<")
                              #f
                            else
                              loop(tail(l))
                            end if
                          end method;
                    loop(l)
                  end method;
            local method check-subsequent-ambiguities (oprev :: <pair>) => ();
                    if (~precedes-all?(tail(oprev)) | ~precedes-all?(tail(ahead)))
                      make-ambiguous(oprev)
                    else
                      tail(oprev) := pair(meth, tail(oprev))
                    end if;
                  end method;
            local method insert (oprev :: <pair>, osub :: <list>) => ()
                    if (empty?(osub))
                      check-subsequent-ambiguities(oprev)
                    else
                      let indic = order-the-methods(meth, head(osub), args);
                      if (indic == #"<")          // Comes before current one.
                        check-subsequent-ambiguities(oprev)
                      elseif (indic == #">")      // Comes after, check further.
                        insert(osub, tail(osub))
                      else        // Ambiguous.  All following ordered methods are too.
                        unless (indic == #"=" & *gracefully-ignore-duplicate-methods*)
                          make-ambiguous(oprev)
                        end unless
                      end if
                    end if
                  end method;
            insert(ohead, tail(ohead));
            loop(tail(methlist))
          end unless
        end method;
  loop(methlist);
  values(tail(ohead), tail(ahead))
end function;



define variable *gracefully-dispatch-to-ambiguous-methods* = #t;

// See the code in compute-sorted-applicable-methods-1.  What this does is cause
// a duplicated method to get tossed on the floor rather than considered
// ambiguous.  Doing this in any kind of consistent way relies on consistent
// adding of methods to the g.f. - which is (mostly) done (latest addition
// comes first in the generic-function-methods) and on the preservation of this
// ordering through the discrimination pruning (which is also done).
define variable *gracefully-ignore-duplicate-methods* = #t;


define abstract class <ambiguous-methods> (<simple-condition>)
  constant slot ambiguous-methods-generic :: <generic-function>, required-init-keyword: generic:;
  constant slot ambiguous-methods-ordered :: <list>, init-keyword: ordered:, init-value: #();
  constant slot ambiguous-methods-ambiguous :: <list>, required-init-keyword: ambiguous:;
  constant slot ambiguous-methods-arguments :: <sequence>, required-init-keyword: arguments:;
end class;


define class <ambiguous-methods-warning> (<ambiguous-methods>, <warning>)
end class;

define class <ambiguous-methods-error> (<ambiguous-methods>, <error>)
end class;


define function %order-methods-desperately (m1 :: <method>, m2 :: <method>,
                                            args :: <simple-object-vector>)
 => (v :: <symbol>);
  let nreq :: <integer> = %method-number-required(m1);
  local method loop (idx :: <integer>, ambigp)
          if (idx == nreq)
            if (ambigp) #"<>" else #"=" end
          else
            let s1 :: <type> = %method-specializer(m1, idx);
            let s2 :: <type> = %method-specializer(m2, idx);
            let arg = vector-element(args, idx);
            let cmp0 :: <symbol> = %order-specializers(s1, s2, arg);
            let cmp = if (cmp0 == #"<>") %order-specializers-desperately(s1, s2, arg) else cmp0 end;
            if (cmp == #"<" | cmp == #">")
              cmp
            else
              loop(idx + 1, ambigp | cmp == #"<>")
            end if
          end if
        end method;
  loop(0, #f)
end function;


define function %order-methods
    (meth1 :: <method>, meth2 :: <method>, args :: <simple-object-vector>)
 => (order :: <symbol>);
  let nreq :: <integer> = %method-number-required(meth1);
  local method loop (state :: <symbol>, idx :: <integer>)
          if (idx == nreq)
            state
          else
            let meth1spec :: <type> = %method-specializer(meth1, idx);
            let meth2spec :: <type> = %method-specializer(meth2, idx);
            let cmp :: <symbol> = %order-specializers(meth1spec, meth2spec,
                                                      vector-element(args, idx));
            let idx :: <integer> = idx + 1;
            if (cmp == #"=")
              loop(state, idx)
            elseif (cmp ~== #"<>" & (state == #"=" | cmp == state))
              loop(cmp, idx)
            else
              #"<>"
            end if
          end if
        end method;
  loop (#"=", 0)
end function;

define function %class<
    (c1 :: <class>, c2 :: <class>, wrt :: <class>)
 => (o :: <boolean>);
  /*
  local method fubar (l :: <list>)
          if (empty?(l))
            error("Can't order specializers - arg/reference class %= is neither %= nor %=", wrt, c1, c2)
          else
            let c :: <class> = head(l);
            let nxt :: <list> = tail(l);
            if (c == c1)
              #t
            elseif (c == c2)
              #f
            else fubar(nxt)
            end if
          end if
        end method;
  fubar(all-superclasses(wrt))
  */
  block (return)
    for-each-superclass (c :: <class> of wrt)
      if (c == c1)
        return(#t);
      elseif (c == c2)
        return(#f);
      else
        // look at the next one
      end if;
    end for-each-superclass;
    error("Can't order specializers - arg/reference class %= is "
          "neither %= nor %=", wrt, c1, c2)
  end block;
end function;


define function %order-specializers-default (t1 :: <type>, t2 :: <type>)
 => (order :: <symbol>, canonical-type :: <type>);
  if (grounded-subtype?(t1, t2))
    values(if (grounded-subtype?(t2, t1)) #"=" else #"<" end, t1)
  elseif (grounded-subtype?(t2, t1))
    values(#">", t2)
  else
    values(#"<>", <object>)
  end if
end function;


define function %order-specializers-desperately (t1 :: <type>, t2 :: <type>, arg)
 => (order :: <symbol>, canonical-type :: <type>);
  if (t1 == t2)
    values(#"=", t1)
  elseif (instance?(t1, <union>))
    let t1 :: <union> = t1;
    let left :: <type> = union-type1(t1);
    let right :: <type> = union-type2(t1);
    if (primitive-instance?(arg, left))
      if (primitive-instance?(arg, right))
        let (order :: <symbol>, ntype :: <type>) = %order-specializers-desperately(left, right, arg);
        if (order ~== #"<>")
          %order-specializers-desperately(ntype, t2, arg)
        else
          values(order, ntype)
        end if
      else
        %order-specializers-desperately(left, t2, arg)
      end if
    elseif (primitive-instance?(arg, right))
      %order-specializers-desperately(right, t2, arg)
    else
      error("You shouldn't get here!")
    end if
  elseif (instance?(t2, <union>))
    let t2 :: <union> = t2;
    let left :: <type> = union-type1(t2);
    let right :: <type> = union-type2(t2);
    if (primitive-instance?(arg, left))
      if (primitive-instance?(arg, right))
        let (order :: <symbol>, ntype :: <type>) = %order-specializers-desperately(left, right, arg);
        if (order ~== #"<>")
          %order-specializers-desperately(t1, ntype, arg)
        else
          values(order, ntype)
        end if
      else
        %order-specializers-desperately(t1, left, arg)
      end if
    elseif (primitive-instance?(arg, right))
      %order-specializers-desperately(t1, right, arg)
    else
      error("You shouldn't get here either!")
    end if
  elseif (instance?(t1, <singleton>))
    values(if (instance?(t2, <singleton>)) #"=" else #"<" end, t1)
  elseif (instance?(t2, <singleton>))
    values(#">", t2)
  elseif (instance?(t1, <subclass>))
    let t1 :: <subclass> = t1;
    let c1 :: <class> = t1.subclass-class;
    if (instance?(t2, <subclass>))
      let arg :: <class> = arg;
      let t2 :: <subclass> = t2;
      let c2 :: <class> = t2.subclass-class;
      case
        (c1 == c2) => values(#"=", t1);
        (%class<(c1, c2, arg)) => values(#"<", t1);
        otherwise => values(#">", t2);
      end case
    elseif (instance?(t2, <class>))
      let c2 :: <class> = t2;
      values(if (subtype?(<class>, c2))
               if (c1 == <object>) %order-specializers(<class>, c2, arg) else #"<" end
             else #"<>"
             end,
             t1)
    else
      %order-specializers-default(t1, t2)
    end if
  elseif (instance?(t2, <subclass>))
    let t2 :: <subclass> = t2;
    if (instance?(t1, <class>))
      let c2 :: <class> = t2.subclass-class;
      let c1 :: <class> = t1;
      values(if (subtype?(<class>, c1))
               if (c2 == <object>) %order-specializers(c1, <class>, arg) else #">" end if
             else #"<>"
             end,
             t2)
    else
      %order-specializers-default(t1, t2)
    end if
  elseif (instance?(t1, <class>))
    let t1 ::<class> = t1;
    if (instance?(t2, <class>))
      let t2 :: <class> = t2;
      if (%class<(t1, t2, object-class(arg))) values(#"<", t1) else values(#">", t2) end if
    else
      %order-specializers-default(t1, t2)
    end if
  else
    %order-specializers-default(t1, t2)
  end if
end function;


define function %order-specializers (t1 :: <type>, t2 :: <type>, arg)
 => (order :: <symbol>, canonical-type :: <type>);
  if (t1 == t2)
    values(#"=", t1)
  elseif (instance?(t1, <singleton>))
    values(if (instance?(t2, <singleton>)) #"=" else #"<" end, t1)
  elseif (instance?(t2, <singleton>))
    values(#">", t2)
  elseif (instance?(t1, <subclass>))
    let t1 :: <subclass> = t1;
    let c1 :: <class> = t1.subclass-class;
    if (instance?(t2, <subclass>))
      let arg :: <class> = arg;
      let t2 :: <subclass> = t2;
      let c2 :: <class> = t2.subclass-class;
      case
        (c1 == c2) => values(#"=", t1);
        (%class<(c1, c2, arg)) => values(#"<", t1);
        otherwise => values(#">", t2);
      end case
    elseif (instance?(t2, <class>))
      let c2 :: <class> = t2;
      values(if (subtype?(<class>, c2))
               if (c1 == <object>) %order-specializers(<class>, c2, arg) else #"<" end
             else #"<>"
             end,
             t1)
    else
      %order-specializers-default(t1, t2)
    end if
  elseif (instance?(t2, <subclass>))
    let t2 :: <subclass> = t2;
    if (instance?(t1, <class>))
      let c2 :: <class> = t2.subclass-class;
      let c1 :: <class> = t1;
      values(if (subtype?(<class>, c1))
               if (c2 == <object>) %order-specializers(c1, <class>, arg) else #">" end if
             else #"<>"
             end,
             t2)
    else
      %order-specializers-default(t1, t2)
    end if
  elseif (instance?(t1, <class>))
    let t1 :: <class> = t1;
    if (instance?(t2, <class>))
      let t2 :: <class> = t2;
      if (%class<(t1, t2, object-class(arg))) values(#"<", t1) else values(#">", t2) end if
    else
      %order-specializers-default(t1, t2)
    end if
  else
    %order-specializers-default(t1, t2)
  end if
end function;


define function same-specializer? (s1 :: <type>, s2 :: <type>) => (answer :: <boolean>);
  select (s1 by instance?)
    <class> =>
      s1 == s2;
    <singleton> =>
      let s1 :: <singleton> = s1;
      if (instance?(s2, <singleton>))
        let s2 :: <singleton> = s2;
        singleton-object(s1) == singleton-object(s2)
      else
        #f
      end if;
    <subclass> =>
      let s1 :: <subclass> = s1;
      if (instance?(s2, <subclass>))
        let s2 :: <subclass> = s2;
        s1.subclass-class == s2.subclass-class
      else
        #f
      end if;
    otherwise =>
      (s1 == s2) | (grounded-subtype?(s1, s2) & grounded-subtype?(s2, s1));
  end select
end function;


define inline function same-specializers-spread?
    (req1 :: <simple-object-vector>, nreq1 :: <integer>,
     req2 :: <simple-object-vector>, nreq2 :: <integer>)
  => (answer :: <boolean>);
  (nreq1 == nreq2
   & (req1 == req2  // in case data sharing makes this easy
        | begin
            local method loop (i :: <integer>)
                    if (i == nreq1)
                      #t
                    elseif (same-specializer?
                              (vector-element(req1, i),
                               vector-element(req2, i)))
                      loop(i + 1)
                    else
                      #f
                    end if
                  end method;
            loop(0)
          end))
end function;

define function same-specializers? (sig1 :: <signature>, sig2 :: <signature>)
  => (answer :: <boolean>);
  same-specializers-spread?
    (signature-required(sig1), signature-number-required(sig1),
     signature-required(sig2), signature-number-required(sig2))
end function;