dispatch-caches.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 variable *call-site-caches-enabled?* = #t;

define function call-site-caches-enabled? () => (res)
  *call-site-caches-enabled?*
end function;

define function call-site-caches-enabled?-setter (well?)
  *call-site-caches-enabled?* := well?
end function;


//define sealed generic profiling-call-site-cache-header-engine-node-count-1
//    (x :: <profiling-cache-header-engine-node>) => (v :: <raw-machine-word>);

//define sealed generic profiling-call-site-cache-header-engine-node-count-2
//    (x :: <profiling-cache-header-engine-node>) => (v :: <raw-machine-word>);

//define sealed generic profiling-call-site-cache-header-engine-node-count-1-setter
//    (v :: <raw-machine-word>, x :: <profiling-cache-header-engine-node>);

//define sealed generic profiling-call-site-cache-header-engine-node-count-2-setter
//    (v :: <raw-machine-word>, x :: <profiling-cache-header-engine-node>);




define inline-only function stchen-checkedmask
    (stchen :: <simple-typechecked-cache-header-engine-node>) => (m :: <integer>)
  %load-byte(stchen$v-checkedmask, stchen$s-checkedmask, properties(stchen))
end function;


define function install-cache-header-engine-node-next (old :: <cache-header-engine-node>,
                                                       next :: type-union(<method>, <engine-node>),
                                                       gf :: <generic-function>)
 => ()
  // Make sure all side effects to date are to date...
  synchronize-side-effects();
  // Then store.
  cache-header-engine-node-next(old) := next;
  // primitive-enable-cache-header-engine-node(old, gf);
end function;


define constant $cache-header-engine-node-users-increment :: <integer> = 4;


define inline-only function make-new-gf-cache-info-users (current-size :: <integer>)
 => (v :: <simple-object-vector>)
  make(<simple-object-vector>,
       size: current-size + $cache-header-engine-node-users-increment,
       fill: #f)
end function;



define function track-cache-header-engine-node (e :: <cache-header-engine-node>, c :: <gf-cache-info>)
 => ()
  let v :: <simple-object-vector> = gf-cache-info-users(c);
  let n :: <integer> = size(v);
  local method loop (i :: <integer>)
          if (i == n)
            let nv = %make-simple-vector(n + $cache-header-engine-node-users-increment, #f);
            for (i :: <integer> from 0 below n) vector-element(nv, i) := vector-element(v, i) end;
            vector-element(nv, n) := e;
            gf-cache-info-users(c) := nv;
          else
            let e2 = vector-element(v, i);
            if (e2 == #f)
              vector-element(v, i) := e;
            elseif (e2 ~== e)
              loop(i + 1);
            end if;
          end if;
        end method;
  loop(0)
end function;


define function compute-typecheckable-argument-mask
  (gf :: <generic-function>, headed-methods :: <pair>) => (bitz :: <integer>);
  if (~*call-site-caches-enabled?* | ~generic-function-sealed?(gf))
    0
  else
    let meths :: <list> = %proper-list-tail(headed-methods);
    let nreq :: <integer> = min(%gf-number-required(gf),
                                $simple-typechecked-cache-arguments-limit);
    if (meths == #())
      0
    else
      iterate loop (argnum :: <integer> = 0, bitz :: <integer> = 0)
        if (argnum == nreq)
          bitz
        else
          let m :: <method> = head(meths);
          let next-l :: <list> = %proper-list-tail(meths);
          let this-spec :: <type> = %method-specializer(m, argnum);
          if (this-spec == <object>)
            loop(argnum + 1, bitz)
          else
            iterate scan (l :: <list> = next-l)
              if (l == #())
                loop(argnum + 1, logior(ash(1, argnum), bitz))
              else
                let m :: <method> = head(l);
                let next-l :: <list> = %proper-list-tail(l);
                if (same-specializer?(this-spec, %method-specializer(m, argnum)))
                  scan(next-l)
                else
                  loop(argnum + 1, bitz)
                end if
              end if
            end iterate;
          end if
        end if
      end iterate
    end if
  end if
end function;


//// Cache Info Creation and Upgrading


define function upgrade-gf-cache-info!
    (new :: <gf-cache-info>, ds :: <dispatch-state>,
     users :: false-or(<simple-object-vector>))
 => ();
  gf-cache-info-users(new) := users | make-new-gf-cache-info-users(0);
  %ds-cache(ds) := new;
end function;


define function upgrade-to-basic-gf-cache-info (old, ds :: <dispatch-state>)
 => (cache-info :: <gf-cache-info>)
  case
    old == #f | old == 0 =>
      let new :: <gf-cache-info>
        = system-allocate-simple-instance(<gf-cache-info>);
      upgrade-gf-cache-info!(new, ds, #f);
      %gf-cache(%ds-gf(ds)) := new;
    instance?(old, <integer>) =>
      upgrade-to-simple-typechecked-gf-cache-info(old, ds);
    instance?(old, <gf-cache-info>) =>
      old;
    otherwise =>
      error("Bogus gf cache info %=", old);
  end case
end function;


define function upgrade-simple-typechecked-gf-cache-info!
    (new :: <simple-typechecked-gf-cache-info>, ds :: <dispatch-state>,
     argmask :: false-or(<integer>),
     entries :: false-or(<simple-object-vector>),
     users :: false-or(<simple-object-vector>))
 => ();
  upgrade-gf-cache-info!(new, ds, users);
  let m :: <integer> = argmask | compute-typecheckable-argument-mask(%ds-gf(ds), %ds-headed-methods(ds));
  simple-typechecked-gf-cache-info-argmask(new) := m;
  simple-typechecked-gf-cache-info-entries(new)
    := entries | make(<simple-object-vector>,
                      size: 1 + compress-mask(m, m), // What a crappy way to do logcount.
                      fill: #f);
end function;


define function upgrade-to-simple-typechecked-gf-cache-info (old, ds :: <dispatch-state>)
 => (cache-info :: <simple-typechecked-gf-cache-info>)
  if (instance?(old, <simple-typechecked-gf-cache-info>))
    old
  else
    let new :: <simple-typechecked-gf-cache-info>
      = system-allocate-simple-instance(<simple-typechecked-gf-cache-info>);
    select (old by instance?)
      <integer>, singleton(#f) =>
        upgrade-simple-typechecked-gf-cache-info!(new, ds, old, #f, #f);
    end select;
    %gf-cache(%ds-gf(ds)) := new
  end if
end function;


define function compute-argument-precheck-mask (ds :: <dispatch-state>, cache)
 => ();
  let m :: <integer>
    = case
        cache == #f =>
          // By default, do first the argument positions which have no varying specializers.
          let gf :: <generic-function> = %ds-gf(ds);
          %gf-cache(gf) := compute-typecheckable-argument-mask(gf, %ds-headed-methods(ds));
        instance?(cache, <integer>) =>
          // We've computed it already - maybe at compile time.
          cache;
        instance?(cache, <simple-typechecked-gf-cache-info>) =>
          let cache :: <simple-typechecked-gf-cache-info> = cache;
          simple-typechecked-gf-cache-info-argmask(cache);
        otherwise =>
          0;
      end case;
  if (m ~== 0) %ds-args-to-check-first(ds) := list(m) end;
end function;

//// Call site cache


define function handle-simple-call-site-cache-head-methods-computed
    (ds :: <dispatch-state>, cache, old :: <cache-header-engine-node>)
 => (root-engine);
  let cache :: <gf-cache-info> = upgrade-to-basic-gf-cache-info(cache, ds);
  track-cache-header-engine-node(old, cache);
  let oengine = cache-header-engine-node-next(old) | $absent-engine-node;
  let nengine = walk-existing-dispatch-engine(ds, oengine, walk-existing-dispatch-engine);
  if (oengine ~== nengine)
    install-cache-header-engine-node-next(old, nengine, %ds-gf(ds));
    subst-engine-node(nengine, oengine, ds);
  end if;
  nengine
end function;

define function handle-simple-call-site-cache-head
    (ds :: <dispatch-state>, cache, old :: <cache-header-engine-node>)
 => (root-engine);
  compute-headed-methods(ds);
  handle-simple-call-site-cache-head-methods-computed(ds, cache, old);
end function;

//// Profiling Header

define function handle-profiling-call-site-cache-head
    (ds :: <dispatch-state>, cache, old :: <cache-header-engine-node>)
 => (root-engine);
  compute-headed-methods(ds);
  handle-simple-call-site-cache-head-methods-computed(ds, cache, old)
end function;


//// Unknown handler

define function handle-unknown-cache-head
  (ds :: <dispatch-state>, cache, old :: <cache-header-engine-node>)
  => ();
  dispwarn(make(<simple-warning>,
                format-string: "Unhandled g.f. cache for %= - %=",
                format-arguments: vector(%ds-gf(ds), old)),
           ds);
  cache-header-punt(ds, cache, old)
end function;


define function find-or-create-common-cache-header
    (gf :: <generic-function>) => (res :: <common-root-cache-header-engine-node>)
  let d = discriminator(gf);
  if (instance?(d, <common-root-cache-header-engine-node>))
    d
  else
    let new :: <common-root-cache-header-engine-node>
      = bootstrap-typed-allocate-engine-node(<common-root-cache-header-engine-node>,
                                             engine-node$k-cache-header,
                                             0);
    primitive-initialize-engine-node(new);
    cache-header-engine-node-parent(new) := gf;
    install-cache-header-engine-node-next(new, d, gf);
    discriminator(gf) := new;
    new
  end if
end function;

define function cache-header-punt (ds :: <dispatch-state>, cache, e :: <cache-header-engine-node>)
 => ()
  let cache :: <gf-cache-info> = upgrade-to-basic-gf-cache-info(cache, ds);
  track-cache-header-engine-node(e, cache);
  let root = find-or-create-common-cache-header(%ds-gf(ds));
  install-cache-header-engine-node-next(e, root, %ds-gf(ds))
end function;



//define function make-simple-typechecked-gf-cache-info (m :: <integer>)
// => (c :: <simple-typechecked-gf-cache-info>);
//  let c :: <simple-typechecked-gf-cache-info>
//    = system-allocate-simple-instance(<simple-typechecked-gf-cache-info>);
//  gf-cache-info-users(c) := make(<simple-object-vector>,
//                                 size: $cache-header-engine-node-users-increment,
//                                 fill: #f);
//  simple-typechecked-gf-cache-info-argmask(c) := m;
//  simple-typechecked-gf-cache-info-entries(c)
//    := make(<simple-object-vector>,
//            size: 1 + compress-mask(m, m), // What a crappy way to do logcount.
//            fill: #f);
//  c
//end function;


define function handle-simple-typechecked-cache-head
  (ds :: <dispatch-state>, cache, old :: <simple-typechecked-cache-header-engine-node>)
  => ();
  compute-headed-methods(ds);
  let cache :: <simple-typechecked-gf-cache-info>
    = upgrade-to-simple-typechecked-gf-cache-info(cache, ds);
  let checkedmask :: <integer> = stchen-checkedmask(old);
  let argmask :: <integer> = simple-typechecked-gf-cache-info-argmask(cache);
  let idx :: <integer> = compress-mask(argmask, checkedmask);
  let entries :: <simple-object-vector> = simple-typechecked-gf-cache-info-entries(cache);
  let nentries :: <integer> = size(entries);
  if (idx + 1 == nentries) track-cache-header-engine-node(old, cache) end;
  let gf :: <generic-function> = %ds-gf(ds);
  install-cache-header-engine-node-next
    (old,
     element(entries, idx)
       | (begin
            if (~entries[nentries - 1])
              ensure-engine-for-simple-typechecked-gf-cache(checkedmask, ds);
              if (~entries[nentries - 1]) error("gf caching is hosed") end;
            end;
            find-or-install-simple-typechecked-cache
              (idx, argmask, checkedmask, entries,
               head(tail(%ds-headed-methods(ds))), gf)
          end),
     gf)
end function;


define function find-or-install-simple-typechecked-cache (idx :: <integer>,
                                                          argmask :: <integer>,
                                                          checkedmask :: <integer>,
                                                          cachev :: <simple-object-vector>,
                                                          proto :: <method>,
                                                          gf :: <generic-function>)
  element(cachev, idx)
    | (element(cachev, idx)
         := if (argmask == checkedmask)
              error("Find-or-install-simple-typechecked-cache didn't find all-checked state!")
            else
              // Iterate over all the masks which have one more bit set than checkedmask,
              // in case there is already discrimination engine defined that we can share
              // with.  If we find one, we use that as the target of a typecheck-discriminator.
              // If not, pick one, and recurse.
              let (target, argnum :: <integer>)
                = begin
                    local method loop (m :: <integer>, bitnum :: <integer>, firstargnum)
                            if (m == 0)
                              let firstargnum :: <integer> = firstargnum | error("I'm in trouble!");
                              let ncheckedmask = logior(ash(1, firstargnum), checkedmask);
                              let nidx :: <integer> = compress-mask(argmask, ncheckedmask);
                              values(find-or-install-simple-typechecked-cache
                                       (nidx, argmask, ncheckedmask, cachev, proto, gf),
                                     firstargnum)
                            elseif (logbit?(0, m) & ~logbit?(bitnum, checkedmask))
                              let e? = element(cachev, compress-mask
                                                 (argmask, logior(ash(1, bitnum), checkedmask)));
                              if (e?)
                                values(e?, bitnum)
                              else
                                loop(ash(m, -1), bitnum + 1, firstargnum | bitnum)
                              end if
                            else
                              loop(ash(m, -1), bitnum + 1, firstargnum)
                            end if
                          end method;
                    loop(argmask, 0, #f)
                  end;
              make-typecheck-discriminator(argnum, gf, %method-specializer(proto, argnum), target)
            end if)
end function;


define function ensure-engine-for-simple-typechecked-gf-cache
    (checkedmask :: <integer>, ds :: <dispatch-state>)
  let cache :: <simple-typechecked-gf-cache-info> = %ds-cache(ds);
  let argmask :: <integer> = simple-typechecked-gf-cache-info-argmask(cache);
  let cachevec :: <simple-object-vector> = simple-typechecked-gf-cache-info-entries(cache);
  let nentries :: <integer> = size(cachevec);
  %ds-args-to-check-first(ds)
    := if (argmask == checkedmask)
         list(argmask)
       else
         list(checkedmask, logand(argmask, lognot(checkedmask)))
       end if;
  compute-dispatch-from-root(ds, %ds-gf(ds));
  local method lose (desc, datum)
          let gf :: <generic-function> = %ds-gf(ds);
          let default = discriminator(gf);
          for (i from 0 below nentries) if (~cachevec[i]) cachevec[i] := default end; end;
          dispwarn(make(<simple-warning>,
                        format-string: "For dispatch on %= with args %=, encountered %s %= unexpectedly.",
                        format-arguments: vector(gf, reconstruct-args-from-mepargs(gf, %ds-args(ds)),
                                                 desc, datum)),
                   ds);
        end method;
  let masque-so-far :: <integer> = 0;
  local method walk (ds :: <dispatch-state>, x, callback :: <function>)
          let msf :: <integer> = masque-so-far;
          cachevec[compress-mask(argmask, msf)] := x;
          // The weird checking order here is to force us to keep iterating until we get
          // past multiple discriminators which check on the same argument.
          if (instance?(x, <discriminator>))
            let x :: <discriminator> = x;
            let argnum :: <integer> = discriminator-argnum(x);
            if (argnum < $simple-typechecked-cache-arguments-limit & logbit?(argnum, argmask))
              if (~logbit?(argnum, msf)) masque-so-far := logior(msf, ash(1, argnum)) end;
              walk-existing-dispatch-engine(ds, x, callback)
            elseif (msf ~== argmask)
              lose("discriminator on arg", argnum);
              x
            else
              x
            end if
          else
            if (msf ~== argmask) lose("non-discriminator", x) end;
            x
          end if
        end method;
  walk(ds, discriminator(%ds-gf(ds)), walk)
end function;


define constant $profile-count-low-slot-offset  = 5;
define constant $profile-count-high-slot-offset = 6;

define inline-only function %profile-count-low (di :: <profiling-call-site-cache-header-engine-node>)
 => (low :: <machine-word>)
  primitive-wrap-machine-word
    (primitive-cast-pointer-as-raw
       (primitive-initialized-slot-value(di, integer-as-raw($profile-count-low-slot-offset))))
end function %profile-count-low;

define inline-only function %profile-count-low-setter
    (new-low :: <machine-word>, di :: <profiling-call-site-cache-header-engine-node>)
  primitive-slot-value(di, integer-as-raw($profile-count-low-slot-offset))
    := primitive-cast-raw-as-pointer(primitive-unwrap-machine-word(new-low));
end function %profile-count-low-setter;

define inline-only function %profile-count-high (di :: <profiling-call-site-cache-header-engine-node>)
 => (high :: <machine-word>)
  primitive-wrap-machine-word
    (primitive-cast-pointer-as-raw
       (primitive-initialized-slot-value(di, integer-as-raw($profile-count-high-slot-offset))))
end function %profile-count-high;

define inline-only function %profile-count-high-setter
    (new-high :: <machine-word>, di :: <profiling-call-site-cache-header-engine-node>)
  primitive-slot-value(di, integer-as-raw($profile-count-high-slot-offset))
    := primitive-cast-raw-as-pointer(primitive-unwrap-machine-word(new-high));
end function %profile-count-high-setter;

define variable *profile-all-terminal-engine-nodes?* = #f;

define function profile-all-terminal-engine-nodes? () => (well?)
  *profile-all-terminal-engine-nodes?*
end function;

define function profile-all-terminal-engine-nodes?-setter (well?)
  *profile-all-terminal-engine-nodes?* := well?
end function;