diff --git a/pcl/compat.lisp b/pcl/compat.lisp deleted file mode 100644 index 606915388599787e139609db4539d203cf61bca7..0000000000000000000000000000000000000000 --- a/pcl/compat.lisp +++ /dev/null @@ -1,31 +0,0 @@ -;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. -;;; All rights reserved. -;;; -;;; Use and copying of this software and preparation of derivative works -;;; based upon this software are permitted. Any distribution of this -;;; software or derivative works must comply with all applicable United -;;; States export control laws. -;;; -;;; This software is made available AS IS, and Xerox Corporation makes no -;;; warranty about the software, its performance or its conformity to any -;;; specification. -;;; -;;; Any person obtaining a copy of this software is requested to send their -;;; name and post office or electronic mail address to: -;;; CommonLoops Coordinator -;;; Xerox PARC -;;; 3333 Coyote Hill Rd. -;;; Palo Alto, CA 94304 -;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) -;;; -;;; Suggestions, comments and requests for improvements are also welcome. -;;; ************************************************************************* -;;; - -(in-package :pcl) - -() - diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp index 3f8c49bfb67ecbc464412dd741feb5d37656abca..cb5db3e00ce07016902d9abce2efde88069341ee 100644 --- a/pcl/defsys.lisp +++ b/pcl/defsys.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.25 2002/08/26 02:23:12 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.26 2002/08/26 02:40:55 pmai Exp $") ;;; ;;; Some support stuff for compiling and loading PCL. It would be nice if ;;; there was some portable make-system we could all agree to share for a @@ -494,7 +494,6 @@ and load your system with: (ctypes t t (defclass defcombin)) (construct t t (defclass boot defs low)) (env t t (defclass boot defs low fin)) - (compat t t ()) (cmucl-documentation t t () CMU) (precom1 (dlisp) t (defs low cache fin dfun)) (precom2 (dlisp) t (defs low cache fin dfun)) diff --git a/pcl/dlap.lisp b/pcl/dlap.lisp deleted file mode 100644 index c9ecda9e89bc9170816c9831b10f0ada31342b48..0000000000000000000000000000000000000000 --- a/pcl/dlap.lisp +++ /dev/null @@ -1,611 +0,0 @@ -;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. -;;; All rights reserved. -;;; -;;; Use and copying of this software and preparation of derivative works -;;; based upon this software are permitted. Any distribution of this -;;; software or derivative works must comply with all applicable United -;;; States export control laws. -;;; -;;; This software is made available AS IS, and Xerox Corporation makes no -;;; warranty about the software, its performance or its conformity to any -;;; specification. -;;; -;;; Any person obtaining a copy of this software is requested to send their -;;; name and post office or electronic mail address to: -;;; CommonLoops Coordinator -;;; Xerox PARC -;;; 3333 Coyote Hill Rd. -;;; Palo Alto, CA 94304 -;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) -;;; -;;; Suggestions, comments and requests for improvements are also welcome. -;;; ************************************************************************* -;;; - -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/dlap.lisp,v 1.8 1999/05/30 23:13:57 pw Exp $") -;;; - -(in-package :pcl) - - - -(defun emit-one-class-reader (class-slot-p) - (emit-reader/writer :reader 1 class-slot-p)) - -(defun emit-one-class-writer (class-slot-p) - (emit-reader/writer :writer 1 class-slot-p)) - -(defun emit-two-class-reader (class-slot-p) - (emit-reader/writer :reader 2 class-slot-p)) - -(defun emit-two-class-writer (class-slot-p) - (emit-reader/writer :writer 2 class-slot-p)) - - - -(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p) - (let ((instance nil) - (arglist ()) - (closure-variables ()) - (field (first-wrapper-cache-number-index))) - ;;we need some field to do the fast obsolete check - (ecase reader/writer - (:reader (setq instance (dfun-arg-symbol 0) - arglist (list instance))) - (:writer (setq instance (dfun-arg-symbol 1) - arglist (list (dfun-arg-symbol 0) instance)))) - (ecase 1-or-2-class - (1 (setq closure-variables '(wrapper-0 index miss-fn))) - (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn)))) - (generating-lap closure-variables - arglist - (with-lap-registers ((inst t) ;reg for the instance - (wrapper t) - (cnv fixnum-vector) - (cache-no index)) ;reg for the cache no - (let ((index cache-no) ;This register is used - ;for different values at - ;different times. - (slots (and (null class-slot-p) - (allocate-register 'vector))) - (csv (and class-slot-p - (allocate-register t)))) - (prog1 (flatten-lap - (opcode :move (operand :arg instance) inst) ;get the instance - (opcode :std-instance-p inst 'std-instance) ;if not either std-inst - (opcode :fsc-instance-p inst 'fsc-instance) ;or fsc-instance then - (opcode :go 'trap) ;we lose - - (opcode :label 'fsc-instance) - (opcode :move (operand :fsc-wrapper inst) wrapper) - (and slots - (opcode :move (operand :fsc-slots inst) slots)) - (opcode :go 'have-wrapper) - - (opcode :label 'std-instance) - (opcode :move (operand :std-wrapper inst) wrapper) - (and slots - (opcode :move (operand :std-slots inst) slots)) - - (opcode :label 'have-wrapper) - (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv) - (opcode :move (operand :cref cnv field) cache-no) - (opcode :izerop cache-no 'trap) ;obsolete wrapper? - - (ecase 1-or-2-class - (1 (emit-check-1-class-wrapper wrapper 'wrapper-0 'trap)) - (2 (emit-check-2-class-wrapper wrapper 'wrapper-0 'wrapper-1 'trap))) - - (if class-slot-p - (flatten-lap - (opcode :move (operand :cvar 'index) csv) - (ecase reader/writer - (:reader (emit-get-class-slot csv 'trap inst)) - (:writer (emit-set-class-slot csv (car arglist) inst)))) - (flatten-lap - (opcode :move (operand :cvar 'index) index) - (ecase reader/writer - (:reader (emit-get-slot slots index 'trap inst)) - (:writer (emit-set-slot slots index (car arglist) inst))))) - - (opcode :label 'trap) - (emit-miss 'miss-fn)) - (when slots (deallocate-register slots)) - (when csv (deallocate-register csv)))))))) - - - -(defun emit-one-index-readers (class-slot-p) - (let ((arglist (list (dfun-arg-symbol 0)))) - (generating-lap '(field cache-vector mask size index miss-fn) - arglist - (with-lap-registers ((slots vector)) - (emit-dlap arglist - '(standard-instance) - 'trap - (with-lap-registers ((index index)) - (flatten-lap - (opcode :move (operand :cvar 'index) index) - (if class-slot-p - (emit-get-class-slot index 'trap slots) - (emit-get-slot slots index 'trap)))) - (flatten-lap - (opcode :label 'trap) - (emit-miss 'miss-fn)) - nil - (and (null class-slot-p) (list slots))))))) - -(defun emit-one-index-writers (class-slot-p) - (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)))) - (generating-lap '(field cache-vector mask size index miss-fn) - arglist - (with-lap-registers ((slots vector)) - (emit-dlap arglist - '(t standard-instance) - 'trap - (with-lap-registers ((index index)) - (flatten-lap - (opcode :move (operand :cvar 'index) index) - (if class-slot-p - (emit-set-class-slot index (dfun-arg-symbol 0) slots) - (emit-set-slot slots index (dfun-arg-symbol 0))))) - (flatten-lap - (opcode :label 'trap) - (emit-miss 'miss-fn)) - nil - (and (null class-slot-p) (list nil slots))))))) - - - -(defun emit-n-n-readers () - (let ((arglist (list (dfun-arg-symbol 0)))) - (generating-lap '(field cache-vector mask size miss-fn) - arglist - (with-lap-registers ((slots vector) - (index index)) - (emit-dlap arglist - '(standard-instance) - 'trap - (emit-get-slot slots index 'trap) - (flatten-lap - (opcode :label 'trap) - (emit-miss 'miss-fn)) - index - (list slots)))))) - -(defun emit-n-n-writers () - (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)))) - (generating-lap '(field cache-vector mask size miss-fn) - arglist - (with-lap-registers ((slots vector) - (index index)) - (flatten-lap - (emit-dlap arglist - '(t standard-instance) - 'trap - (emit-set-slot slots index (dfun-arg-symbol 0)) - (flatten-lap - (opcode :label 'trap) - (emit-miss 'miss-fn)) - index - (list nil slots))))))) - - - -(defun emit-checking (metatypes applyp) - (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))) - (generating-lap '(field cache-vector mask size emf miss-fn) - dlap-lambda-list - (emit-dlap (remove '&rest dlap-lambda-list) - metatypes - 'trap - (with-lap-registers ((emf t)) - (flatten-lap - (opcode :move (operand :cvar 'emf) emf) - (opcode :emf-call emf))) - (with-lap-registers ((miss-function t)) - (flatten-lap - (opcode :label 'trap) - (opcode :move (operand :cvar 'miss-fn) miss-function) - (opcode :jmp miss-function))) - nil)))) - -(defun emit-caching (metatypes applyp) - (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))) - (generating-lap '(field cache-vector mask size miss-fn) - dlap-lambda-list - (with-lap-registers ((emf t)) - (emit-dlap (remove '&rest dlap-lambda-list) - metatypes - 'trap - (flatten-lap - (opcode :emf-call emf)) - (with-lap-registers ((miss-function t)) - (flatten-lap - (opcode :label 'trap) - (opcode :move (operand :cvar 'miss-fn) miss-function) - (opcode :jmp miss-function))) - emf))))) - -(defun emit-constant-value (metatypes) - (let ((dlap-lambda-list (make-dlap-lambda-list metatypes nil))) - (generating-lap '(field cache-vector mask size miss-fn) - dlap-lambda-list - (with-lap-registers ((value t)) - (emit-dlap dlap-lambda-list - metatypes - 'trap - (flatten-lap - (opcode :return value)) - (with-lap-registers ((miss-function t)) - (flatten-lap - (opcode :label 'trap) - (opcode :move (operand :cvar 'miss-fn) miss-function) - (opcode :jmp miss-function))) - value))))) - - - -(defun emit-check-1-class-wrapper (wrapper cwrapper-0 miss-label) - (with-lap-registers ((cwrapper t)) - (flatten-lap - (opcode :move (operand :cvar cwrapper-0) cwrapper) - (opcode :neq wrapper cwrapper miss-label)))) ;wrappers not eq, trap - -(defun emit-check-2-class-wrapper (wrapper cwrapper-0 cwrapper-1 miss-label) - (with-lap-registers ((cwrapper t)) - (flatten-lap - (opcode :move (operand :cvar cwrapper-0) cwrapper) ;This is an OR. Isn't - (opcode :eq wrapper cwrapper 'hit-internal) ;assembly code fun - (opcode :move (operand :cvar cwrapper-1) cwrapper) ; - (opcode :neq wrapper cwrapper miss-label) ; - (opcode :label 'hit-internal)))) - -(defun emit-get-slot (slots index trap-label &optional temp) - (let ((slot-unbound (operand :constant *slot-unbound*))) - (with-lap-registers ((val t :reuse temp)) - (flatten-lap - (opcode :move (operand :instance-ref slots index) val) ;get slot value - (opcode :eq val slot-unbound trap-label) ;is the slot unbound? - (opcode :return val))))) ;return the slot value - -(defun emit-set-slot (slots index new-value-arg &optional temp) - (with-lap-registers ((new-val t :reuse temp)) - (flatten-lap - (opcode :move (operand :arg new-value-arg) new-val) ;get new value into a reg - (opcode :move new-val (operand :instance-ref slots index));set slot value - (opcode :return new-val)))) - -(defun emit-get-class-slot (index trap-label &optional temp) - (let ((slot-unbound (operand :constant *slot-unbound*))) - (with-lap-registers ((val t :reuse temp)) - (flatten-lap - (opcode :move (operand :cdr index) val) - (opcode :eq val slot-unbound trap-label) - (opcode :return val))))) - -(defun emit-set-class-slot (index new-value-arg &optional temp) - (with-lap-registers ((new-val t :reuse temp)) - (flatten-lap - (opcode :move (operand :arg new-value-arg) new-val) - (opcode :move new-val (operand :cdr index)) - (opcode :return new-val)))) - -(defun emit-miss (miss-fn) - (with-lap-registers ((miss-fn-reg t)) - (flatten-lap - (opcode :move (operand :cvar miss-fn) miss-fn-reg) ;get the miss function - (opcode :jmp miss-fn-reg)))) ;and call it - - - -(defun dlap-wrappers (metatypes) - (mapcar #'(lambda (x) (and (neq x 't) - (allocate-register t))) - metatypes)) - -(defun dlap-wrapper-moves (wrappers args metatypes miss-label slot-regs) - (gathering1 (collecting) - (iterate ((mt (list-elements metatypes)) - (arg (list-elements args)) - (wrapper (list-elements wrappers)) - (i (interval :from 0))) - (when wrapper - (gather1 - (emit-fetch-wrapper mt arg wrapper miss-label (nth i slot-regs))))))) - -(defun emit-dlap (args metatypes miss-label hit miss value-reg &optional slot-regs) - (let* ((wrappers (dlap-wrappers metatypes)) - (nwrappers (remove nil wrappers)) - (wrapper-moves (dlap-wrapper-moves wrappers args metatypes miss-label slot-regs))) - (prog1 (emit-dlap-internal nwrappers - wrapper-moves - hit - miss - miss-label - value-reg) - (mapc #'deallocate-register nwrappers)))) - -(defun emit-dlap-internal (wrapper-regs wrapper-moves hit miss miss-label value-reg) - (cond ((cdr wrapper-regs) - (emit-greater-than-1-dlap - wrapper-regs wrapper-moves hit miss miss-label value-reg)) - ((null value-reg) - (emit-1-nil-dlap - (car wrapper-regs) (car wrapper-moves) hit miss miss-label)) - (t - (emit-1-t-dlap - (car wrapper-regs) (car wrapper-moves) hit miss miss-label value-reg)))) - - - -(defun emit-1-nil-dlap (wrapper wrapper-move hit miss miss-label) - (with-lap-registers ((location index) - (primary index) - (cache-vector vector)) - (flatten-lap - wrapper-move - (opcode :move (operand :cvar 'cache-vector) cache-vector) - (with-lap-registers ((wrapper-cache-no index)) - (flatten-lap - (emit-1-wrapper-compute-primary-cache-location wrapper primary wrapper-cache-no) - (opcode :move primary location) - (emit-check-1-wrapper-in-cache cache-vector location wrapper hit) ;inline hit code - (opcode :izerop wrapper-cache-no miss-label))) - (with-lap-registers ((size index)) - (flatten-lap - (opcode :move (operand :cvar 'size) size) - (opcode :label 'loop) - (opcode :move (operand :i1+ location) location) - (opcode :fix= location primary miss-label) - (opcode :fix= location size 'set-location-to-min) - (opcode :label 'continue) - (emit-check-1-wrapper-in-cache cache-vector location wrapper hit) - (opcode :go 'loop) - (opcode :label 'set-location-to-min) - (opcode :izerop primary miss-label) - (opcode :move (operand :constant (index-value->index 0)) location) - (opcode :go 'continue))) - miss))) - -;;; -;;; The function below implements CACHE-VECTOR-LOCK-COUNT as the first entry -;;; in a cache (svref cache-vector 0). This should probably be abstracted. -;;; -(defun emit-1-t-dlap (wrapper wrapper-move hit miss miss-label value) - (with-lap-registers ((location index) - (primary index) - (cache-vector vector) - (initial-lock-count t)) - (flatten-lap - wrapper-move - (opcode :move (operand :cvar 'cache-vector) cache-vector) - (with-lap-registers ((wrapper-cache-no index)) - (flatten-lap - (emit-1-wrapper-compute-primary-cache-location wrapper primary wrapper-cache-no) - (opcode :move primary location) - (opcode :move (operand :cref cache-vector 0) initial-lock-count) ;get lock-count - (emit-check-cache-entry cache-vector location wrapper 'hit-internal) - (opcode :izerop wrapper-cache-no miss-label))) ;check for obsolescence - (with-lap-registers ((size index)) - (flatten-lap - (opcode :move (operand :cvar 'size) size) - - (opcode :label 'loop) - (opcode :move (operand :i1+ location) location) - (opcode :move (operand :i1+ location) location) - (opcode :label 'continue) - (opcode :fix= location primary miss-label) - (opcode :fix= location size 'set-location-to-min) - (emit-check-cache-entry cache-vector location wrapper 'hit-internal) - (opcode :go 'loop) - - (opcode :label 'set-location-to-min) - (opcode :izerop primary miss-label) - (opcode :move (operand :constant (index-value->index 2)) location) - (opcode :go 'continue))) - (opcode :label 'hit-internal) - (opcode :move (operand :i1+ location) location) ;position for getting value - (opcode :move (emit-cache-vector-ref cache-vector location) value) - (emit-lock-count-test initial-lock-count cache-vector 'hit) - miss - (opcode :label 'hit) - hit))) - -(defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value) - (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0))))) - (with-lap-registers ((location index) - (primary index) - (cache-vector vector) - (initial-lock-count t) - (next-location index) - (line-size index)) ;Line size holds a constant - ;that can be folded in if there was - ;a way to add a constant to - ;an index register - (flatten-lap - (apply #'flatten-lap wrapper-moves) - (opcode :move (operand :constant cache-line-size) line-size) - (opcode :move (operand :cvar 'cache-vector) cache-vector) - (emit-n-wrapper-compute-primary-cache-location wrappers primary miss-label) - (opcode :move primary location) - (opcode :move location next-location) - (opcode :move (operand :cref cache-vector 0) initial-lock-count) ;get the lock-count - (with-lap-registers ((size index)) - (flatten-lap - (opcode :move (operand :cvar 'size) size) - (opcode :label 'continue) - (opcode :move (operand :i+ location line-size) next-location) - (emit-check-cache-line cache-vector location wrappers 'hit) - (emit-adjust-location location next-location primary size 'continue miss-label) - (opcode :label 'hit) - (and value (opcode :move (emit-cache-vector-ref cache-vector location) value)) - (emit-lock-count-test initial-lock-count cache-vector 'hit-internal) - miss - (opcode :label 'hit-internal) - hit)))))) - - - -;;; -;;; Cache related lap code -;;; - -(defun emit-check-1-wrapper-in-cache (cache-vector location wrapper hit-code) - (let ((exit-emit-check-1-wrapper-in-cache - (make-symbol "exit-emit-check-1-wrapper-in-cache"))) - (with-lap-registers ((cwrapper t)) - (flatten-lap - (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper) - (opcode :neq cwrapper wrapper exit-emit-check-1-wrapper-in-cache) - hit-code - (opcode :label exit-emit-check-1-wrapper-in-cache))))) - -(defun emit-check-cache-entry (cache-vector location wrapper hit-label) - (with-lap-registers ((cwrapper t)) - (flatten-lap - (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper) - (opcode :eq cwrapper wrapper hit-label)))) - -(defun emit-check-cache-line (cache-vector location wrappers hit-label) - (let ((checks - (flatten-lap - (gathering1 (flattening-lap) - (iterate ((wrapper (list-elements wrappers))) - (with-lap-registers ((cwrapper t)) - (gather1 - (flatten-lap - (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper) - (opcode :neq cwrapper wrapper 'exit-emit-check-cache-line) - (opcode :move (operand :i1+ location) location))))))))) - (flatten-lap - checks - (opcode :go hit-label) - (opcode :label 'exit-emit-check-cache-line)))) - -(defun emit-lock-count-test (initial-lock-count cache-vector hit-label) - ;; - ;; jumps to hit-label if cache-vector-lock-count consistent, otherwise, continues - ;; - (with-lap-registers ((new-lock-count t)) - (flatten-lap - (opcode :move (operand :cref cache-vector 0) new-lock-count) ;get new cache-vector-lock-count - (opcode :fix= new-lock-count initial-lock-count hit-label)))) - - - -(defun emit-adjust-location (location next-location primary size cont-label miss-label) - (flatten-lap - (opcode :move next-location location) - (opcode :fix= location size 'at-end-of-cache) - (opcode :fix= location primary miss-label) - (opcode :go cont-label) - (opcode :label 'at-end-of-cache) - (opcode :fix= primary (operand :constant (index-value->index 1)) miss-label) - (opcode :move (operand :constant (index-value->index 1)) location) - (opcode :go cont-label))) - - -;; From cache.lisp -(defun emit-cache-vector-ref (cache-vector-operand location-operand) - (operand :iref cache-vector-operand location-operand)) - -(defun emit-wrapper-ref (wrapper-operand field-operand) - (operand :iref wrapper-operand field-operand)) - -(defun emit-wrapper-cache-number-vector (wrapper-operand) - (operand :wrapper-cache-number-vector wrapper-operand)) - -(defun emit-cache-number-vector-ref (cnv-operand field-operand) - (operand :iref cnv-operand field-operand)) - -(defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no) - (with-lap-registers ((mask index) - (cnv fixnum-vector)) - (let ((field wrapper-cache-no)) - (flatten-lap - (opcode :move (operand :cvar 'mask) mask) - (opcode :move (operand :cvar 'field) field) - (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv) - (opcode :move (emit-cache-number-vector-ref cnv field) wrapper-cache-no) - (opcode :move (operand :ilogand wrapper-cache-no mask) primary))))) - -(defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label) - (with-lap-registers ((field index) - (mask index)) - (let ((add-wrapper-cache-numbers - (flatten-lap - (gathering1 (flattening-lap) - (iterate ((wrapper (list-elements wrappers)) - (i (interval :from 1))) - (gather1 - (with-lap-registers ((wrapper-cache-no index) - (cnv fixnum-vector)) - (flatten-lap - (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no) - (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv) - (opcode :move (emit-cache-number-vector-ref cnv field) - wrapper-cache-no) - (opcode :izerop wrapper-cache-no miss-label) - (opcode :move (operand :i+ primary wrapper-cache-no) primary) - (when (zerop (mod i wrapper-cache-number-adds-ok)) - (opcode :move (operand :ilogand primary mask) primary)))))))))) - (flatten-lap - (opcode :move (operand :constant 0) primary) - (opcode :move (operand :cvar 'field) field) - (opcode :move (operand :cvar 'mask) mask) - add-wrapper-cache-numbers - (opcode :move (operand :ilogand primary mask) primary) - (opcode :move (operand :i1+ primary) primary))))) - -(defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot) - (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper"))) - (with-lap-registers ((arg t)) - (ecase metatype - ((standard-instance) - (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper")) - (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))) - (flatten-lap - (opcode :move (operand :arg argument) arg) - (opcode :std-instance-p arg get-std-inst-wrapper) ;is it a std wrapper? - (opcode :fsc-instance-p arg get-fsc-inst-wrapper) ;is it a fsc wrapper? - (opcode :go miss-label) - (opcode :label get-fsc-inst-wrapper) - (opcode :move (operand :fsc-wrapper arg) dest) ;get fsc wrapper - (and slot - (opcode :move (operand :fsc-slots arg) slot)) - (opcode :go exit-emit-fetch-wrapper) - (opcode :label get-std-inst-wrapper) - (opcode :move (operand :std-wrapper arg) dest) ;get std wrapper - (and slot - (opcode :move (operand :std-slots arg) slot)) - (opcode :label exit-emit-fetch-wrapper)))) - (class - (when slot (error "Can't do a slot reg for this metatype.")) - (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper")) - (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))) - (flatten-lap - (opcode :move (operand :arg argument) arg) - (opcode :std-instance-p arg get-std-inst-wrapper) - (opcode :fsc-instance-p arg get-fsc-inst-wrapper) - (opcode :move (operand :built-in-or-structure-wrapper arg) dest) - (opcode :go exit-emit-fetch-wrapper) - (opcode :label get-fsc-inst-wrapper) - (opcode :move (operand :fsc-wrapper arg) dest) - (opcode :go exit-emit-fetch-wrapper) - (opcode :label get-std-inst-wrapper) - (opcode :move (operand :std-wrapper arg) dest) - (opcode :label exit-emit-fetch-wrapper)))) - ((built-in-instance structure-instance) - (when slot (error "Can't do a slot reg for this metatype.")) - (let () - (flatten-lap - (opcode :move (operand :arg argument) arg) - (opcode :std-instance-p arg miss-label) - (opcode :fsc-instance-p arg miss-label) - (opcode :move (operand :built-in-or-structure-wrapper arg) dest)))))))) - diff --git a/pcl/inline.lisp b/pcl/inline.lisp deleted file mode 100644 index 91122050edc7d61a2d0182b762a2e4f89c9b2585..0000000000000000000000000000000000000000 --- a/pcl/inline.lisp +++ /dev/null @@ -1,263 +0,0 @@ -;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- - -(in-package :pcl) - -;; This file contains some of the things that will have to change to support -;; inlining of methods. - -(defun make-method-lambda-internal (method-lambda &optional env) - (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) - (error "The method-lambda argument to make-method-lambda, ~S,~ - is not a lambda form" method-lambda)) - (multiple-value-bind (documentation declarations real-body) - (extract-declarations (cddr method-lambda) env) - (let* ((name-decl (get-declaration 'method-name declarations)) - (sll-decl (get-declaration 'method-lambda-list declarations)) - (method-name (when (consp name-decl) (car name-decl))) - (generic-function-name (when method-name (car method-name))) - (specialized-lambda-list (or sll-decl (cadr method-lambda)))) - (multiple-value-bind (parameters lambda-list specializers) - (parse-specialized-lambda-list specialized-lambda-list) - (let* ((required-parameters - (mapcar #'(lambda (r s) (declare (ignore s)) r) - parameters - specializers)) - (slots (mapcar #'list required-parameters)) - (calls (list nil)) - (parameters-to-reference - (make-parameter-references specialized-lambda-list - required-parameters - declarations - method-name - specializers)) - (class-declarations - `(declare - ,@(remove nil - (mapcar #'(lambda (a s) (and (symbolp s) - (neq s 't) - `(class ,a ,s))) - parameters - specializers)))) - (method-lambda - ;; Remove the documentation string and insert the - ;; appropriate class declarations. The documentation - ;; string is removed to make it easy for us to insert - ;; new declarations later, they will just go after the - ;; cadr of the method lambda. The class declarations - ;; are inserted to communicate the class of the method's - ;; arguments to the code walk. - `(lambda ,lambda-list - ,class-declarations - ,@declarations - (progn ,@parameters-to-reference) - (block ,(if (listp generic-function-name) - (cadr generic-function-name) - generic-function-name) - ,@real-body))) - (constant-value-p (and (null (cdr real-body)) - (constantp (car real-body)))) - (constant-value (and constant-value-p - (eval (car real-body)))) - (plist (if (and constant-value-p - (or (typep constant-value '(or number character)) - (and (symbolp constant-value) - (symbol-package constant-value)))) - (list :constant-value constant-value) - ())) - (applyp (dolist (p lambda-list nil) - (cond ((memq p '(&optional &rest &key)) - (return t)) - ((eq p '&aux) - (return nil)))))) - (multiple-value-bind (walked-lambda call-next-method-p closurep - next-method-p-p) - (walk-method-lambda method-lambda required-parameters env - slots calls) - (multiple-value-bind (ignore walked-declarations walked-lambda-body) - (extract-declarations (cddr walked-lambda)) - (declare (ignore ignore)) - (when (or next-method-p-p call-next-method-p) - (setq plist (list* :needs-next-methods-p 't plist))) - (when (some #'cdr slots) - (multiple-value-bind (slot-name-lists call-list) - (slot-name-lists-from-slots slots calls) - (let ((pv-table-symbol (make-symbol "pv-table"))) - (setq plist - `(,@(when slot-name-lists - `(:slot-name-lists ,slot-name-lists)) - ,@(when call-list - `(:call-list ,call-list)) - :pv-table-symbol ,pv-table-symbol - ,@plist)) - (setq walked-lambda-body - `((pv-binding (,required-parameters ,slot-name-lists - ,pv-table-symbol) - ,@walked-lambda-body)))))) - (when (and (memq '&key lambda-list) - (not (memq '&allow-other-keys lambda-list))) - (let ((aux (memq '&aux lambda-list))) - (setq lambda-list (nconc (ldiff lambda-list aux) - (list '&allow-other-keys) - aux)))) - (values `(lambda (.method-args. .next-methods.) - (simple-lexical-method-functions - (,lambda-list .method-args. .next-methods. - :call-next-method-p ,call-next-method-p - :next-method-p-p ,next-method-p-p - :closurep ,closurep - :applyp ,applyp) - ,@walked-declarations - ,@walked-lambda-body)) - `(,@(when plist - `(:plist ,plist)) - ,@(when documentation - `(:documentation ,documentation))))))))))) - -(define-inline-function slot-value (instance slot-name) (form closure-p env) - :predicate (and (not closure-p) (constantp slot-name)) - :inline-arguments (required-parameters slots) - :inline (optimize-slot-value - slots - (can-optimize-access form required-parameters env) - form)) - -;collect information about: -; uses of the required-parameters -; uses of call-next-method and next-method-p: -; called-p -; apply-p -; arglist info -;optimize calls to slot-value, set-slot-value, slot-boundp -;optimize calls to find-class -;optimize generic-function calls -(defun make-walk-function (required-parameters info slots calls) - #'(lambda (form context env) - (cond ((not (eq context ':eval)) form) - ((not (listp form)) form) - ((eq (car form) 'call-next-method) - (setq call-next-method-p 't) - form) - ((eq (car form) 'next-method-p) - (setq next-method-p-p 't) - form) - ((and (eq (car form) 'function) - (cond ((eq (cadr form) 'call-next-method) - (setq call-next-method-p 't) - (setq closurep t) - form) - ((eq (cadr form) 'next-method-p) - (setq next-method-p-p 't) - (setq closurep t) - form) - (t nil)))) - ((and (or (eq (car form) 'slot-value) - (eq (car form) 'set-slot-value) - (eq (car form) 'slot-boundp)) - (constantp (caddr form))) - (let ((parameter - (can-optimize-access form - required-parameters env))) - (ecase (car form) - (slot-value - (optimize-slot-value slots parameter form)) - (set-slot-value - (optimize-set-slot-value slots parameter form)) - (slot-boundp - (optimize-slot-boundp slots parameter form))))) - ((and (or (symbolp (car form)) - (and (consp (car form)) - (eq (caar form) 'setf))) - (fboundp (car form)) - (if (eq *boot-state* 'complete) - (standard-generic-function-p (gdefinition (car form))) - (funcallable-instance-p (gdefinition (car form))))) - (optimize-generic-function-call - form required-parameters env slots calls)) - (t form)))) - -(defun walk-method-lambda (method-lambda required-parameters env slots calls) - (let* ((call-next-method-p nil) ;flag indicating that call-next-method - ;should be in the method definition - (closurep nil) ;flag indicating that #'call-next-method - ;was seen in the body of a method - (next-method-p-p nil) ;flag indicating that next-method-p - ;should be in the method definition - (walk-functions `((call-next-method-p - ,#'(lambda (form closure-p env) - (setq call-next-method-p 't) - (when closure-p - (setq closurep t)) - form)) - (next-method-p - ,#'(lambda (form closure-p env) - (setq next-method-p-p 't) - (when closure-p - (setq closurep t)) - form)) - ((slot-value set-slot-value slot-boundp) - ,#'(lambda (form closure-p env) - (if (and (not closure-p) - (constantp (caddr form))) - - (let ((walked-lambda (walk-form method-lambda env - (make-walk-function - `((call-next-method-p - ,#'(lambda (form closure-p env) - (setq call-next-method-p 't) - (when closure-p - (setq closurep t)) - form)) - (next-method-p - ,#'(lambda (form closure-p env) - (setq next-method-p-p 't) - (when closure-p - (setq closurep t)) - form)) - ((slot-value set-slot-value slot-boundp) - ,#'(lambda (form closure-p env) - ( - (values walked-lambda - call-next-method-p closurep next-method-p-p))))) - -(defun initialize-method-function (initargs &optional return-function-p method) - (let* ((mf (getf initargs ':function)) - (method-spec (getf initargs ':method-spec)) - (plist (getf initargs ':plist)) - (pv-table-symbol (getf plist ':pv-table-symbol)) - (pv-table nil) - (mff (getf initargs ':fast-function))) - (flet ((set-mf-property (p v) - (when mf - (setf (method-function-get mf p) v)) - (when mff - (setf (method-function-get mff p) v)))) - (when method-spec - (when mf - (setq mf (set-function-name mf method-spec))) - (when mff - (let ((name `(,(or (get (car method-spec) 'fast-sym) - (setf (get (car method-spec) 'fast-sym) - (intern (format nil "FAST-~A" - (car method-spec)) - *the-pcl-package*))) - ,@(cdr method-spec)))) - (set-function-name mff name) - (unless mf - (set-mf-property :name name))))) - (when plist - (let ((snl (getf plist :slot-name-lists)) - (cl (getf plist :call-list))) - (when (or snl cl) - (setq pv-table (intern-pv-table :slot-name-lists snl - :call-list cl)) - (when pv-table (set pv-table-symbol pv-table)) - (set-mf-property :pv-table pv-table))) - (loop (when (null plist) (return nil)) - (set-mf-property (pop plist) (pop plist))) - (when method - (set-mf-property :method method)) - (when return-function-p - (or mf (method-function-from-fast-function mff))))))) - - - diff --git a/pcl/lap.lisp b/pcl/lap.lisp deleted file mode 100644 index eaaeeba084ee15828c062764ff1094892d2caf15..0000000000000000000000000000000000000000 --- a/pcl/lap.lisp +++ /dev/null @@ -1,502 +0,0 @@ -;;;-*-Mode: LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. -;;; All rights reserved. -;;; -;;; Use and copying of this software and preparation of derivative works -;;; based upon this software are permitted. Any distribution of this -;;; software or derivative works must comply with all applicable United -;;; States export control laws. -;;; -;;; This software is made available AS IS, and Xerox Corporation makes no -;;; warranty about the software, its performance or its conformity to any -;;; specification. -;;; -;;; Any person obtaining a copy of this software is requested to send their -;;; name and post office or electronic mail address to: -;;; CommonLoops Coordinator -;;; Xerox PARC -;;; 3333 Coyote Hill Rd. -;;; Palo Alto, CA 94304 -;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) -;;; -;;; Suggestions, comments and requests for improvements are also welcome. -;;; ************************************************************************* -;;; - -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/lap.lisp,v 1.9 2001/03/13 15:49:48 pw Exp $") -;;; - -(in-package 'pcl) - -;;; -;;; This file defines PCL's interface to the LAP mechanism. -;;; -;;; The file is divided into two parts. The first part defines the interface -;;; used by PCL to create abstract LAP code vectors. PCL never creates lists -;;; that represent LAP code directly, it always calls this mechanism to do so. -;;; This provides a layer of error checking on the LAP code before it gets to -;;; the implementation-specific assembler. Note that this error checking is -;;; syntactic only, but even so is useful to have. Because of it, no specific -;;; LAP assembler should worry itself with checking the syntax of the LAP code. -;;; -;;; The second part of the file defines the LAP assemblers for each PCL port. -;;; These are included together in the same file to make it easier to change -;;; them all should some random change be made in the LAP mechanism. -;;; - -(defvar *make-lap-closure-generator*) -(defvar *precompile-lap-closure-generator*) -(defvar *lap-in-lisp*) - -(defun make-lap-closure-generator - (closure-variables arguments iregs vregs fvregs tregs lap-code) - (funcall *make-lap-closure-generator* - closure-variables arguments iregs - vregs fvregs tregs lap-code)) - -(defmacro precompile-lap-closure-generator - (cvars args i-regs v-regs fv-regs t-regs lap) - (funcall *precompile-lap-closure-generator* cvars args i-regs - v-regs fv-regs t-regs lap)) - -(defmacro lap-in-lisp (cvars args iregs vregs fvregs tregs lap) - (declare (ignore cvars args)) - `(locally (declare #.*optimize-speed*) - ,(make-lap-prog iregs vregs fvregs tregs - (flatten-lap lap (opcode :label 'exit-lap-in-lisp))))) - - -;;; -;;; The following functions and macros are used by PCL when generating LAP -;;; code: -;;; -;;; GENERATING-LAP -;;; WITH-LAP-REGISTERS -;;; ALLOCATE-REGISTER -;;; DEALLOCATE-REGISTER -;;; LAP-FLATTEN -;;; OPCODE -;;; OPERAND -;;; -(declaim '(special *generating-lap*)) ;CAR - alist of free registers - ;CADR - alist of allocated registers - ;CADDR - max reg number allocated - ; - ;in each alist, the entries have - ;the form: (type . (:REG <n>)) - ; - -;;; -;;; This goes around the generation of any lap code. <body> should return a lap -;;; code sequence, this macro will take care of converting that to a lap closure -;;; generator. -;;; -(defmacro generating-lap (closure-variables arguments &body body) - `(let* ((*generating-lap* (list () () -1))) - (finalize-lap-generation nil ,closure-variables ,arguments (progn ,@body)))) - -(defmacro generating-lap-in-lisp (closure-variables arguments &body body) - `(let* ((*generating-lap* (list () () -1))) - (finalize-lap-generation t ,closure-variables ,arguments (progn ,@body)))) - -;;; -;;; Each register specification looks like: -;;; -;;; (<var> <type> &key :reuse <other-reg>) -;;; -(defmacro with-lap-registers (register-specifications &body body) - ;; - ;; Given that, for now, there is only one keyword argument and - ;; that, for now, we do no error checking, we can be pretty - ;; sleazy about how this works. - ;; - (flet ((make-allocations () - (gathering1 (collecting) - (dolist (spec register-specifications) - (gather1 - `(,(car spec) (or ,(cadddr spec) (allocate-register ',(cadr spec)))))))) - (make-deallocations () - (gathering1 (collecting) - (dolist (spec register-specifications) - (gather1 - `(unless ,(cadddr spec) (deallocate-register ,(car spec)))))))) - `(let ,(make-allocations) - (multiple-value-prog1 (progn ,@body) - ,@(make-deallocations))))) - -(defun allocate-register (type) - (destructuring-bind (free allocated) *generating-lap* - (let ((entry (assoc type free))) - (cond (entry - (setf (car *generating-lap*) (delete entry free) - (cadr *generating-lap*) (cons entry allocated)) - (cdr entry)) - (t - (let ((new `(,type . (:reg ,(incf (caddr *generating-lap*)))))) - (setf (cadr *generating-lap*) (cons new allocated)) - (cdr new))))))) - -(defun deallocate-register (reg) - (let ((entry (rassoc reg (cadr *generating-lap*)))) - (unless entry (error "Attempt to free an unallocated register.")) - (push entry (car *generating-lap*)) - (setf (cadr *generating-lap*) (delete entry (cadr *generating-lap*))))) - -(defvar *precompiling-lap* nil) - -(defun finalize-lap-generation (in-lisp-p closure-variables arguments lap-code) - (when (cadr *generating-lap*) (error "Registers still allocated when lap being finalized.")) - (let ((iregs ()) - (vregs ()) - (fvregs ()) - (tregs ())) - (dolist (entry (car *generating-lap*)) - (ecase (car entry) - (index (push (caddr entry) iregs)) - (vector (push (caddr entry) vregs)) - (fixnum-vector (push (caddr entry) fvregs)) - ((t) (push (caddr entry) tregs)))) - (cond (in-lisp-p - `(lap-in-lisp ,closure-variables ,arguments ,iregs - ,vregs ,fvregs ,tregs ,lap-code)) - (*precompiling-lap* - `(precompile-lap-closure-generator - ,closure-variables ,arguments ,iregs - ,vregs ,fvregs ,tregs ,lap)) - (t - (make-lap-closure-generator - closure-variables arguments iregs - vregs fvregs tregs lap-code))))) - -(defun flatten-lap (&rest opcodes-or-sequences) - (let ((result ())) - (dolist (opcode-or-sequence opcodes-or-sequences result) - (cond ((null opcode-or-sequence)) - ((not (consp (car opcode-or-sequence))) ;its an opcode - (setf result (append result (list opcode-or-sequence)))) - (t - (setf result (append result opcode-or-sequence))))))) - -(defmacro flattening-lap () - '(let ((result ())) - (values #'(lambda (value) (push value result)) - #'(lambda () (apply #'flatten-lap (reverse result)))))) - - - -;;; -;;; This code deals with the syntax of the individual opcodes and operands. -;;; - -;;; -;;; The first two of these variables are documented to all ports. They are -;;; lists of the symbols which name the lap opcodes and operands. They can -;;; be useful to determine whether a port has implemented all the required -;;; opcodes and operands. -;;; -;;; The third of these variables is for use of the emitter only. -;;; -(defvar *lap-operands* ()) -(defvar *lap-opcodes* ()) -(defvar *lap-emitters* (make-hash-table :test #'eq :size 30)) - -(defun opcode (name &rest args) - (let ((emitter (gethash name *lap-emitters*))) - (if emitter - (apply emitter args) - (error "No opcode named ~S." name)))) - -(defun operand (name &rest args) - (let ((emitter (gethash name *lap-emitters*))) - (if emitter - (apply emitter args) - (error "No operand named ~S." name)))) - -(defmacro defopcode (name types) - (let ((fn-name (symbol-append "LAP Opcode " name *the-pcl-package*)) - (lambda-list - (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) types))) - `(progn - (eval-when (load eval) (load-defopcode ',name ',fn-name)) - (defun ,fn-name ,lambda-list - (defopcode-1 ',name ',types ,@lambda-list))))) - -(defmacro defoperand (name types) - (let ((fn-name (symbol-append "LAP Operand " name *the-pcl-package*)) - (lambda-list - (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) types))) - `(progn - (eval-when (load eval) (load-defoperand ',name ',fn-name)) - (defun ,fn-name ,lambda-list - (defoperand-1 ',name ',types ,@lambda-list))))) - -(defun load-defopcode (name fn-name) - (if* (memq name *lap-operands*) - (error "LAP opcodes and operands must have disjoint names.") - (setf (gethash name *lap-emitters*) fn-name) - (pushnew name *lap-opcodes*))) - -(defun load-defoperand (name fn-name) - (if* (memq name *lap-opcodes*) - (error "LAP opcodes and operands must have disjoint names.") - (setf (gethash name *lap-emitters*) fn-name) - (pushnew name *lap-operands*))) - -(defun defopcode-1 (name operand-types &rest args) - (iterate ((arg (list-elements args)) - (type (list-elements operand-types))) - (check-opcode-arg name arg type)) - (cons name (copy-list args))) - -(defun defoperand-1 (name operand-types &rest args) - (iterate ((arg (list-elements args)) - (type (list-elements operand-types))) - (check-operand-arg name arg type)) - (cons name (copy-list args))) - -(defun check-opcode-arg (name arg type) - (labels ((usual (x) - (and (consp arg) (eq (car arg) x))) - (check (x) - (ecase x - ((:reg :cdr :constant :iref :instance-ref :cvar :arg :lisp :lisp-variable) - (usual x)) - (:label (symbolp arg)) - (:operand (and (consp arg) (memq (car arg) *lap-operands*)))))) - (unless (if (consp type) - (if (eq (car type) 'or) - (some #'check (cdr type)) - (error "What type is this?")) - (check type)) - (error "The argument ~S to the opcode ~A is not of type ~S." arg name type)))) - -(defun check-operand-arg (name arg type) - (flet ((check (x) - (ecase x - (:symbol (symbolp arg)) - (:register-number (and (integerp arg) (>= arg 0))) - (:t t) - (:reg (and (consp arg) (eq (car arg) :reg))) - (:fixnum (typep arg 'fixnum))))) - (unless (if (consp type) - (if (eq (car type) 'or) - (some #'check (cdr type)) - (error "What type is this?")) - (check type)) - (error "The argument ~S to the operand ~A is not of type ~S." arg name type)))) - - - -;;; -;;; The actual opcodes. -;;; -(defopcode :break ()) ;For debugging only. Not -(defopcode :beep ()) ;all ports are required to -(defopcode :print (:reg)) ;implement this. - - -(defopcode :move (:operand (or :reg :iref :instance-ref :cdr :lisp-variable))) - -(defopcode :eq ((or :reg :constant) (or :reg :constant) :label)) -(defopcode :neq ((or :reg :constant) (or :reg :constant) :label)) -(defopcode :fix= ((or :reg :constant) (or :reg :constant) :label)) -(defopcode :izerop (:reg :label)) - -(defopcode :std-instance-p (:reg :label)) -(defopcode :fsc-instance-p (:reg :label)) -(defopcode :built-in-instance-p (:reg :label)) -(defopcode :structure-instance-p (:reg :label)) - -(defopcode :jmp ((or :reg :constant))) -(defopcode :emf-call ((or :reg :constant))) - -(defopcode :label (:label)) -(defopcode :go (:label)) - -(defopcode :return ((or :reg :constant))) - -(defopcode :exit-lap-in-lisp ()) - -;;; -;;; The actual operands. -;;; -(defoperand :reg (:register-number)) -(defoperand :cvar (:symbol)) -(defoperand :arg (:symbol)) - -(defoperand :cdr (:reg)) - -(defoperand :constant (:t)) - -(defoperand :std-wrapper (:reg)) -(defoperand :fsc-wrapper (:reg)) -(defoperand :built-in-wrapper (:reg)) -(defoperand :structure-wrapper (:reg)) -(defoperand :other-wrapper (:reg)) -(defoperand :built-in-or-structure-wrapper (:reg)) - -(defoperand :std-slots (:reg)) -(defoperand :fsc-slots (:reg)) - -(defoperand :wrapper-cache-number-vector (:reg)) - -(defoperand :cref (:reg :fixnum)) - -(defoperand :iref (:reg :reg)) -(defoperand :iset (:reg :reg :reg)) - -(defoperand :instance-ref (:reg :reg)) -(defoperand :instance-set (:reg :reg :reg)) - -(defoperand :i1+ (:reg)) -(defoperand :i+ (:reg :reg)) -(defoperand :i- (:reg :reg)) -(defoperand :ilogand (:reg :reg)) -(defoperand :ilogxor (:reg :reg)) -(defoperand :ishift (:reg :fixnum)) - -(defoperand :lisp (:t)) -(defoperand :lisp-variable (:symbol)) - - - -;;; -;;; LAP tests (there need to be a lot more of these) -;;; -#| -(defun make-lap-test-closure-1 (result) - #'(lambda (arg1) - (declare (pcl-fast-call)) - (declare (ignore arg1)) - result)) - -(defun make-lap-test-closure-2 (result) - #'(lambda (arg1 arg2) - (declare (pcl-fast-call)) - (declare (ignore arg1 arg2)) - result)) - -(eval-when (eval) - (compile 'make-lap-test-closure-1) - (compile 'make-lap-test-closure-2)) - -(declaim (special lap-win lap-lose)) -(eval-when (load eval) - (setq lap-win (make-lap-test-closure-1 'win) - lap-lose (make-lap-test-closure-1 'lose))) - -(defun lap-test-1 () - (let* ((cg (generating-lap '(cache) - '(arg) - (with-lap-registers ((i0 index) - (v0 vector) - (t0 t)) - (flatten-lap - (opcode :move (operand :cvar 'cache) v0) - (opcode :move (operand :arg 'arg) i0) - (opcode :move (operand :iref v0 i0) t0) - (opcode :jmp t0))))) - - (cache (make-array 32)) - (closure (funcall cg cache)) - (fn0 (make-lap-test-closure-1 'fn0)) - (fn1 (make-lap-test-closure-1 'fn1)) - (fn2 (make-lap-test-closure-1 'fn2)) - (in0 (index-value->index 2)) - (in1 (index-value->index 10)) - (in2 (index-value->index 27))) - - (setf (svref cache (index->index-value in0)) fn0 - (svref cache (index->index-value in1)) fn1 - (svref cache (index->index-value in2)) fn2) - - (unless (and (eq (funcall closure in0) 'fn0) - (eq (funcall closure in1) 'fn1) - (eq (funcall closure in2) 'fn2)) - (error "LAP TEST 1 failed.")))) - -(defun lap-test-2 () - (let* ((cg (generating-lap '(cache mask) - '(arg) - (with-lap-registers ((i0 index) - (i1 index) - (i2 index) - (v0 vector) - (t0 t)) - - (flatten-lap - (opcode :move (operand :cvar 'cache) v0) - (opcode :move (operand :arg 'arg) i0) - (opcode :move (operand :cvar 'mask) i1) - (opcode :move (operand :ilogand i0 i1) i2) - (opcode :move (operand :iref v0 i2) t0) - (opcode :jmp t0))))) - (cache (make-array 32)) - (mask #b00110) - (closure (funcall cg cache mask)) - (in0 (index-value->index #b00010)) - (in1 (index-value->index #b01010)) - (in2 (index-value->index #b10011))) - (fill cache lap-lose) - (setf (svref cache (index->index-value in0)) lap-win) - - (unless (and (eq (funcall closure in0) 'win) - (eq (funcall closure in1) 'win) - (eq (funcall closure in2) 'win)) - (error "LAP TEST 2 failed.")))) - -(defun lap-test-3 () - (let* ((cg (generating-lap '(addend) '(arg) - (with-lap-registers - ((i0 index) - (i1 index) - (i2 index)) - - (flatten-lap - (opcode :move (operand :cvar 'addend) i0) - (opcode :move (operand :arg 'arg) i1) - (opcode :move (operand :i+ i0 i1) i2) - (opcode :return i2))))) - (closure (funcall cg (index-value->index 5)))) - - (unless (= (index->index-value (funcall closure (index-value->index 2))) 7) - (error "LAP TEST 3 failed.")))) - -(defun lap-test-4 () - (let* ((cg (generating-lap '(winner loser) '(arg) - (with-lap-registers ((t0 t)) - (flatten-lap - (opcode :move (operand :arg 'arg) t0) - (opcode :eq t0 (operand :constant 'foo) 'win) - (opcode :move (operand :cvar 'loser) t0) - (opcode :jmp t0) - (opcode :label 'win) - (opcode :move (operand :cvar 'winner) t0) - (opcode :jmp t0))))) - (closure (funcall cg #'true #'false))) - (unless (and (eq (funcall closure 'foo) 't) - (eq (funcall closure 'bar) 'nil)) - (error "LAP TEST 4 failed.")))) - -(defun lap-test-5 () - (let* ((cg (generating-lap '(array) '(arg) - (with-lap-registers ((r0 vector) - (r1 t) - (r2 index)) - (flatten-lap - (opcode :move (operand :cvar 'array) r0) - (opcode :move (operand :arg 'arg) r1) - (opcode :move (operand :constant (index-value->index 0)) r2) - (opcode :move r1 (operand :iref r0 r2)) - (opcode :return r1))))) - (array (make-array 1)) - (closure (funcall cg array))) - (unless (and (= (funcall closure 1) (svref array 0)) - (eq (funcall closure 'foo) (svref array 0))) - (error "LAP TEST 5 failed.")))) - -|# - diff --git a/pcl/list-functions.lisp b/pcl/list-functions.lisp deleted file mode 100644 index f4601a439f50c732bb7105b6b19b0d3695862e7b..0000000000000000000000000000000000000000 --- a/pcl/list-functions.lisp +++ /dev/null @@ -1,141 +0,0 @@ - -(in-package :pcl) - -(defvar *defun-list* nil) -(defvar *defmethod-list* nil) -(defvar *defmacro-list* nil) -(defvar *defgeneric-list* nil) - -(defun list-functions (&optional print-p) - (let ((eof '(eof)) - (*package* *package*)) - (setq *defun-list* nil - *defmethod-list* nil - *defmacro-list* nil) - (labels ((process-form (form) - (when (consp form) - (case (car form) - ((in-package export import shadow shadowing-import) (eval form)) - #+lcl3.0 (lcl:handler-bind (eval form)) - (let (when print-p (print form))) - (defun (push (list (cadr form) (caddr form)) - *defun-list*)) - (defmethod (push (list (cadr form) (caddr form)) - *defmethod-list*)) - (defmacro (push (list (cadr form) (caddr form)) - *defmacro-list*)) - (defgeneric (push (list (cadr form) (caddr form)) - *defgeneric-list*)) - (eval-when (mapc #'process-form (cddr form))) - (progn (mapc #'process-form (cdr form))) - ((defvar defparameter defconstant proclaim - defsetf defstruct deftype define-compiler-macro)) - ((define-walker-template defopcode defoperand - define-method-combination define-constructor-code-type - defclass)) - (t (when print-p (print form))))))) - (dolist (file (system-source-files 'pcl)) - (with-open-file (in file :direction :input) - (loop (let ((form (read in nil eof))) - (when (eq form eof) (return nil)) - (process-form form)))))) - (values (length *defun-list*) - (length *defmethod-list*) - (length *defmacro-list*) - (length *defgeneric-list*)))) - -(defun list-all-gfs (&key all-p (show-methods-p t) san-p (name "generic-functions")) - (let ((keys nil) (opt nil) - (gf-vector (make-array 10 :initial-element nil)) - (readers nil) (writers nil) (cv nil) - (*package* *the-pcl-package*) - (*print-pretty* nil) - (s-a-n (find-package "SLOT-ACCESSOR-NAME")) - (lisp-sans (mapcar #'slot-reader-symbol '(function type)))) - ;; This one has no predefined methods. - (defgeneric update-dependent (metaobject dependent &rest initargs)) - (map-all-generic-functions - #'(lambda (gf) - (when (or all-p - (let ((name (generic-function-name gf))) - (when (consp name) (setq name (cadr name))) - (and (not (find #\: (symbol-name name))) - (or (eq (symbol-package name) *the-pcl-package*) - (and san-p - (memq name lisp-sans) - (and (eq (symbol-package name) s-a-n) - (string= "PCL " (symbol-name name) - :end2 4))))))) - (let ((ll (generic-function-lambda-list gf))) - (multiple-value-bind (nrequired noptional - keysp restp allow-other-keys-p keywords) - (analyze-lambda-list ll) - (cond ((use-constant-value-dfun-p gf t) - (push gf cv)) - ((or keysp restp allow-other-keys-p keywords) - (push gf keys)) - ((plusp noptional) - (push gf opt)) - ((and (= nrequired 1) - (let ((m (generic-function-methods gf))) - (and m - (every #'standard-reader-method-p m)))) - (push gf readers)) - ((and (= nrequired 2) - (let ((m (generic-function-methods gf))) - (and m - (every #'standard-writer-method-p m)))) - (push gf writers)) - (t - (push gf (aref gf-vector nrequired))))))))) - (with-open-file (out (let* ((system (get-system 'pcl)) - (*system-directory* (funcall (car system)))) - (make-pathname :defaults - (truename (make-source-pathname "defsys")) - :name name)) - :direction :output) - (format out ";;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-~2%") - (format out "(in-package :pcl)~%") - (flet ((print-gf-list (list) - (setq list - (sort (mapcar #'generic-function-name list) - #'(lambda (sym1 sym2) - (let* ((s1 (if (consp sym1) (cadr sym1) sym1)) - (s2 (if (consp sym2) (cadr sym2) sym2)) - (p1 (symbol-package s1)) - (p2 (symbol-package s2))) - (if (eq p1 p2) - (string< (symbol-name s1) (symbol-name s2)) - (string< (package-name p1) (package-name p2))))))) - (dolist (sym list) - (let* ((*print-case* :downcase) - (gf (gdefinition sym)) - (lambda-list (generic-function-lambda-list gf))) - (format out "~&~S~%" `(defgeneric ,sym ,lambda-list)) - (when show-methods-p - (dolist (m (generic-function-methods gf)) - (let* ((q (method-qualifiers m)) - (qs (if (null q) - "" - (format nil "~{~S~^ ~}" q))) - (s (unparse-specializers m))) - (format out "~&; ~7A ~S~%" qs s))) - (terpri out)))))) - (when cv - (format out "~%;;; class predicates~%") - (print-gf-list cv)) - (when readers - (format out "~%;;; readers~%") - (print-gf-list readers)) - (when writers - (format out "~%;;; writers~%") - (print-gf-list writers)) - (dotimes (i 10) - (when (aref gf-vector i) - (format out "~%;;; ~D argument~:P ~%" i) - (print-gf-list (aref gf-vector i)))) - (format out "~%;;; optional arguments ~%") - (print-gf-list opt) - (format out "~%;;; keyword arguments ~%") - (print-gf-list keys)) - (terpri out)))) diff --git a/pcl/make-test.lisp b/pcl/make-test.lisp deleted file mode 100644 index a80a006e1de668fafb3e928f689221cf319b9282..0000000000000000000000000000000000000000 --- a/pcl/make-test.lisp +++ /dev/null @@ -1,47 +0,0 @@ -(in-package :pcl) - -(defun top-level-form-form (form) - #+cmu - (if (and (consp form) (eq (car form) 'eval-when)) - (third form) - form) - #+kcl - (fourth (third form)) - #+lcl3.0 - (third (third form))) - -(defun make-test () - (let ((table (make-hash-table :test 'eq)) - (count 0)) - (labels ((fixup (form) - (if (consp form) - (cons (fixup (car form)) (fixup (cdr form))) - (if (and (symbolp form) (null (symbol-package form))) - (or (gethash form table) - (setf (gethash form table) - (intern (format nil "~A-%-~D" (symbol-name form) - (incf count)) - *the-pcl-package*))) - form)))) - (with-open-file (out "test.lisp" - :direction :output :if-exists :supersede) - (declare (type stream out)) - (let ((*print-case* :downcase) - (*print-pretty* t) - (*package* *the-pcl-package*)) - (format out "~S~%" '(in-package :pcl)) - (let ((i 0) - (f (macroexpand '(PRECOMPILE-FUNCTION-GENERATORS PCL)))) - (dolist (form (cdr (top-level-form-form f))) - (let ((name (intern (format nil "FGEN-~D" (incf i))))) - (format out "~S~%" `(defun ,name () ,(fixup form)))))) - (let ((i 0) - (f (macroexpand '(PRECOMPILE-DFUN-CONSTRUCTORS PCL)))) - (dolist (form (cdr f)) - (let ((name (intern (format nil "DFUN-CONSTR-~D" (incf i)))) - (form (top-level-form-form form))) - (format out "~S~%" `(defun ,name () - (list ,(second form) - ,(third form) - ,(fixup (macroexpand (fifth form)))))))))))))) - diff --git a/pcl/plap.lisp b/pcl/plap.lisp deleted file mode 100644 index 3b670ea38d48e56c2646c09b94d4f6d2e7404c61..0000000000000000000000000000000000000000 --- a/pcl/plap.lisp +++ /dev/null @@ -1,353 +0,0 @@ -;;;-*-Mode: LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. -;;; All rights reserved. -;;; -;;; Use and copying of this software and preparation of derivative works -;;; based upon this software are permitted. Any distribution of this -;;; software or derivative works must comply with all applicable United -;;; States export control laws. -;;; -;;; This software is made available AS IS, and Xerox Corporation makes no -;;; warranty about the software, its performance or its conformity to any -;;; specification. -;;; -;;; Any person obtaining a copy of this software is requested to send their -;;; name and post office or electronic mail address to: -;;; CommonLoops Coordinator -;;; Xerox PARC -;;; 3333 Coyote Hill Rd. -;;; Palo Alto, CA 94304 -;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) -;;; -;;; Suggestions, comments and requests for improvements are also welcome. -;;; ************************************************************************* -;;; - -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/plap.lisp,v 1.10 2001/03/13 15:49:49 pw Exp $") -;;; - -(in-package 'pcl) - -;;; -;;; The portable implementation of the LAP assembler. -;;; -;;; The portable implementation of the LAP assembler works by translating -;;; LAP code back into Lisp code and then compiling that Lisp code. Note -;;; that this implementation is actually going to get a lot of use. Some -;;; implementations (KCL) won't implement a native LAP assembler at all. -;;; Other implementations may not implement native LAP assemblers for all -;;; of their ports. All of this implies that this portable LAP assembler -;;; needs to generate the best code it possibly can. -;;; - - -;;; -;;; -;;; - -(defmacro lap-case (operand &body cases) - (once-only (operand) - `(ecase (car ,operand) - ,@(mapcar #'(lambda (case) - `(,(car case) - (apply #'(lambda ,(cadr case) ,@(cddr case)) - (cdr ,operand)))) - cases)))) - -(defvar *lap-args*) -(defvar *lap-rest-p*) -(defvar *lap-i-regs*) -(defvar *lap-v-regs*) -(defvar *lap-fv-regs*) -(defvar *lap-t-regs*) - -(defvar *lap-optimize-declaration* '#.*optimize-speed*) - - -(eval-when (load eval) - (setq *make-lap-closure-generator* - #'(lambda (closure-var-names arg-names index-regs - vector-regs fixnum-vector-regs t-regs lap-code) - (compile-lambda - (make-lap-closure-generator-lambda - closure-var-names arg-names index-regs - vector-regs fixnum-vector-regs t-regs lap-code))) - - *precompile-lap-closure-generator* - #'(lambda (cvars args i-regs v-regs fv-regs t-regs lap) - `(function - ,(make-lap-closure-generator-lambda cvars args i-regs - v-regs fv-regs t-regs lap))) - *lap-in-lisp* - #'(lambda (cvars args iregs vregs fvregs tregs lap) - (declare (ignore cvars args)) - (make-lap-prog - iregs vregs fvregs tregs - (flatten-lap lap ;(opcode :label 'exit-lap-in-lisp) - ))))) - -(defun make-lap-closure-generator-lambda (cvars args i-regs v-regs fv-regs t-regs lap) - (let* ((rest (memq '&rest args)) - (ldiff (and rest (ldiff args rest)))) - (when rest (setq args (append ldiff '(&rest .lap-rest-arg.)))) - (let* ((*lap-args* (if rest ldiff args)) - (*lap-rest-p* (not (null rest)))) - `(lambda ,cvars - #'(lambda ,args - ;; - ;; Use LOCALLY instead of a declare on the lambda so that we don't - ;; suppress arg count checking... - (locally (declare ,*lap-optimize-declaration*) - ,(make-lap-prog-internal i-regs v-regs fv-regs t-regs lap))))))) - -(defun make-lap-prog (i-regs v-regs fv-regs t-regs lap) - (let* ((*lap-args* 'lap-in-lisp) - (*lap-rest-p* 'lap-in-lisp)) - (make-lap-prog-internal i-regs v-regs fv-regs t-regs lap))) - -(defun make-lap-prog-internal (i-regs v-regs fv-regs t-regs lap) - (let* ((*lap-i-regs* i-regs) - (*lap-v-regs* v-regs) - (*lap-fv-regs* fv-regs) - (*lap-t-regs* t-regs) - (code (mapcar #'lap-opcode lap))) - `(prog ,(mapcar #'(lambda (reg) - `(,(lap-reg reg) - ,(lap-reg-initial-value-form reg))) - (append i-regs v-regs fv-regs t-regs)) - (declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*)) - (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*)) - (type cache-number-vector - ,@(mapcar #'lap-reg *lap-fv-regs*))) - ,.code))) - -(defvar *empty-vector* '#()) -(defvar *empty-fixnum-vector* - (make-array 8 - :element-type 'fixnum - :initial-element 0)) - -(defun lap-reg-initial-value-form (reg) - (cond ((member reg *lap-i-regs*) 0) - ((member reg *lap-v-regs*) '*empty-vector*) - ((member reg *lap-fv-regs*) '*empty-fixnum-vector*) - ((member reg *lap-t-regs*) nil) - (t - (error "What kind of register is ~S?" reg)))) - -(defun lap-opcode (opcode) - (lap-case opcode - (:move (from to) - `(setf ,(lap-operand to) ,(lap-operand from))) - - ((:eq :neq :fix=) (arg1 arg2 label) - `(when ,(lap-operands (ecase (car opcode) - (:eq 'eq) (:neq 'neq) (:fix= 'RUNTIME\ FIX=)) - arg1 - arg2) - (go ,label))) - - ((:izerop) (arg label) - `(when ,(lap-operands 'RUNTIME\ IZEROP arg) - (go ,label))) - - (:std-instance-p (from label) - `(when ,(lap-operands 'RUNTIME\ STD-INSTANCE-P from) (go ,label))) - (:fsc-instance-p (from label) - `(when ,(lap-operands 'RUNTIME\ FSC-INSTANCE-P from) (go ,label))) - (:built-in-instance-p (from label) - (declare (ignore from)) - `(when ,t (go ,label))) ;*** - (:structure-instance-p (from label) - `(when ,(lap-operands 'RUNTIME\ STRUCTURE-INSTANCE-P from) (go ,label))) ;*** - - ((:jmp :emf-call) (fn) - (if (eq *lap-args* 'lap-in-lisp) - (error "Can't do a :JMP in LAP-IN-LISP.") - `(return - ,(if (eq (car opcode) :jmp) - (if *lap-rest-p* - `(RUNTIME\ APPLY ,(lap-operand fn) ,@*lap-args* .lap-rest-arg.) - `(RUNTIME\ FUNCALL ,(lap-operand fn) ,@*lap-args*)) - `(RUNTIME\ EMF-CALL ,(lap-operand fn) ,*lap-rest-p* ,@*lap-args* - ,@(when *lap-rest-p* `(.lap-rest-arg.))))))) - - (:return (value) - `(return ,(lap-operand value))) - - (:label (label) label) - (:go (label) `(go ,label)) - - (:exit-lap-in-lisp () `(go exit-lap-in-lisp)) - - (:break () `(break)) - (:beep () ) - (:print (val) (lap-operands 'print val)) - )) - -(defun lap-operand (operand) - (lap-case operand - (:reg (n) (lap-reg n)) - (:cdr (reg) (lap-operands 'cdr reg)) - ((:cvar :arg) (name) name) - (:constant (c) `',c) - ((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper - :built-in-or-structure-wrapper :std-slots :fsc-slots - :wrapper-cache-number-vector) - (x) - (lap-operands (ecase (car operand) - (:std-wrapper 'RUNTIME\ STD-WRAPPER) - (:fsc-wrapper 'RUNTIME\ FSC-WRAPPER) - (:built-in-wrapper 'RUNTIME\ BUILT-IN-WRAPPER) - (:structure-wrapper 'RUNTIME\ STRUCTURE-WRAPPER) - (:built-in-or-structure-wrapper - 'RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER) - (:std-slots 'RUNTIME\ STD-SLOTS) - (:fsc-slots 'RUNTIME\ FSC-SLOTS) - (:wrapper-cache-number-vector - 'RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR)) - x)) - - - (:i1+ (index) (lap-operands 'RUNTIME\ I1+ index)) - (:i+ (index1 index2) (lap-operands 'RUNTIME\ I+ index1 index2)) - (:i- (index1 index2) (lap-operands 'RUNTIME\ I- index1 index2)) - (:ilogand (index1 index2) (lap-operands 'RUNTIME\ ILOGAND index1 index2)) - (:ilogxor (index1 index2) (lap-operands 'RUNTIME\ ILOGXOR index1 index2)) - - (:iref (vector index) (lap-operands 'RUNTIME\ IREF vector index)) - (:iset (vector index value) (lap-operands 'RUNTIME\ ISET vector index value)) - - (:instance-ref (vector index) - (lap-operands 'RUNTIME\ INSTANCE-REF vector index)) - (:instance-set (vector index value) - (lap-operands 'RUNTIME\ INSTANCE-SET vector index value)) - - (:cref (vector i) `(RUNTIME\ SVREF ,(lap-operand vector) ,i)) - (:lisp-variable (symbol) symbol) - (:lisp (form) form) - )) - -(defun lap-operands (fn &rest regs) - (cons fn (mapcar #'lap-operand regs))) - -(defun lap-reg (n) (intern (format nil "REG~D" n) *the-pcl-package*)) - - -;;; -;;; Runtime Implementations of the operands and opcodes. -;;; -;;; In those ports of PCL which choose not to completely re-implement the -;;; LAP code generator, it may still be provident to consider reimplementing -;;; one or more of these to get the compiler to produce better code. That -;;; is why they are split out. -;;; -(declaim (declaration pcl-fast-call)) - -(defmacro RUNTIME\ FUNCALL (fn &rest args) - `(funcall (the function ,fn) ,.args)) - -(defmacro RUNTIME\ APPLY (fn &rest args) - `(apply (the function ,fn) ,.args)) - -(defmacro RUNTIME\ EMF-CALL (emf restp &rest required-args+rest-arg) - `(invoke-effective-method-function ,emf ,restp ,@required-args+rest-arg)) - -(defmacro RUNTIME\ STD-WRAPPER (x) - `(std-instance-wrapper ,x)) - -(defmacro RUNTIME\ FSC-WRAPPER (x) - `(fsc-instance-wrapper ,x)) - -(defmacro RUNTIME\ BUILT-IN-WRAPPER (x) - `(built-in-wrapper-of ,x)) - -(defmacro RUNTIME\ STRUCTURE-WRAPPER (x) - `(built-in-or-structure-wrapper ,x)) - -(defmacro RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER (x) - `(built-in-or-structure-wrapper ,x)) - -(defmacro RUNTIME\ STRUCTURE-INSTANCE-P (x) - `(structure-instance-p ,x)) - -(defmacro RUNTIME\ STD-SLOTS (x) - `(std-instance-slots (the std-instance ,x))) - -(defmacro RUNTIME\ FSC-SLOTS (x) - `(fsc-instance-slots ,x)) - -(defmacro RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR (x) - `(wrapper-cache-number-vector ,x)) - -(defmacro RUNTIME\ STD-INSTANCE-P (x) - `(std-instance-p ,x)) - -(defmacro RUNTIME\ FSC-INSTANCE-P (x) - `(fsc-instance-p ,x)) - -(defmacro RUNTIME\ IZEROP (x) - `(zerop (the fixnum ,x))) - -(defmacro RUNTIME\ FIX= (x y) - `(= (the fixnum ,x) (the fixnum ,y))) - -;;; -;;; These are the implementations of the index operands. The portable -;;; assembler generates Lisp code that uses these macros. Even though -;;; the variables holding the arguments and results have type declarations -;;; on them, we put type declarations in here. -;;; -;;; Some compilers are so stupid... -;;; -(defmacro RUNTIME\ IREF (vector index) - `(aref ,vector (the fixnum ,index))) - -(defmacro RUNTIME\ ISET (vector index value) - `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value)) - -(defmacro RUNTIME\ INSTANCE-REF (vector index) - `(svref (the simple-vector ,vector) (the fixnum ,index))) - -(defmacro RUNTIME\ INSTANCE-SET (vector index value) - `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value)) - -(defmacro RUNTIME\ SVREF (vector fixnum) - `(aref ,vector (the fixnum ,fixnum))) - -(defmacro RUNTIME\ I+ (index1 index2) - `(the fixnum (+ (the fixnum ,index1) (the fixnum ,index2)))) - -(defmacro RUNTIME\ I- (index1 index2) - `(the fixnum (- (the fixnum ,index1) (the fixnum ,index2)))) - -(defmacro RUNTIME\ I1+ (index) - `(the fixnum (1+ (the fixnum ,index)))) - -(defmacro RUNTIME\ ILOGAND (index1 index2) - `(the fixnum (logand (the fixnum ,index1) (the fixnum ,index2)))) - -(defmacro RUNTIME\ ILOGXOR (index1 index2) - `(the fixnum (logxor (the fixnum ,index1) (the fixnum ,index2)))) - -;;; -;;; In the portable implementation, indexes are just fixnums. -;;; - -(defconstant index-value-limit most-positive-fixnum) - -(defun index-value->index (index-value) index-value) -(defun index->index-value (index) index) - -(defun make-index-mask (cache-size line-size) - (let ((cache-size-in-bits (floor (log cache-size 2))) - (line-size-in-bits (floor (log line-size 2))) - (mask 0)) - (dotimes (i cache-size-in-bits) (setq mask (dpb 1 (byte 1 i) mask))) - (dotimes (i line-size-in-bits) (setq mask (dpb 0 (byte 1 i) mask))) - mask)) - - diff --git a/pcl/quadlap.lisp b/pcl/quadlap.lisp deleted file mode 100644 index ad90099e53fda91099a6e68bb6c246cb19b7d716..0000000000000000000000000000000000000000 --- a/pcl/quadlap.lisp +++ /dev/null @@ -1,619 +0,0 @@ -;; -[Thu Mar 1 10:54:27 1990 by jkf]- -;; pcl to quad translation -;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.6 1997/02/06 21:24:19 pw Exp $ -;; -;; copyright (c) 1990 Franz Inc. -;; -(in-package :compiler) - - - - -(defvar *arg-to-treg* nil) -(defvar *cvar-to-index* nil) -(defvar *reg-array* nil) -(defvar *closure-treg* nil) -(defvar *nargs-treg* nil) - -(defvar *debug-sparc* nil) - -(defmacro pcl-make-lambda (&key required) - `(list 'lambda nil :unknown-type 0 compiler::.function-level. - ,required nil nil nil nil nil nil nil nil nil - nil 'compiler::none nil nil nil - nil nil nil nil nil nil 0 nil)) - -(defmacro pcl-make-varrec (&key name loc contour-level) - `(list ,name nil 0 nil ,loc nil t compiler::.function-level. nil nil :unknown-type nil nil ,contour-level)) - -(defmacro pcl-make-lap (&key lap constants cframe-size locals) - `(list nil ,constants ,lap nil nil ,cframe-size ,locals nil nil nil)) - - -(defstruct preg - ;; pseudo reg descritpor - treg ; associated treg - index ; :index if this is an index type reg - ; :vector if this is a vector type reg - ) - - -(defun pcl::excl-lap-closure-generator (closure-vars-names - arg-names - index-regs - vector-regs - fixnum-vector-regs - t-regs - lap-code) - (let ((function (pcl::excl-lap-closure-gen closure-vars-names - arg-names - index-regs - (append vector-regs fixnum-vector-regs) - t-regs - lap-code))) - #'(lambda (&rest closure-vals) - (insert-closure-vals function closure-vals)))) - - -(defun pcl::excl-lap-closure-gen - (closure-vars-names arg-names index-regs vector-regs t-regs lap-code) - (let ((*quads* nil) - (*treg-num* 0) - (*all-tregs* nil) - (*bb-count* 0) - *treg-bv-size* - *treg-vector* - (*next-catch-frame* 0) - (*max-catch-frame* -1) - *catch-labels* - *top-label* - *mv-treg* - *mv-treg-target* - *zero-treg* - *nil-treg* - *bbs* *bb* lap - ;; bbs - *cross-block-regs* - *const-tregs* *move-tregs* - *actuals* - *ignore-argcount* - *binds-specs* - *bvl-current-bv* ; for bitvector cacher - *bvl-used-bvs* - *bvl-index* - (*inhibit-call-count* t) - - ; this fcn - *arg-to-treg* - *cvar-to-index* - *reg-array* - minargs - maxargs - *closure-treg* - - node - otherargregs - - *nargs-treg* - ) - - (if* *debug-sparc* - then (format t ">>** << Generating sparc lap code~%")) - - (setq *nil-treg* - #+allegro-v4.0 (new-reg :global t) - #-allegro-v4.0 (new-reg) - *mv-treg* (new-reg) - *mv-treg-target* (list *mv-treg*) - *zero-treg* (comp::new-reg)) - - ; examine given args - - (setq minargs 0 maxargs 0) - (let (requireds) - (dolist (arg arg-names) - (if* (eq '&rest arg) - then (setq maxargs nil) - else (if* (null arg) - then ; we want a name even though we won't use it - (setq arg (gensym))) - (incf minargs) - (incf maxargs) - (push (cons arg (new-reg)) *arg-to-treg*) - (push (pcl-make-varrec :name arg - :loc (cdr (car *arg-to-treg*)) - :contour-level 0) - requireds) - )) - (setq node (pcl-make-lambda :required (nreverse requireds)))) - (setq *arg-to-treg* (nreverse *arg-to-treg*)) - - ; build closure vector list - (let ((index -1)) - (dolist (cvar closure-vars-names) - (push (cons cvar (incf index)) *cvar-to-index*))) - - (let ((maxreg (max (apply #'max (cons -1 index-regs)) - (apply #'max (cons -1 vector-regs)) - (apply #'max (cons -1 t-regs))))) - (setq *reg-array* (make-array (1+ maxreg)))) - - (dolist (index index-regs) - (setf (svref *reg-array* index) - (make-preg :treg (new-reg) - :index :index))) - - (dolist (vector vector-regs) - (setf (svref *reg-array* vector) - (make-preg :treg (new-reg) - :index :vector))) - - (dolist (tr t-regs) - (setf (svref *reg-array* tr) (make-preg :treg (new-reg)))) - - - (if* closure-vars-names - then (setq *closure-treg* (new-reg))) - (setq *nargs-treg* (new-reg)) - - ;; (md-allocate-global-tregs) - - ; function entry - (qe nop :arg :first-block) - (qe entry) - (qe argcount :arg (list minargs maxargs)) - (qe lambda :d (mapcar #'cdr *arg-to-treg*)) - (qe register :arg :nargs :d (list *nargs-treg*)) - - (if* *closure-treg* - then ; put the first closure vector in *closure-treg* - (qe extract-closure-vec :d (list *closure-treg*)) - (let ((offsetreg (new-reg))) - (qe const :arg (mdparam 'md-cons-car-adj) :d (list offsetreg)) - (qe ref :u (list *closure-treg* offsetreg) - :d (list *closure-treg*) - :arg :long)) - ) - - (excl-gen-quads lap-code) - - (if* *debug-sparc* - then (do-quad-list (quad next *quads*) - (format t "~a~%" quad)) - - (format t "basic blocks~%")) - - (setq *bbs* (qc-compute-basic-blocks *quads*)) - - (excl::target-class-case - ((:r :m) (setq *actuals* (qc-compute-actuals *bbs*)))) - - (qc-live-variable-analysis *bbs*) - - (setq *treg-bv-size* (* 16 (truncate (+ *treg-num* 15) 16))) - - (qc-build-treg-vector) - - - (let ((*dump-bbs* nil) - (r::*local-regs* - ; use the in registers that aren't in use - (append r::*local-regs* - (if* maxargs - then (nthcdr maxargs r::*in-regs* ))))) - (unwind-protect - (progn - ; machine specific code generation - (multiple-value-bind (lap-code literals size-struct locals) - #+(target-class r m e) - (progn - #+allegro-v4.0 - (md-codegen node *bbs* - nil otherargregs) - #-allegro-v4.0 - (md-codegen node *bbs* - *nil-treg* *mv-treg* *zero-treg* - nil otherargregs)) - - #-(target-class r m e) (md-codegen node *bbs*) - (setq lap - (pcl-make-lap :lap lap-code - :constants literals - :cframe-size size-struct - :locals locals))) - - - lap) - (giveback-bvs))) - - #+ignore - (progn (format t "sparc code pre optimization~%") - (dolist (instr (lap-lap lap)) - (format t "> ~a~%" instr))) - (md-optimize lap) ; peephole optimize - (if* *debug-sparc* - then (format t "sparc code post optimization~%") - (dolist (instr (lap-lap lap)) - (format t "> ~a~%" instr))) - (md-assemble lap) - (setq last-lap lap) - - (nl-runtime-make-a-fcnobj lap))) - -(defun qe-slot-access (operand offset dest) - ;; access a slot in a structure - (let ((temp (new-reg))) - (qe const :arg offset :d (list temp)) - (qe ref :u (list (get-treg-of operand) temp) - :d (list (get-treg-of dest)) - :arg :long))) - - -(defun get-treg-of (operand &optional res-operand) - ;; get the appropriate treg for the operand - (let ((prefer-treg (and res-operand (simple-get-treg-of res-operand)))) - (if* (numberp operand) - then (let ((treg (new-reg))) - (qe const :arg operand :d (list treg)) - treg) - elseif (consp operand) - then (ecase (car operand) - (:reg - (preg-treg (svref *reg-array* (cadr operand)))) - (:arg - (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq)))) - (if* (null x) - then (error "where is arg ~s" operand) - else x))) - (:cvar - (let ((res-treg (or prefer-treg (new-reg))) - (temp-treg (new-reg))) - (qe const :arg (+ (mdparam 'md-svector-data0-adj) - (* 4 (cdr (assoc (cadr operand) - *cvar-to-index* - :test #'eq)))) - :d (list temp-treg)) - (qe ref :u (list *closure-treg* temp-treg) - :d (list res-treg) - :arg :long) - res-treg)) - (:constant - (let ((treg (or prefer-treg (new-reg)))) - (qe const :arg (if* (fixnump (cadr operand)) - then (* 8 (cadr operand)) ; md!! - else (cadr operand)) - :d (list treg)) - treg)) - (:index-constant - ; operand invented by jkf to denote an index type constant - (let ((treg (or prefer-treg (new-reg)))) - (qe const :arg (if* (fixnump (cadr operand)) - then (* 4 (cadr operand)) ; md!! - else (cadr operand)) - :d (list treg)) - treg))) - else (error "bad operand: ~s" operand)))) - -(defun simple-get-treg-of (operand) - ;; get the treg if it is so simple that we don't have to - ;; emit any instructions to access it. - ;; return nil if we can't do it. - (if* (numberp operand) - then nil - elseif (consp operand) - then (case (car operand) - (:reg - (preg-treg (svref *reg-array* (cadr operand)))) - (:arg - (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq)))) - (if* (null x) - then nil - else x)))) - - else nil)) - -(defun index-p (operand) - ;; determine if the result of this operand is an index value - ;* it would be better if conversion between lisp values and - ; index values were made explicit in the lap code - (and (consp operand) - (or (and (eq :reg (car operand)) - (eq :index (preg-index (svref *reg-array* (cadr operand))))) - (member (car operand) - '(:i+ :i- :ilogand :ilogxor :i1+) - :test #'eq)) - t)) - -(defun gen-index-treg (operand) - ;; return the non-index type operand in a index treg - (if* (and (consp operand) - (eq ':constant (car operand))) - then (get-treg-of `(:index-constant ,(cadr operand))) - else (let ((treg (get-treg-of operand)) - (new-reg (new-reg)) - (shift-reg (new-reg))) - (qe const :arg 1 :d (list shift-reg)) - (qe lsr :u (list treg shift-reg) :d (list new-reg)) - new-reg))) - - - - - -(defun vector-preg-p (operand) - (and (consp operand) - (eq :reg (car operand)) - (eq :vector (preg-index (svref *reg-array* (cadr operand)))))) - - - -(defun excl-gen-quads (laps) - ;; generate quads from the lap - (dolist (lap laps) - (if* *debug-sparc* then (format t ">> ~a~%" lap)) - (block again - (let ((opcode (car lap)) - (op1 (cadr lap)) - (op2 (caddr lap))) - (case opcode - (:move - ; can be either simple (both args registers) - ; or one arg can be complex and the other simple - (case (car op2) - ((:iref :instance-ref) - ;; assume that this is a lisp store - ;;(warn "assuming lisp store in ~s" lap) - (let (op1-treg) - (if* (not (vector-preg-p (cadr op2))) - then ; must offset before store - (error "must use vector register in ~s" lap) - else (setq op1-treg (get-treg-of (cadr op2)))) - - - - (qe set :u (list op1-treg - (get-treg-of (caddr op2)) - (get-treg-of op1)) - :arg :lisp) - (return-from again))) - (:cdr - ;; it certainly is a lisp stoer - (let (op1-treg const-reg) - (setq op1-treg (get-treg-of (cadr op2))) - (setq const-reg (new-reg)) - (qe const :arg (mdparam 'md-cons-cdr-adj) - :d (list const-reg)) - - - - (qe set :u (list op1-treg - const-reg - (get-treg-of op1)) - :arg :lisp) - (return-from again)))) - - ; the 'to'address is simple, the from address may not be - - (let ((index1 (index-p op1)) - (index2 (index-p op2)) - (vector1 (vector-preg-p op1)) - (vector2 (vector-preg-p op2))) - (ecase (car op1) - ((:reg :cvar :arg :constant :lisp-symbol) - (qe move - :u (list (get-treg-of op1 op2)) - :d (list (get-treg-of op2)))) - (:std-wrapper - (qe-slot-access (cadr op1) - (+ (* 1 4) - (comp::mdparam 'md-svector-data0-adj)) - op2)) - (:std-slots - (qe-slot-access (cadr op1) - (+ (* 2 4) - (comp::mdparam 'md-svector-data0-adj)) - op2)) - (:fsc-wrapper - (qe-slot-access (cadr op1) - (+ (* (- 15 1) 4) - (comp::mdparam 'md-function-const0-adj)) - op2)) - (:fsc-slots - (qe-slot-access (cadr op1) - (+ (* (- 15 2) 4) - (comp::mdparam 'md-function-const0-adj)) - op2)) - ((:built-in-wrapper :structure-wrapper :built-in-or-structure-wrapper) - (qe call :arg 'pcl::built-in-or-structure-wrapper - :u (list (get-treg-of (cadr op1))) - :d (list (get-treg-of op2)))) - (:other-wrapper - (warn "do other-wrapper")) - ((:i+ :i- :ilogand :ilogxor) - (qe arith :arg (cdr (assoc (car op1) - '((:i+ . :+) - (:i- . :-) - (:ilogand . :logand) - (:ilogxor . :logxor)) - :test #'eq)) - :u (list (get-treg-of (cadr op1)) - (get-treg-of (caddr op1))) - :d (list (get-treg-of op2)))) - (:i1+ - (let ((const-reg (new-reg))) - (qe const :arg 4 ; an index value of 1 - :d (list const-reg)) - (qe arith :arg :+ - :u (list const-reg - (get-treg-of (cadr op1))) - :d (list (get-treg-of op2))))) - - ((:iref :cref :instance-ref) - (let (op1-treg) - (if* (not (vector-preg-p (cadr op1))) - then ; must offset before store - (error "must use vector register in ~s" lap) - else (setq op1-treg (get-treg-of (cadr op1)))) - - (qe ref :u (list op1-treg - (get-treg-of (caddr op1) op2)) - :d (list (get-treg-of op2)) - :arg :long))) - (:cdr - (let ((const-reg (new-reg))) - (qe const :arg (mdparam 'md-cons-cdr-adj) - :d (list const-reg)) - (qe ref :arg :long - :u (list (get-treg-of (cadr op1)) - const-reg) - :d (list (get-treg-of op2)))))) - (if* (not (eq index1 index2)) - then (let ((shiftamt (new-reg))) - (qe const :arg 1 :d (list shiftamt)) - (if* (and index1 (not index2)) - then ; converting from index to non-index - (qe lsl :u (list (get-treg-of op2) shiftamt) - :d (list (get-treg-of op2))) - elseif (and (not index1) index2) - ; converting to an index - then (qe lsr :u (list (get-treg-of op2) shiftamt) - :d (list (get-treg-of op2))))) - elseif (and vector2 (not vector1)) - then ; add vector offset - (let ((tempreg (new-reg)) - (vreg (get-treg-of op2))) - (qe const :arg (mdparam 'md-svector-data0-adj) - :d (list tempreg)) - (qe arith :arg :+ :u (list vreg tempreg) - :d (list vreg)))))) - (:fix= - (let (tr1 tr2) - (if* (index-p op1) - then (setq tr1 (get-treg-of op1)) - (if* (not (index-p op2)) - then (setq tr2 (gen-index-treg op2)) - else (setq tr2 (get-treg-of op2))) - elseif (index-p op2) - then ; assert: op1 isn't an index treg - (setq tr1 (gen-index-treg op1)) - (setq tr2 (get-treg-of op2)) - else (setq tr1 (get-treg-of op1) - tr2 (get-treg-of op2))) - - - - (qe bcc :u (list tr1 tr2) - :arg (cadddr lap) - :arg2 :eq ))) - ((:eq :neq :fix=) - (if* (not (eq (index-p op1) (index-p op2))) - then (error "non matching operands indexwise in: ~s" lap)) - (qe bcc :u (list (get-treg-of op1) - (get-treg-of op2)) - :arg (cadddr lap) - :arg2 (cdr (assoc opcode '((:eq . :eq) - (:neq . :ne)) - :test #'eq)))) - (:izerop - (qe bcc :u (list (get-treg-of op1) - *zero-treg*) - :arg (caddr lap) - :arg2 :eq)) - (:std-instance-p - (let ((treg (get-treg-of op1)) - (tempreg (new-reg)) - (temp2reg (new-reg)) - (offsetreg (new-reg)) - (nope (pc-genlab))) - (qe typecheck :u (list treg) - :arg nope - :arg2 '(not structure)) - (qe const :arg 'pcl::std-instance :d (list tempreg)) - (qe const :arg (mdparam 'md-svector-data0-adj) - :d (list offsetreg)) - (qe ref :u (list treg offsetreg) - :d (list temp2reg) - :arg :long) - (qe bcc :arg2 :eq :u (list tempreg temp2reg) - :arg (caddr lap)) - (qe label :arg nope))) - - (:fsc-instance-p - (let ((treg (get-treg-of op1)) - (nope (pc-genlab)) - (offsetreg (new-reg)) - (tempreg (new-reg)) - (checkreg (new-reg))) - (qe typecheck :u (list treg) - :arg nope - :arg2 '(not compiled-function)) - (qe const :arg (mdparam 'md-function-flags-adj) - :d (list offsetreg)) - (qe ref :u (list treg offsetreg) :d (list tempreg) - :arg :ubyte) - (qe const :arg pcl::funcallable-instance-flag-bit - :d (list checkreg)) - (qe bcc :u (list checkreg tempreg) - :arg (caddr lap) - :arg2 :bit-and) - (qe label :arg nope))) - (:built-in-instance-p - ; always true - (qe bra :arg (caddr lap))) - (:jmp - (qe tail-funcall :u (list *nargs-treg* (get-treg-of op1)))) - (:structure-instance-p - ; always true - (qe bra :arg (caddr lap))) - - (:return - (let (op-treg) - (if* (index-p op1) - then ; convert to lisp before returning - (let ((shiftamt (new-reg))) - (setq op-treg (new-reg)) - (qe const :arg 1 :d (list shiftamt)) - (qe lsl :u (list (get-treg-of op1) shiftamt) - :d (list op-treg))) - else (setq op-treg (get-treg-of op1))) - - (qe move :u (list op-treg) :d *mv-treg-target*) - (qe return :u *mv-treg-target*))) - - (:go - (qe bra :arg (cadr lap))) - - (:label - (qe label :arg (cadr lap))) - - - - (t (warn "ignoring ~s" lap))))))) - - -(defun insert-closure-vals (function closure-vals) - ;; build a fucntion from the lap and insert - (let ((newfun (sys::copy-function function))) - (setf (excl::fn_closure newfun) (list (apply 'vector closure-vals))) - newfun)) - - - -; test case: -; (pcl::defclass foo () (a b c)) -; (pcl::defmethod barx ((a foo) b c) a ) -; (apply 'pcl::excl-lap-closure-generator pcl::*tcase*) -; -; to turn it on - -(if* (not (and (boundp 'user::noquad) - (symbol-value 'user::noquad))) - then (setq pcl::*make-lap-closure-generator* - 'pcl::excl-lap-closure-generator)) - - - - - - - diff --git a/pcl/time.lisp b/pcl/time.lisp deleted file mode 100644 index 2b5d9cbfe734153e8bab2c2d47dd2eae98c35c7b..0000000000000000000000000000000000000000 --- a/pcl/time.lisp +++ /dev/null @@ -1,156 +0,0 @@ -(in-package "PCL") - -(declaim (optimize (speed 3)(safety 0)(compilation-speed 0))) - -(defvar *tests*) -(setq *tests* nil) - -(defvar m (car (generic-function-methods #'shared-initialize))) -(defvar gf #'shared-initialize) -(defvar c (find-class 'standard-class)) - -(defclass str () - ((slot :initform nil :reader str-slot)) - (:metaclass structure-class)) - -(defvar str (make-instance 'str)) - - -(push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)" - '(time-slot-value m 'plist 10000)) - *tests*) -(push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)" - '(time-slot-value m 'generic-function 10000)) - *tests*) -(push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (structure)" - '(time-slot-value str 'slot 10000)) - *tests*) -(defun time-slot-value (object slot-name n) - (time (dotimes (i n) (slot-value object slot-name)))) - - -(push (cons "Time optimized slot-value outside of a defmethod. Case (2). (standard)" - '(time-slot-value-function m 10000)) - *tests*) -(defun time-slot-value-function (object n) - (time (dotimes (i n) (slot-value object 'function)))) - - -(push (cons "Time optimized slot-value outside of a defmethod. Case (2). (structure)" - '(time-slot-value-slot str 10000)) - *tests*) -(defun time-slot-value-slot (object n) - (time (dotimes (i n) (slot-value object 'slot)))) - - -(push (cons "Time one-class dfun." - '(time-generic-function-methods gf 10000)) - *tests*) -(defun time-generic-function-methods (object n) - (time (dotimes (i n) (generic-function-methods object)))) - - -(push (cons "Time one-index dfun." - '(time-class-precedence-list c 10000)) - *tests*) -(defun time-class-precedence-list (object n) - (time (dotimes (i n) (class-precedence-list object)))) - - -(push (cons "Time n-n dfun." - '(time-method-function m 10000)) - *tests*) -(defun time-method-function (object n) - (time (dotimes (i n) (method-function object)))) - - -(push (cons "Time caching dfun." - '(time-class-slots c 10000)) - *tests*) -(defun time-class-slots (object n) - (time (dotimes (i n) (class-slots object)))) - - -(push (cons "Time typep for classes." - '(time-typep-standard-object m 10000)) - *tests*) -(defun time-typep-standard-object (object n) - (time (dotimes (i n) (typep object 'standard-object)))) - - -(push (cons "Time default-initargs." - '(time-default-initargs (find-class 'plist-mixin) 1000)) - *tests*) -(defun time-default-initargs (class n) - (time (dotimes (i n) (default-initargs class nil)))) - - -(push (cons "Time make-instance." - '(time-make-instance (find-class 'plist-mixin) 1000)) - *tests*) -(defun time-make-instance (class n) - (time (dotimes (i n) (make-instance class)))) - -(push (cons "Time constant-keys make-instance." - '(time-constant-keys-make-instance 1000)) - *tests*) - -(expanding-make-instance-top-level -(defun constant-keys-make-instance (n) - (dotimes (i n) (make-instance 'plist-mixin)))) - -(precompile-random-code-segments) - -(defun time-constant-keys-make-instance (n) - (time (constant-keys-make-instance n))) - -(defun expand-all-macros (form) - (walk-form form nil #'(lambda (form context env) - (if (and (eq context :eval) - (consp form) - (symbolp (car form)) - (not (special-form-p (car form))) - (macro-function (car form))) - (values (macroexpand form env)) - form)))) - -(push (cons "Macroexpand meth-structure-slot-value" - '(pprint (multiple-value-bind (pgf pm) - (prototypes-for-make-method-lambda - 'meth-structure-slot-value) - (expand-defmethod - 'meth-structure-slot-value pgf pm - nil '((object str)) - '(#'(lambda () (slot-value object 'slot))) - nil)))) - *tests*) - -#-kcl -(push (cons "Show code for slot-value inside a defmethod for a structure-class. Case (3)." - '(disassemble (meth-structure-slot-value str))) - *tests*) -(defmethod meth-structure-slot-value ((object str)) - #'(lambda () (slot-value object 'slot))) - - -#|| ; interesting, but long. (produces 100 lines of output) -(push (cons "Macroexpand meth-standard-slot-value" - '(pprint (expand-all-macros - (expand-defmethod-internal 'meth-standard-slot-value - nil '((object standard-method)) - '(#'(lambda () (slot-value object 'function))) - nil)))) - *tests*) -(push (cons "Show code for slot-value inside a defmethod for a standard-class. Case (4)." - '(disassemble (meth-standard-slot-value m))) - *tests*) -(defmethod meth-standard-slot-value ((object standard-method)) - #'(lambda () (slot-value object 'function))) -||# - - -(defun do-tests () - (dolist (doc+form (reverse *tests*)) - (format t "~&~%~A~%" (car doc+form)) - (pprint (cdr doc+form)) - (eval (cdr doc+form))))