;;; -*- mode:lisp; base:10.; package:user; fonts:(cptfontb) -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Polly -- the Sweet Polly Purebred consing package. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Functions are provided here that will generate "pure" cons ;;; cells in Franz Lisp. Such conses do not "disturb" the garbage ;;; collector, ie., they are not "swept". NB: There is uncertainty as ;;; to whether such objects can come back "read-only" after dumplisp. ;;; $Header: /ct/ctlisp/polly.l,v 1.11 84/01/06 10:00:18 john Exp $ ;;; $Log: /ct/ctlisp/polly.l,v $ ;;;Revision 1.11 84/01/06 10:00:18 john ;;;Rearranged order of pure-append, pure-append2 ;;; ;;;Revision 1.10 84/01/05 09:34:48 john ;;;Added new definition for pure-append that takes N arguments ;;;instead of just two. ;;; ;;;Revision 1.9 84/01/04 06:04:48 mark ;;;Improved the hunks stuff so that it would not need as many ;;;re-cycle-able scratch hunks. Cleaned up a few other things, ;;;such as unnecessary rplac-ing in pure-cons. Documented the ;;;fact that pure-putprop on atoms on the LISPM does not go in ;;;the permanent-storage-area. Removed an unnecessary specbind ;;;from pure-make-array. Declared some things localf. etc. ;;; ;;;Revision 1.8 83/12/07 19:00:21 penny ;;;Even more lossage. ;;; ;;;Revision 1.7 83/12/07 17:53:53 penny ;;;Oh {expletive deleted}, don't even ask, lossage on all fronts. ;;; ;;;Revision 1.6 83/12/07 13:02:31 penny ;;;Removed redundant dependencies. ;;; ;;;Revision 1.5 83/12/06 15:17:13 john ;;;Added pure-hunk, pure-makhunk for franz, pure-make-array for zetalisp. ;;; ;;;Revision 1.4 83/11/01 09:10:22 john ;;;Fixed pure-putprop to not be fooled by values that look ;;;like indicators. It always returns the value now. Finally, ;;;it will turn an impure property into a pure one. ;;; ;;;Revision 1.3 83/10/31 20:31:04 bill ;;;Fixed pure-cons pure-append and pure-putprop. ;;;Added ct_loads on aip and compat so that we can compile bare. ;;; ;;;Revision 1.2 83/10/28 07:53:55 john ;;;Checking in Frozen this time. ;;; ;;;Revision 1.1 83/10/28 07:52:01 john ;;;Initial revision ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Dependencies on Other Files ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; We don't really need these -- ;;; (eval-when (compile load eval) (ct_load 'compat)) ;;; (eval-when (compile load eval) (ct_load 'aip)) #+franz (eval-when (compile load eval) (ct_load 'lispmloop)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Missing From the LISPM {Truly Amazing} ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+lispm ;;;;; (defun purep (ptr) ;;;;; ;;; Provided for compatibility with Franz. Purep is true if ;;; the cons {or array or etc.} is in the permanent-storage-area, ;;; which is a static area. (eq (area-name (%area-number ptr)) 'permanent-storage-area)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Constants and Such ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+franz (declare (special *simon-foo-sinister* ;Recycle-able pure cons. *simon-bar-sinister* ;Recycle-able impure cons. *rawhunks*)) ;Recycle-able impure hunks. ;;; Note: *simon-foo-sinister* is initialized below, after pure-cons. #+franz ;;;;;;;;;;;;;;;;;;;; (setq *simon-bar-sinister* ;;;;;;;;;;;;;;;;;;;; ;;; A single cons in regular space that we use to copy into ;;; pure space. This cons gets used over and over... (cons nil nil)) ;;; Note: *rawhunks* is initialized below, above pure-raw-hunk. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The Main POLLY External Functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The Lisp Machine has a great advantage; it can cons stuff in ;;; any area desired. In Franz, it is much harder: we must copy ;;; things from regular space to pure space. ;;; **************** ;;; CONS ;;; **************** ;;;;;;;;; (defun pure-cons (car cdr) ;;;;;;;;; ;;; Modified to copy a bare cons. Before, was copying a cons and ;;; all it pointed to. #+lispm (cons-in-area car cdr permanent-storage-area) #+franz (let ((it (purcopy *simon-bar-sinister*))) ;;; (rplaca *simon-bar-sinister* nil) ;;; deleted, mlm {unnecessary} ;;; (rplacd *simon-bar-sinister* nil) ;;; deleted, mlm {unnecessary} (rplaca it car) (rplacd it cdr))) ;;; **************** ;;; LIST ;;; **************** ;;;;;;;;; (defun pure-list (&rest args) ;;;;;;;;; #+lispm (lexpr-funcall #'list-in-area permanent-storage-area args) #+franz (loop with new = (pure-cons nil nil) with tail = new for arg on args do (rplaca tail (car arg)) ;;Install this element. unless (null (cdr arg)) do (progn (rplacd tail (pure-cons nil nil)) ;;Make room for next. (setq tail (cdr tail))) ;;Move the tail down. finally (return new))) ;;; **************** ;;; APPEND ;;; **************** #+lispm ;;;;;;;;;;; (defun pure-append (&rest lists) ;;;;;;;;;;; (let ((default-cons-area permanent-storage-area)) (apply #'append lists))) ;;; Pure appends exactly two things together. THis function for internal ;;; use only. #+franz (declare (localf pure-append2)) #+franz (defun pure-append2 (list1 list2) (cond ;; If the first list is nil, just return the second ((null list1) list2) ;; Otherwise, recurse down the elements of the first list. (t (pure-cons (car list1) (pure-append2 (cdr list1) list2))))) ;;; New version of pure-append. Works for any number of arguments, and ;;; correctly solves (pure-append nil nil) #+franz (defun pure-append (&rest lists) (cond ;; If there is only one list, just return it. ((null (cdr lists)) (car lists)) ;; Otherwise, break this down. (t (pure-append2 (car lists) (apply #'pure-append (cdr lists)))))) ;;; **************** ;;; PUTPROP ;;; **************** ;;; This specvar needed by Franz for pure-putprop, for obscure reasons. #+franz (setq *simon-foo-sinister* (pure-cons nil nil)) #+franz (declare (localf int-pure-putprop)) ;;Internal use only. ;;;;;;;;;;;; (defun pure-putprop (plist val propnam) ;;;;;;;;;;;; #+lispm ;;; NB: In the case of property lists on atoms, pure-putprop does ;;; not actually "do the right thing" on the LISPM, because these are ;;; normally kept in a special area {sys:property-list-area}. We ;;; could probably fix this eventually {the source code for putprop ;;; is readable enough}, but it would require some care. For ;;; example, after a full-GC, the special property-list area comes ;;; back CDR-coded. We could lose badly if we ignored this issue. ;;; Hence, pure-putprop is harmlessly equivalent to putprop on the ;;; LISPM in this case. It does the right thing with free property ;;; lists, however. The following code avoids doing the specbind ;;; in the case where it isn't going to work anyway. -- mlm (cond ((symbolp plist) (putprop plist val propnam)) ;Punt, avoid specbind. (t (let ((default-cons-area permanent-storage-area)) ;Win. (putprop plist val propnam)))) #+franz ;;; This version works by identifying the internal property list, ;;; modifying it, and replacing it. (cond ((symbolp plist) (setplist plist (int-pure-putprop (plist plist) val propnam))) (t (rplacd plist (int-pure-putprop (cdr plist) val propnam)))) #+franz ;Putprop should return val. val) #+franz ;;;;;;;;;;;;;;;; (defun int-pure-putprop (intlist val ind) ;;;;;;;;;;;;;;;; ;;; This will modify the property list correctly. If a property ;;; already exists, and is implemented with NON-pure conses, they ;;; will be replaced with pure conses. The expense, one cons per ;;; putprop, is negligible. (rplacd *simon-foo-sinister* intlist) ;;; Careful -- cannot use memq since ind might be the same as a value. (let ((thing (loop for tail on *simon-foo-sinister* by #'cddr until (eq (cadr tail) ind) finally (return tail)))) (cond ;; If already there and pure, just replace -- ((and thing (purep (cdr thing))) (rplaca (cddr thing) val)) (thing ;; Already there, but impure -- fix up -- (rplacd thing (pure-cons ind (pure-cons val (cdddr thing))))) (t (rplacd *simon-foo-sinister* ;;Not there yet -- (pure-cons ind ;;add it on the front, (pure-cons val ;;for quicker access. (cdr *simon-foo-sinister*))))))) (cdr *simon-foo-sinister*)) ;;; ******************* ;;; HUNKS -- FRANZ ONLY ;;; ******************* ;;; NB: This stuff has been very carefully written, comparing ;;; against the Franz C- and LISP-coded primitives. Please do ;;; not "extend" or "generalize" this stuff without good reason, ;;; since a lot of other code (eg., Chunks, Diana) relies on this ;;; being a set of very efficient, low-level interfaces. --mlm #+franz ;;;;;;;;;; (setq *rawhunks* ;So can index into these. ;;;;;;;;;; ;;; The repository for impure scratch hunks, used only in Franz. ;;; Rewritten by Mark to use fewer sample hunks, relying on the ;;; fact that, in Franz, only powers of two are actually allocated. ;;; The specvar is needed to enable recycling the raw impure hunks ;;; that are required for purcopy-ing. It is NOT referred to out- ;;; side of this file. ;;; NB: Use of *makhunk is not encouraged by the Franz manual. ;;; However, it is used very carefully here, and enables us to avoid ;;; consing up hunks of all possible sizes between 1 and 128. ;;; We could have provided an option of not initializing the sizes ;;; that aren't being used, but the space savings is relatively small ;;; and the cost and complexity of having to check is not worth it. (hunk (*makhunk 0) ;;For pure hunks of 1 or 2 elements. (*makhunk 1) ;;For pure hunks of 3 or 4 elements. (*makhunk 2) ;;For pure hunks of 5 thru 8 elements. (*makhunk 3) ;;For pure hunks of 9 thru 16 elements. (*makhunk 4) ;;For pure hunks of 17 thru 32 elements. (*makhunk 5) ;;For pure hunks of 33 thru 64 elements. (*makhunk 6))) ;;For pure hunks of 65 thru 128 elements. #+franz (declare (localf pure-raw-hunk)) #+franz ;;;;;;;;;;;;; (defun pure-raw-hunk (size) ;;;;;;;;;;;;; ;;; NB: This is a very low-level interface, provided only for ;;; within this file itself. Given a size in [1, 128.], returns ;;; a raw, uninitialized hunk in pure space. The caller must ;;; then use *rplacx to initialize elements. The ACTUAL space ;;; used will be to the nearest power of two. The APPARENT size ;;; will be 1+ the largest index'd element initialized. (purcopy (cxr (cond ((= size 1) 0) (t (1- (haulong (1- size))))) *rawhunks*))) #+franz ;;;;;;;;;;;;;;;;; (defun pure-hunk-of-nils (size) ;;;;;;;;;;;;;;;;; ;;; NB: The use of *rplacx is not encouraged by the Franz manual, ;;; but the usage here is in keeping with the letter and spirit. (do ((h (pure-raw-hunk size)) (i 0 (1+ i))) ((= i size) h) (declare (fixnum i)) (*rplacx i h nil))) #+franz ;;;;;;;;;;;;;;;;;;; (defun impure-hunk-of-nils (size) ;;;;;;;;;;;;;;;;;;; ;;; An impure version, provided for convenience and parallelism of ;;; construction. Maybe slightly more efficient than (makhunk size). ;;; Note that the use of *makhunk and *rplacx are not encouraged by ;;; the Franz manual, but the usage here is in keeping with its intent. (do ((h (*makhunk (cond ((= size 1) 0) (t (1- (haulong (1- size))))))) (i 0 (1+ i))) ((= i size) h) (declare (fixnum i)) (*rplacx i h nil))) #+franz ;;;;;;;;; (defun pure-hunk (&rest args) ;;;;;;;;; ;;; Pure-hunk returns a hunk in pure space. It accepts any number ;;; of arguments from 1 to 128 and creates that size hunk. Indexing ;;; ranges from 0 to 127. Actually storage utilization is to the ;;; next-higher power of two. (let* ((l (length args)) (h (pure-raw-hunk l))) (declare (fixnum l)) (do ((i 0 (1+ i)) (tail args (cdr tail))) ((= i l) h) (*rplacx i h (car tail))))) #+franz ;;;;;;;;;;;; (defun pure-makhunk (num-or-lst) ;;;;;;;;;;;; (cond ((listp num-or-lst) (apply #'pure-hunk num-or-lst)) (t (pure-hunk-of-nils num-or-lst)))) ;;; **************** ;;; ARRAYS ;;; **************** ;;; Create a pure-array -- currently for LM only. #+lispm ;;;;;;;;;;;;;;; (defun pure-make-array (dims &rest args) ;;;;;;;;;;;;;;; (lexpr-funcall #'make-array dims ':area permanent-storage-area args)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; eof ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;