reduce-historical/psl-1983/util/hcons.sl

% HCONS.SL -   Hashing (unique) CONS and associated utilities.
%
% Author:      William Galway
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        Wednesday, 2 June 1982
% Copyright (c) 1982 University of Utah
%
(BothTimes       % ?? Compile time may suffice.
  (load useful)
  (load fast-vector))

% Summary of "user level" functions provided:
% (DM Hcons (X) ...)  % Nary hashed cons, right associative.
% (DN Hlist (X) ...)  % Hcons version of "list" function.

% Hcons version of "copy" function.  Note that unlike copy, this is not
% guaranteed to create a new copy of a structure. (In fact, rather the
% opposite.)
% (DE Hcopy (lst) ...)

% (DE Happend (U V) ...) % Hcons version of "append" function.
% (DE Hreverse (U) ...)  % Hcons version of "reverse" function.

% Pairs for property list functions must be created by Hcons.
% Get property of id or pair.
% (DE extended-get (id-or-pair  indicator) ...)
% Put property of id or pair.  Known to setf.
% (DE extended-put (id-or-pair indicator val) ...)


% Number of hash "slots" in table, should be a prime number to get an even
% spread of hits (??).  This package has been written so that it should be
% possible to modify this size at runtime (I hope).  So if the hash-tables
% get too heavily loaded they can be copied to larger ones.
(DefConst hcons-table-size 103)

% Build the two tables (we switch from one to the other on each garbage
% collection.  Note that (MkVect 1) gives TWO locations.
(setf hash-cons-tables (MkVect 1))

(setf (IGetV hash-cons-tables 0)
  (MkVect (sub1 (const hcons-table-size))))

(setf (IGetV hash-cons-tables 1)
  (MkVect (sub1 (const hcons-table-size))))

% current-table-number switches between 0 and one at each garbage
% collection--selecting the current table to use.
(setf current-table-number 0)

(DE next-table-number (table-number)
  (cond
    ((equal table-number 0) 1)
    (T 0)))

% Should really use structs for this, but I'm unsure on the exact details
% of how structs work, and it's very important to understand how much free
% space will be demanded by any routines that are called.
% Anyway, each location in a "hash table" is either NIL, or an "entry",
% where an entry is implemented as a vector of
% [ <dotted-pair>  <property-list-for-pair>  <next-entry-in-chain> ]

% This should be done differently too.
(DefConst entry-size 4)  % The size of an entry in "heap units"??
(DefConst pair-size 2)   % Similarly for pairs.

(DS create-hash-entry ()
  % Create a 3 element vector.
  (MkVect 2))

(DS pair-info (ent)
  (IGetV ent 0))

(DS prop-list-info (ent)
  (IGetV ent 1))

(DS next-entry (ent)
  (IGetV ent 2))

% Finds a location within a "hash table", for a pair (X,Y).
% This version is very simpleminded!
(DS hcons-hash-function (htable X Y)
  (remainder
    % Take absolute value to avoid sign problems with remainder.
    (abs (plus (Sys2Int X) (Sys2Int Y)))
    (add1 (ISizeV htable))))

% Copy entries from one "hash cons table" to another, setting the source
% table to all NILs.  Return the dst-table, as well as copying into it.
% This routine is used to place entries in their new locations after a
% garbage collection.  This routine MUST NOT allocate anything on the heap.
(DE move-hcons-table (src-table  dst-table)
  (prog (dst-index src-entry src-pair nxt-entry)
    (for (from src-index 0 (ISizeV src-table) 1)
      (do
        (progn
          (setf src-entry (IGetV src-table src-index))
          % Use GetV here, until "the bug" in IGetV gets fixed.
          (setf (GetV src-table src-index) NIL)
          (while src-entry
            (progn
                (setf src-pair (pair-info src-entry))
                (setf dst-index
                  (hcons-hash-function
                    dst-table
                    (car src-pair) (cdr src-pair)))
                % Save the next entry in the the chain, and then relink the
                % current entry into its new location.
                (setf nxt-entry (next-entry src-entry))
                (setf (next-entry src-entry)
                  (IGetV dst-table dst-index))
                (setf (IGetV dst-table dst-index) src-entry)
                % Move to next thing in chain.
                (setf src-entry nxt-entry))))))

    (return dst-table)))

% Nary version of hashed cons.
(DM Hcons (X)
  (RobustExpand (cdr X)  'hcons2  NIL))

% Binary "hashed" cons of X and Y, returns pointer to previously
% constructed pair if it can be found in the hash table.
(DE Hcons2 (X Y)
  (prog (hashloc hitchain tmpchain newpair newentry)
    (setf hashloc (hcons-hash-function
                    (IGetV hash-cons-tables current-table-number)
                    X Y))

    % Get chain of entries at the appropriate hash location in the
    % appropriate table.
    (setf hitchain (IGetV
                     (IGetV hash-cons-tables current-table-number)
                     hashloc))

    % Search for a previously constructed pair, if any, with car and cdr
    % equal to X and Y respectively.
    % Note that tmpchain is not a list, but a "chain" of "entries".
    (setf tmpchain hitchain)
    (while (and tmpchain
             % Keep searching unless an exact match is found.
             (not (and
                    % EqN test might be better, so that we handle numbers
                    % intelligently?  Probably have to worry about hash
                    % code also.
                    (eq X (car (setf newpair (pair-info tmpchain))))
                    (eq Y (cdr newpair)))))
      % do
      (setf tmpchain (next-entry tmpchain)))

    (cond
      % If no entry was found, create a new one.
      ((null tmpchain)
        (progn
          % We need enough room for one new pair, plus one new entry.  If
          % there isn't enough room on the heap then collect garbage (and
          % in the process move EVERYTHING around, switch hash tables,
          % etc.)
          (cond
            ((LessP
               (GtHeap NIL)      % Returns free space in heap.
               (plus (const pair-size) (const entry-size)))
              (progn
                (reclaim)
                % Recalculate locations of everything.
                (setf hashloc
                  (hcons-hash-function
                    (IGetV hash-cons-tables current-table-number)
                    X Y))

                % Get chain of entries at the appropriate hash location in
                % the appropriate table.
                (setf hitchain
                  (IGetV
                    (IGetV hash-cons-tables current-table-number)
                    hashloc)))))

          % Allocate the new pair, store information into the appropriate
          % spot in appropriate table.
          (setf newpair (cons X Y))
          (setf newentry (create-hash-entry))

          (setf (pair-info newentry) newpair)
          (setf (prop-list-info newentry) NIL)
          (setf (next-entry newentry) hitchain)
          % Link the new entry into the front of the table.
          (setf
            (IGetV
              (IGetV hash-cons-tables current-table-number)
              hashloc)
            newentry))))

    % Return the pair (either newly constructed, or old).
    (return newpair)))

% "hcons" version of "list" function.
(DN Hlist (X)
  (do-hlist X))

(DE do-hlist (X)
  (cond
    ((null X) NIL)
    (T (hcons (car X) (do-hlist (cdr X))))))

% "hcons" version of copy.  Note that unlike copy, this is not guaranteed
% to create a new copy of a structure. (In fact, rather the opposite.)
(DE Hcopy (lst)
  (cond
    ((not (pairp lst)) lst)
    (T (hcons (hcopy (car lst))  (hcopy (cdr lst))))))

% "hcons" version of Append function.
(DE Happend (U V)
  (cond
    % First arg is NIL, or some other non-pair.
    ((not (PairP U)) V)
    % else ...
    (T (hcons (car U) (Happend (cdr U) V)))))

% Hcons version of Reverse.
(DE Hreverse (U)
  (prog (V)
    (while (PairP U)
      (progn
        (setf V (hcons (car U) V))
        (setf U (cdr U))))
    (return V)))

% Look up and return the entry for a pair, if any.  Return NIL if argument
% is not a pair.
(DE entry-for-pair (p)
  (cond
    ((PairP p)
      (prog (hashloc ent)
        (setf hashloc
          (hcons-hash-function
            (IGetV hash-cons-tables current-table-number)
            (car p) (cdr p)))

        % Look at appropriate spot in hash table.
        (setf ent
          (IGetV (IGetV hash-cons-tables current-table-number) hashloc))
                    
        % Search through chain for p.
        (while (and ent
                 (not (eq (pair-info ent) p)))
          (setf ent (next-entry ent)))

        % Return the entry, or NIL if none found.
        (return ent)))))

% Get a property for a pair or identifier.  Only pairs stored in the hash
% table have properties.
(DE extended-get (id-or-pair  indicator)
  (cond
    ((IdP id-or-pair) (get id-or-pair indicator))

    ((PairP id-or-pair)
      (prog (proplist prop-pair)
        (setf proplist (pair-property-list id-or-pair))
        (setf prop-pair (atsoc indicator proplist))
        (return
          (cond
            ((PairP prop-pair) (cdr prop-pair))))))))

% Put function for pairs and identifiers.  Only pairs in the hash table can
% be  given properties.  (We are very sloppy about case when pair isn't in
% table, but hopefully the code won't blow up.)  "val" is returned in all
% cases.
(DE extended-put (id-or-pair indicator val)
  (cond
    ((IdP id-or-pair) (put id-or-pair indicator val))

    ((PairP id-or-pair)
      (prog (proplist prop-pair)
        (setf proplist (pair-property-list id-or-pair))
        % Get the information (if any) stored under the indicator.
        (setf prop-pair (Atsoc indicator proplist))
        (cond
          % Modify the information under the indicator, if any.
          ((PairP prop-pair)
            (setf (cdr prop-pair) val))

          % Otherwise (nothing found under indicator), create new
          % (indicator . value) pair.
          (T
            (progn
              % Note use of cons, not Hcons, WHICH IS RIGHT? (I think cons.)
              (setf prop-pair (cons indicator val))
              % Tack new (indicator . value) pair onto property list, and
              % store in entry for the pair who's property list is being
              % hacked.
              (set-pair-property-list
                id-or-pair (cons prop-pair proplist)))))

        % We return the value even if the pair isn't in the hash table.
        (return val)))))

(PUT 'extended-get 'assign-op 'extended-put)
(FLAG '(extended-get) 'SETF-SAFE)

% Return the "property list" associated with a pair.
(DE pair-property-list (p)
  (prog (ent)
    (setf ent (entry-for-pair p))
    (return
      (cond
        (ent (prop-list-info ent))
        (T NIL)))))

% Set the "property list" cell for a pair, return the new "property list".
(DE set-pair-property-list (p val)
  (prog (ent)
    (setf ent (entry-for-pair p))
    (return
      (cond
        (ent (setf (prop-list-info ent) val))
        (T NIL)))))

% We redefine the garbage collector so that it rebuilds the hash table
% after garbage collection has moved everything.
(putd 'original-!%Reclaim (car (getd '!%Reclaim)) (cdr (getd '!%Reclaim)))

% New version of !%reclaim--shuffles stuff in cons tables after collecting
% garbage.
(DE !%Reclaim ()
  (prog1
    (original-!%Reclaim)

    % Move the old table to the new one, shuffling everything into its
    % correct position.
    (move-hcons-table
      % Would use IGetV, but there appears to be a bug preventing it from
      % working.
      % Source
      (GetV hash-cons-tables current-table-number)
      % Destination
      (GetV hash-cons-tables
          (next-table-number current-table-number)))

    % Point to new "current-table".
    (setf current-table-number
      (next-table-number current-table-number))))