diff --git a/bootfiles/18e/boot16.lisp b/bootfiles/18e/boot16.lisp new file mode 100644 index 0000000000000000000000000000000000000000..c8314780a21a9e34dcc3bce2b1a2dda3cbe67731 --- /dev/null +++ b/bootfiles/18e/boot16.lisp @@ -0,0 +1,23 @@ +;;; +;;; Bootstrap file for adding an IR1 attribute. +;;; + +(in-package :c) + +(handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'continue)))) + (def-boolean-attribute ir1 + call + unsafe + unwind + any + foldable + flushable + movable + predicate + recursive + explicit-check + dynamic-extent-closure-safe)) + +;;; End of file. diff --git a/code/byte-interp.lisp b/code/byte-interp.lisp index c0c4c5a3381f5adc388cea99b50265d8f6cd6742..3bf7429314e8683cfc65675af352081696702887 100644 --- a/code/byte-interp.lisp +++ b/code/byte-interp.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.39 2003/07/16 09:51:57 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/byte-interp.lisp,v 1.40 2003/08/25 20:51:01 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -42,6 +42,18 @@ (deftype return-pc () `(integer ,(- max-pc) ,max-pc)) + +;;; These dummies are defined here, to make a build without compiler +;;; work. + +(defun %dynamic-extent (kind sp) + (declare (ignore kind sp))) + +(defun %dynamic-extent-start ()) + +(defun %dynamic-extent-end (kind sp) + (declare (ignore kind sp))) + ;;;; Byte functions: @@ -987,8 +999,8 @@ ;;; dispatch tree. ;;; -#+nil (declaim (start-block byte-interpret byte-interpret-byte - invoke-xep invoke-local-entry-point)) +(declaim (start-block byte-interpret byte-interpret-byte + invoke-xep invoke-local-entry-point)) (defvar *byte-trace* nil) @@ -1521,5 +1533,5 @@ (push-eval-stack num-results) (byte-interpret old-component (- old-pc) old-fp))))) -;(declaim (end-block byte-interpret byte-interpret-byte invoke-xep)) +(declaim (end-block byte-interpret byte-interpret-byte invoke-xep)) diff --git a/code/exports.lisp b/code/exports.lisp index 38ac5bd070911a9f051034f0c465be4c068e1896..ad741c21da51523be4fd30fbca4b80e31ab26cef 100644 --- a/code/exports.lisp +++ b/code/exports.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.222 2003/08/08 11:32:52 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.223 2003/08/25 20:51:01 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1582,7 +1582,9 @@ "%SET-FUNCTION-SELF" "IR2-COMPONENT-DYNCOUNT-INFO" "DYNCOUNT-INFO" "DYNCOUNT-INFO-P" - "TRUST-DYNAMIC-EXTENT-DECLARATION-P") + "TRUST-DYNAMIC-EXTENT-DECLARATION-P" + "IR2-STACK-ALLOCATE" + "%DYNAMIC-EXTENT" "%DYNAMIC-EXTENT-START" "%DYNAMIC-EXTENT-END") ) (defpackage "XREF" (:export "INIT-XREF-DATABASE" diff --git a/compiler/alpha/alloc.lisp b/compiler/alpha/alloc.lisp index 4b015afefa9e2606267fec383889e3cbef617747..6126a9a56d1ab1eed042d7a9c02e3298d0a6b35b 100644 --- a/compiler/alpha/alloc.lisp +++ b/compiler/alpha/alloc.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/alloc.lisp,v 1.4 2003/08/06 21:10:35 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/alpha/alloc.lisp,v 1.5 2003/08/25 20:50:59 gerd Rel $") ;;; ;;; ********************************************************************** ;;; @@ -17,6 +17,21 @@ (in-package "ALPHA") + +;;;; Dynamic-Extent (not implemented). + +(define-vop (%dynamic-extent-start) + (:args (saved-stack-pointer :scs (any-reg))) + (:results) + (:policy :safe) + (:generator 0)) + +(define-vop (%dynamic-extent-end) + (:args (saved-stack-pointer :scs (any-reg))) + (:results) + (:policy :safe) + (:generator 0)) + ;;;; LIST and LIST* @@ -26,7 +41,7 @@ (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) res) - (:info num) + (:info num dynamic-extent) (:results (result :scs (descriptor-reg))) (:variant-vars star) (:policy :safe) @@ -155,7 +170,7 @@ (define-vop (fixed-alloc) (:args) - (:info name words type lowtag) + (:info name words type lowtag dynamic-extent) (:ignore name) (:results (result :scs (descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) temp) diff --git a/compiler/byte-comp.lisp b/compiler/byte-comp.lisp index 92c061e58802ed8339e3fe9c726c19329919c260..0b93ee89f190ccf558f77893049ac0230084f3f9 100644 --- a/compiler/byte-comp.lisp +++ b/compiler/byte-comp.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/byte-comp.lisp,v 1.35 2003/07/16 09:51:57 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/byte-comp.lisp,v 1.36 2003/08/25 20:51:00 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -695,7 +695,7 @@ ;; ;; If for a lexical exit, we will see a breakup later, so ;; don't consume :NLX-ENTRY now. - (:tagbody) + ((:tagbody :dynamic-extent)) (:block (let ((cont (nlx-info-continuation nlx-info))) (when (interesting cont) diff --git a/compiler/envanal.lisp b/compiler/envanal.lisp index ebdc818ca32b25b6e9c2a15cda03f963ec5fe851..90b39b75c32ff7de83ae7a93fddc82583e6c9758 100644 --- a/compiler/envanal.lisp +++ b/compiler/envanal.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/envanal.lisp,v 1.29 2003/06/03 12:22:37 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/envanal.lisp,v 1.30 2003/08/25 20:51:00 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -49,6 +49,7 @@ (find-non-local-exits component) (find-cleanup-points component) + (find-dynamic-extent-safe-closures component) (tail-annotate component) (dolist (fun (component-lambdas component)) @@ -348,7 +349,11 @@ (code `(%lexical-exit-breakup ',nlx))))) (t (dolist (nlx (cleanup-nlx-info cleanup)) - (code `(%lexical-exit-breakup ',nlx))))))))) + (code `(%lexical-exit-breakup ',nlx)))))) + (:dynamic-extent + (let ((kind (continuation-value (first args))) + (sp (unless *byte-compiling* (second args)))) + (code `(%dynamic-extent-end ',kind ',sp))))))) (when (code) (assert (not (node-tail-p (block-last block1)))) @@ -358,7 +363,7 @@ (dolist (fun (reanalyze-funs)) (local-call-analyze-1 fun))))) - (undefined-value)) + (values)) ;;; Find-Cleanup-Points -- Internal @@ -409,3 +414,78 @@ (eq (basic-combination-kind use) :local))) (setf (node-tail-p use) t))))))) (undefined-value)) + + +;;;; Dynamic-Extent Closures + +(defvar *suppress-dynamic-extent-safe-closures* nil) + +;;; +;;; Mark closures that can be allocated on the stack because they are +;;; passed to functions that are known as dynamic-extent-closure-safe. +;;; Return a list of combinations taking such closures. +;;; +(defun mark-dynamic-extent-safe-closures (component) + (declare (type component component)) + (collect ((combinations)) + (do-blocks (block component) + (do-nodes (node cont block) + (when (and (combination-p node) + (let ((info (basic-combination-kind node))) + (and (function-info-p info) + (ir1-attributep (function-info-attributes info) + dynamic-extent-closure-safe)))) + (dolist (arg (combination-args node)) + (when (and arg + (not (continuation-dynamic-extent arg)) + (ref-p (continuation-use arg)) + (let ((leaf (ref-leaf (continuation-use arg)))) + (and (lambda-p leaf) + (environment-closure + (get-lambda-environment leaf))))) + (setf (continuation-dynamic-extent arg) t) + (combinations node)))))) + (combinations))) + +;;; +;;; Find some more closures that can be allocated with dynamic extent +;;; because they are arguments to functions that are declared +;;; dynamic-extent-safe. +;;; +(defun find-dynamic-extent-safe-closures (component) + (declare (type component component)) + (flet ((insert-dynamic-extent-start (combination) + (declare (type combination combination)) + (let ((fun (basic-combination-fun combination))) + (ensure-block-start fun) + (let* ((block (continuation-block fun)) + (pred (first (block-pred block)))) + (assert (= 1 (length (block-pred block)))) + (assert (= 1 (length (block-succ pred)))) + (assert (not (eq pred (component-head (block-component block))))) + (let ((cleanup (insert-cleanup-code + pred block combination + `(%dynamic-extent :closure + (%dynamic-extent-start))))) + (second (basic-combination-args (block-last cleanup))))))) + + (insert-dynamic-extent-end (combination start-cont) + (declare (type combination combination) + (type continuation start-cont)) + (let* ((call-block (node-block combination))) + (ensure-block-start (node-cont combination)) + (assert (= 1 (length (block-succ call-block)))) + (insert-cleanup-code + call-block (first (block-succ call-block)) combination + `(%dynamic-extent-end :closure ',start-cont))))) + + (unless (or *byte-compiling* *suppress-dynamic-extent-safe-closures*) + (dolist (combination (mark-dynamic-extent-safe-closures component)) + (let ((cont (insert-dynamic-extent-start combination))) + (insert-dynamic-extent-end combination cont) + (when *dynamic-extent-trace* + (format t "~&===> dynamic-extent-safe closure in ~s~%" + (component-name component)))))) + + (values))) + diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp index 104e649b0bc3098c87df799a76ca12f07ddf6e8c..4af53fa903456c18fb270116da072fe8a9cdb8bc 100644 --- a/compiler/fndb.lisp +++ b/compiler/fndb.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.124 2003/08/16 11:45:47 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.125 2003/08/25 20:51:00 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -133,9 +133,10 @@ (defknown funcall (callable &rest t) *) (defknown (mapcar maplist mapcan mapcon) (callable list &rest list) list - (call)) + (call dynamic-extent-closure-safe)) -(defknown (mapc mapl) (callable list &rest list) list (foldable call)) +(defknown (mapc mapl) (callable list &rest list) list + (foldable call dynamic-extent-closure-safe)) ;;; We let values-list be foldable, since constant-folding will turn it into ;;; VALUES. VALUES is not foldable, since MV constants are represented by a @@ -412,27 +413,27 @@ :derive-type (result-type-specifier-nth-arg 1)) (defknown map (type-specifier callable sequence &rest sequence) consed-sequence - (flushable call) + (flushable call dynamic-extent-closure-safe) ; :derive-type 'type-spec-arg1 Nope... (map nil ...) returns null, not nil. ) (defknown map-into (sequence callable &rest sequence) sequence - (call) + (call dynamic-extent-closure-safe) :derive-type #'result-type-first-arg) ;;; Returns predicate result... (defknown some (callable sequence &rest sequence) t - (foldable flushable call)) + (foldable flushable call dynamic-extent-closure-safe)) (defknown (every notany notevery) (callable sequence &rest sequence) boolean - (foldable flushable call)) + (foldable flushable call dynamic-extent-closure-safe)) ;;; Unsafe for :Initial-Value... (defknown reduce (callable sequence &key (:from-end t) (:start index) (:end sequence-end) (:initial-value t) (:key callable)) t - (foldable flushable call unsafe)) + (foldable flushable call unsafe dynamic-extent-closure-safe)) (defknown fill (sequence t &key (:start index) (:end sequence-end)) sequence (unsafe) @@ -448,7 +449,7 @@ (:test-not callable) (:start index) (:end sequence-end) (:count sequence-count) (:key callable)) consed-sequence - (flushable call) + (flushable call dynamic-extent-closure-safe) :derive-type (sequence-result-nth-arg 2)) (defknown substitute @@ -456,21 +457,21 @@ (:test-not callable) (:start index) (:end sequence-end) (:count sequence-count) (:key callable)) consed-sequence - (flushable call) + (flushable call dynamic-extent-closure-safe) :derive-type (sequence-result-nth-arg 3)) (defknown (remove-if remove-if-not) (callable sequence &key (:from-end t) (:start index) (:end sequence-end) (:count sequence-count) (:key callable)) consed-sequence - (flushable call) + (flushable call dynamic-extent-closure-safe) :derive-type (sequence-result-nth-arg 2)) (defknown (substitute-if substitute-if-not) (t callable sequence &key (:from-end t) (:start index) (:end sequence-end) (:count sequence-count) (:key callable)) consed-sequence - (flushable call) + (flushable call dynamic-extent-closure-safe) :derive-type (sequence-result-nth-arg 3)) (defknown delete @@ -478,7 +479,7 @@ (:test-not callable) (:start index) (:end sequence-end) (:count sequence-count) (:key callable)) sequence - (flushable call) + (flushable call dynamic-extent-closure-safe) :derive-type (sequence-result-nth-arg 2)) (defknown nsubstitute @@ -486,88 +487,88 @@ (:test-not callable) (:start index) (:end sequence-end) (:count sequence-count) (:key callable)) sequence - (flushable call) + (flushable call dynamic-extent-closure-safe) :derive-type (sequence-result-nth-arg 3)) (defknown (delete-if delete-if-not) (callable sequence &key (:from-end t) (:start index) (:end sequence-end) (:count sequence-count) (:key callable)) sequence - (flushable call) + (flushable call dynamic-extent-closure-safe) :derive-type (sequence-result-nth-arg 2)) (defknown (nsubstitute-if nsubstitute-if-not) (t callable sequence &key (:from-end t) (:start index) (:end sequence-end) (:count sequence-count) (:key callable)) sequence - (flushable call) + (flushable call dynamic-extent-closure-safe) :derive-type (sequence-result-nth-arg 3)) (defknown remove-duplicates (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) (:end sequence-end) (:key callable)) consed-sequence - (flushable call) + (flushable call dynamic-extent-closure-safe) :derive-type (sequence-result-nth-arg 1)) (defknown delete-duplicates (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) (:end sequence-end) (:key callable)) sequence - (flushable call) + (flushable call dynamic-extent-closure-safe) :derive-type (sequence-result-nth-arg 1)) (defknown find (t sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) (:end sequence-end) (:key callable)) t - (foldable flushable call)) + (foldable flushable call dynamic-extent-closure-safe)) (defknown (find-if find-if-not) (callable sequence &key (:from-end t) (:start index) (:end sequence-end) (:key callable)) t - (foldable flushable call)) + (foldable flushable call dynamic-extent-closure-safe)) (defknown position (t sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) (:end sequence-end) (:key callable)) (or index null) - (foldable flushable call)) + (foldable flushable call dynamic-extent-closure-safe)) (defknown (position-if position-if-not) (callable sequence &key (:from-end t) (:start index) (:end sequence-end) (:key callable)) (or index null) - (foldable flushable call)) + (foldable flushable call dynamic-extent-closure-safe)) (defknown count (t sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) (:end sequence-end) (:key callable)) index - (foldable flushable call)) + (foldable flushable call dynamic-extent-closure-safe)) (defknown (count-if count-if-not) (callable sequence &key (:from-end t) (:start index) (:end sequence-end) (:key callable)) index - (foldable flushable call)) + (foldable flushable call dynamic-extent-closure-safe)) (defknown (mismatch search) (sequence sequence &key (:from-end t) (:test callable) (:test-not callable) (:start1 index) (:end1 sequence-end) (:start2 index) (:end2 sequence-end) (:key callable)) (or index null) - (foldable flushable call)) + (foldable flushable call dynamic-extent-closure-safe)) ;;; Not flushable, since vector sort guaranteed in-place... (defknown (stable-sort sort) (sequence callable &key (:key callable)) sequence - (call) + (call dynamic-extent-closure-safe) :derive-type (sequence-result-nth-arg 1)) (defknown merge (type-specifier sequence sequence callable &key (:key callable)) sequence - (flushable call) + (flushable call dynamic-extent-closure-safe) :derive-type (result-type-specifier-nth-arg 1)) (defknown read-sequence (sequence stream &key (:start index) @@ -593,7 +594,7 @@ (defknown cons (t t) cons (movable flushable unsafe)) (defknown tree-equal (t t &key (:test callable) (:test-not callable)) boolean - (foldable flushable call)) + (foldable flushable call dynamic-extent-closure-safe)) (defknown endp (list) boolean (foldable flushable movable)) (defknown list-length (list) (or index null) (foldable flushable)) (defknown (nth nthcdr) (unsigned-byte list) t (foldable flushable)) @@ -620,51 +621,52 @@ (defknown (nsubst subst) (t t t &key (:key callable) (:test callable) (:test-not callable)) - list (flushable unsafe call)) + list (flushable unsafe call dynamic-extent-closure-safe)) (defknown (subst-if subst-if-not nsubst-if nsubst-if-not) (t t t &key (:key callable)) - list (flushable unsafe call)) + list (flushable unsafe call dynamic-extent-closure-safe)) (defknown (sublis nsublis) (list t &key (:key callable) (:test callable) (:test-not callable)) - list (flushable unsafe call)) + list (flushable unsafe call dynamic-extent-closure-safe)) (defknown member (t list &key (:key callable) (:test callable) (:test-not callable)) - list (foldable flushable call)) + list (foldable flushable call dynamic-extent-closure-safe)) (defknown (member-if member-if-not) (callable list &key (:key callable)) - list (foldable flushable call)) + list (foldable flushable call dynamic-extent-closure-safe)) (defknown tailp (t list) boolean (foldable flushable)) (defknown adjoin (t list &key (:key callable) (:test callable) (:test-not callable)) - list (foldable flushable unsafe call)) + list (foldable flushable unsafe call dynamic-extent-closure-safe)) (defknown (union intersection set-difference set-exclusive-or) (list list &key (:key callable) (:test callable) (:test-not callable)) list - (foldable flushable call)) + (foldable flushable call dynamic-extent-closure-safe)) (defknown (nunion nintersection nset-difference nset-exclusive-or) (list list &key (:key callable) (:test callable) (:test-not callable)) list - (foldable flushable call)) + (foldable flushable call dynamic-extent-closure-safe)) -(defknown subsetp - (list list &key (:key callable) (:test callable) (:test-not callable)) +(defknown subsetp (list list &key (:key callable) (:test callable) + (:test-not callable)) boolean - (foldable flushable call)) + (foldable flushable call dynamic-extent-closure-safe)) (defknown acons (t t t) list (movable flushable unsafe)) (defknown pairlis (t t &optional t) list (flushable unsafe)) (defknown (rassoc assoc) (t list &key (:key callable) (:test callable) (:test-not callable)) - list (foldable flushable call)) + list (foldable flushable call dynamic-extent-closure-safe)) (defknown (assoc-if-not assoc-if rassoc-if rassoc-if-not) - (callable list &key (:key callable)) list (foldable flushable call)) + (callable list &key (:key callable)) list + (foldable flushable call dynamic-extent-closure-safe)) (defknown (memq assq) (t list) list (foldable flushable unsafe)) (defknown delq (t list) list (flushable unsafe)) @@ -684,7 +686,8 @@ (foldable flushable unsafe)) (defknown %puthash (t hash-table t) t (unsafe)) (defknown remhash (t hash-table) boolean ()) -(defknown maphash (callable hash-table) null (foldable flushable call)) +(defknown maphash (callable hash-table) null + (foldable flushable call dynamic-extent-closure-safe)) (defknown clrhash (hash-table) hash-table ()) (defknown hash-table-count (hash-table) index (foldable flushable)) (defknown hash-table-rehash-size (hash-table) (or (integer 1) (float (1.0))) @@ -1143,6 +1146,9 @@ (defknown %instance-typep (t (or type-specifier ctype)) boolean (movable flushable explicit-check)) +(defknown %dynamic-extent (t t) void) +(defknown %dynamic-extent-start () t) +(defknown %dynamic-extent-end (t t) void) (defknown %cleanup-point () void) (defknown %special-bind (t t) void) (defknown %special-unbind (t) void) diff --git a/compiler/generic/vm-ir2tran.lisp b/compiler/generic/vm-ir2tran.lisp index 15ec1a42a79eda7c9ec1816629cfc8f51a8a9664..65876d97c60c1c038dd160dc668d195bf77fa45b 100644 --- a/compiler/generic/vm-ir2tran.lisp +++ b/compiler/generic/vm-ir2tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-ir2tran.lisp,v 1.9 1997/01/18 14:31:15 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-ir2tran.lisp,v 1.10 2003/08/25 20:50:59 gerd Rel $") ;;; ;;; ********************************************************************** ;;; @@ -80,7 +80,8 @@ #-gengc (defun do-fixed-alloc (node block name words type lowtag result) - (vop fixed-alloc node block name words type lowtag result)) + (vop fixed-alloc node block name words type lowtag + (ir2-stack-allocate node) result)) (defoptimizer ir2-convert-fixed-allocation ((&rest args) node block name words type lowtag inits) diff --git a/compiler/globaldb.lisp b/compiler/globaldb.lisp index d76a428cdbe4f48e2f05dbf38114e708a77fc7c7..5664dc06a5ea3044f5c3dfe4565a6a79eba419d8 100644 --- a/compiler/globaldb.lisp +++ b/compiler/globaldb.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.43 2003/08/06 19:00:13 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.44 2003/08/25 20:51:00 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1168,29 +1168,3 @@ (declaim (freeze-type info-env)) -(defvar *trust-dynamic-extent-declarations* - (lambda (safety space speed debug) - (declare (ignore space speed debug) (fixnum safety)) - (< safety 3)) - "If null, don't trust dynamic-extent declarations. - - If T, always trust dynamic-extent declarations. - - Otherwise, the value of this variable must be a function of four - arguments SAFETY, SPACE, SPEED, and DEBUG. If the function returns - true when called, dynamic-extent declarations are trusted, - otherwise, they are not trusted. - - Default is a function that returns true if SAFETY < 3.") - -(defun trust-dynamic-extent-declaration-p (&optional node) - (declare (type (or null node) node)) - (let ((trust *trust-dynamic-extent-declarations*)) - (if (functionp trust) - (let ((cookie (lexenv-cookie (if node - (node-lexenv node) - *lexical-environment*)))) - (funcall trust (cookie-safety cookie) (cookie-space cookie) - (cookie-speed cookie) (cookie-debug cookie))) - trust))) - diff --git a/compiler/hppa/alloc.lisp b/compiler/hppa/alloc.lisp index c9807e3b390ff26f7df7962da71295eb90a31052..2ea4ffcf541845d72640fc69ffe460da91b0335f 100644 --- a/compiler/hppa/alloc.lisp +++ b/compiler/hppa/alloc.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/alloc.lisp,v 1.5 2003/08/06 21:10:35 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/alloc.lisp,v 1.6 2003/08/25 20:50:59 gerd Rel $") ;;; ;;; ********************************************************************** ;;; @@ -16,6 +16,22 @@ (in-package "HPPA") + +;;;; Dynamic-Extent (not implemented). + +(define-vop (%dynamic-extent-start) + (:args (saved-stack-pointer :scs (any-reg))) + (:results) + (:policy :safe) + (:generator 0)) + +(define-vop (%dynamic-extent-end) + (:args (saved-stack-pointer :scs (any-reg))) + (:results) + (:policy :safe) + (:generator 0)) + + ;;;; LIST and LIST* @@ -25,7 +41,7 @@ (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) res) - (:info num) + (:info num dynamic-extent) (:results (result :scs (descriptor-reg))) (:variant-vars star) (:policy :safe) @@ -156,7 +172,7 @@ (define-vop (fixed-alloc) (:args) - (:info name words type lowtag) + (:info name words type lowtag dynamic-extent) (:ignore name) (:results (result :scs (descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) temp) diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index a00aa6eef5840848a1dfee7e3d205e661ddd5961..45b6f08bf3e790b82d5b167bc26687907966130f 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.161 2003/08/07 09:48:43 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.162 2003/08/25 20:51:00 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -121,25 +121,147 @@ DEFUNs is used when compiling calls to that function. If false, only information from FTYPE proclamations will be used.") - -;; returns non-nil if X and Y name the same function. This is more -;; involved than a simple call to EQ due to support for generalized -;; function names. In the IR1 representation, the local function INNER -;; in the following -;; -;; (defun outer (a) -;; (flet ((inner (x) (random x))) -;; (declaim (inline inner)) -;; (inner a))) -;; -;; will have a lambda-name of (FLET INNER OUTER). Some parts of the -;; compiler may search for it under the name INNER. +;;; +;;; Returns non-nil if X and Y name the same function. This is more +;;; involved than a simple call to EQ due to support for generalized +;;; function names. In the IR1 representation, the local function INNER +;;; in the following +;;; +;;; (defun outer (a) +;;; (flet ((inner (x) (random x))) +;;; (declaim (inline inner)) +;;; (inner a))) +;;; +;;; will have a lambda-name of (FLET INNER OUTER). Some parts of the +;;; compiler may search for it under the name INNER. +;;; (defun function-name-eqv-p (x y) (or (equal x y) (and (consp y) (member (car y) '(flet labels)) (equal x (cadr y))))) + +;;;; Dynamic-Extent + +(defvar *trust-dynamic-extent-declarations* #+x86 t #-x86 nil + "If null, don't trust dynamic-extent declarations. + + If T, always trust dynamic-extent declarations. + + Otherwise, the value of this variable must be a function of four + arguments SAFETY, SPACE, SPEED, and DEBUG. If the function returns + true when called, dynamic-extent declarations are trusted, + otherwise they are not trusted.") + +(defvar *dynamic-extent-trace* nil) + +(defun trust-dynamic-extent-declaration-p + (&optional (lexenv *lexical-environment*)) + (declare (type lexenv lexenv)) + (let ((trust *trust-dynamic-extent-declarations*)) + (if (functionp trust) + (let ((cookie (lexenv-cookie lexenv))) + (funcall trust (cookie-safety cookie) (cookie-space cookie) + (cookie-speed cookie) (cookie-debug cookie))) + trust))) + + +(defun process-dynamic-extent-declaration (spec vars fvars lexenv) + (declare (list spec vars fvars) (type lexenv lexenv)) + (if (trust-dynamic-extent-declaration-p lexenv) + (collect ((dynamic-extent)) + (dolist (name (cdr spec)) + (cond ((symbolp name) + (let* ((bound-var (find-in-bindings vars name)) + (var (or bound-var + (lexenv-find name variables) + (find-free-variable name)))) + (if (leaf-p var) + (if bound-var + (setf (leaf-dynamic-extent var) t) + (dynamic-extent var))))) + ((and (consp name) + (eq (car name) 'function) + (null (cddr name)) + (valid-function-name-p (cadr name))) + (let* ((fn-name (cadr name)) + (fn (find fn-name fvars + :key #'leaf-name + :test #'function-name-eqv-p))) + (if fn + (setf (leaf-dynamic-extent fn) t) + (dynamic-extent (find-lexically-apparent-function + fn-name + "in a dynamic-extent declaration"))))) + (t + (compiler-warning + "~@<Invalid name ~s in a dynamic-extent declaration.~@:>" + name)))) + (if (dynamic-extent) + (make-lexenv :default lexenv :dynamic-extent (dynamic-extent)) + lexenv)) + lexenv)) + +;;; +;;; Value is true if some dynamic-extent allocation can be done in the +;;; initialization of variables Vars with values Vals. +;;; +(defun dynamic-extent-allocation-p (vars vals) + (loop for var in vars and val in vals + thereis (and (leaf-dynamic-extent var) + (consp val) + (memq (car val) '(list list* cons))))) + +;;; +;;; Return a list of indices for arguments in Args which might end up +;;; as dynamic-extent closures. We can't tell for sure here because +;;; environment analysis runs after IR1 conversion, so we don't know +;;; yet what are closures and what not. +;;; +(defun dynamic-extent-closure-args (args) + (declare (list args)) + (flet ((find-local-function (name) + (let ((var (lexenv-find-function name))) + (when (leaf-p var) + var)))) + (let ((dynamic-extent (lexenv-dynamic-extent *lexical-environment*))) + (collect ((indices)) + (do* ((i 0 (1+ i)) + (tail args (cdr tail)) + (arg (car tail) (car tail))) + ((null tail)) + (when (and (consp arg) + (eq (car arg) 'function) + (valid-function-name-p (cadr arg)) + (let ((fn (find-local-function (cadr arg)))) + (and fn + (or (leaf-dynamic-extent fn) + (and (functional-p fn) + (or (memq fn dynamic-extent) + (memq (functional-entry-function fn) + dynamic-extent))))))) + (indices i))) + (indices))))) + +;;; +;;; Evaluate Body wrapped in a dynamic-extent cleanup. +;;; FIXME: Maybe don't %dynamic-extent-start if kind = :rest. +;;; +(defun gen-%dynamic-extent (kind) + `(%dynamic-extent ,kind (%dynamic-extent-start))) + +(defmacro with-dynamic-extent ((start cont nnext-cont kind) &body body) + `(progn + (continuation-starts-block ,cont) + (let ((.cleanup. (make-cleanup :kind :dynamic-extent)) + (.next-cont. (make-continuation)) + (,nnext-cont (make-continuation))) + (ir1-convert ,start .next-cont. (gen-%dynamic-extent ,kind)) + (setf (cleanup-mess-up .cleanup.) (continuation-use .next-cont.)) + (let ((*lexical-environment* (make-lexenv :cleanup .cleanup.))) + (ir1-convert .next-cont. ,nnext-cont '(%cleanup-point)) + (locally ,@body))))) ;;;; Namespace management utilities: @@ -771,10 +893,18 @@ (defun ir1-convert-combination (start cont form fun) (declare (type continuation start cont) (list form) (type leaf fun) (values combination)) - (let ((fun-cont (make-continuation))) - (reference-leaf start fun-cont fun) - (ir1-convert-combination-args fun-cont cont (cdr form)))) - + (let ((indices (dynamic-extent-closure-args (cdr form)))) + (if indices + (with-dynamic-extent (start cont nnext-cont :closure) + (when *dynamic-extent-trace* + (format t "~&dynamic-extent args ~:s in ~s~%" indices form)) + (let ((fun-cont (make-continuation))) + (reference-leaf nnext-cont fun-cont fun) + (ir1-convert-combination-args fun-cont cont (cdr form) indices))) + (let ((fun-cont (make-continuation))) + (reference-leaf start fun-cont fun) + (ir1-convert-combination-args fun-cont cont (cdr form)))))) + ;;; IR1-Convert-Combination-Args -- Internal ;;; @@ -783,19 +913,30 @@ ;;; for the call. Args is the list of arguments for the call, which defaults ;;; to the cdr of source. We return the Combination node. ;;; -(defun ir1-convert-combination-args (fun-cont cont args) +(defun ir1-convert-combination-args (fun-cont cont args + &optional dynamic-extent-args) (declare (type continuation fun-cont cont) (list args)) (let ((node (make-combination fun-cont))) (setf (continuation-dest fun-cont) node) (assert-continuation-type fun-cont (values-specifier-type '(values (or function symbol) &rest t))) (collect ((arg-conts)) - (let ((this-start fun-cont)) + (let ((this-start fun-cont) + (lambda-vars (let* ((use (continuation-use fun-cont)) + (leaf (when use (ref-leaf use)))) + (when (lambda-p leaf) + (lambda-vars leaf)))) + (i 0)) (dolist (arg args) (let ((this-cont (make-continuation node))) + (when (or (and lambda-vars + (leaf-dynamic-extent (pop lambda-vars))) + (member i dynamic-extent-args)) + (setf (continuation-dynamic-extent this-cont) t)) (ir1-convert this-start this-cont arg) (setq this-start this-cont) - (arg-conts this-cont))) + (arg-conts this-cont) + (incf i))) (prev-link node this-start) (use-continuation node cont) (setf (combination-args node) (arg-conts)))) @@ -897,7 +1038,8 @@ ;;;; PROCESS-DECLARATIONS: -(declaim (start-block process-declarations make-new-inlinep)) +(declaim (start-block process-declarations make-new-inlinep + find-in-bindings)) ;;; Find-In-Bindings -- Internal ;;; @@ -1141,40 +1283,6 @@ (setf (lambda-var-ignorep var) t))))) (undefined-value)) -(defun process-dynamic-extent-declaration (spec vars fvars lexenv) - (declare (list spec vars fvars) (type lexenv lexenv)) - (collect ((dynamic-extent)) - (dolist (name (cdr spec)) - (cond ((symbolp name) - (let* ((bound-var (find-in-bindings vars name)) - (var (or bound-var - (lexenv-find name variables) - (find-free-variable name)))) - (if (leaf-p var) - (if bound-var - (setf (leaf-dynamic-extent var) t) - (dynamic-extent var))))) - ((and (consp name) - (eq (car name) 'function) - (null (cddr name)) - (valid-function-name-p (cadr name))) - (let* ((fn-name (cadr name)) - (fn (find fn-name fvars - :key #'leaf-name - :test #'function-name-eqv-p))) - (if fn - (setf (leaf-dynamic-extent fn) t) - (dynamic-extent (find-lexically-apparent-function - fn-name - "in a dynamic-extent declaration"))))) - (t - (compiler-warning - "~@<Invalid name ~s in a dynamic-extent declaration.~@:>" - name)))) - (if (dynamic-extent) - (make-lexenv :default lexenv :dynamic-extent (dynamic-extent)) - lexenv))) - (defvar *suppress-values-declaration* nil "If true, processing of the VALUES declaration is inhibited.") @@ -1296,7 +1404,8 @@ ;;;; Lambda hackery: (declaim (start-block ir1-convert-lambda ir1-convert-lambda-body - ir1-convert-aux-bindings varify-lambda-arg)) + ir1-convert-aux-bindings varify-lambda-arg + ir1-convert-dynamic-extent-bindings)) ;;; Varify-Lambda-Arg -- Internal ;;; @@ -1500,7 +1609,17 @@ *lexical-environment*))) (ir1-convert-combination-args fun-cont cont (list (first aux-vals)))))) - (undefined-value)) + (values)) + +(defun ir1-convert-dynamic-extent-bindings (start cont body aux-vars + aux-vals interface) + (declare (type continuation start cont) (list body aux-vars aux-vals)) + (if (dynamic-extent-allocation-p aux-vars aux-vals) + (with-dynamic-extent (start cont nnext-cont :bind) + (ir1-convert-aux-bindings nnext-cont cont body aux-vars + aux-vals interface)) + (ir1-convert-aux-bindings start cont body aux-vars aux-vals interface)) + (values)) ;;; IR1-Convert-Special-Bindings -- Internal @@ -1516,12 +1635,13 @@ ;;; cleanup, causing cleanup code to be emitted when the scope is exited. ;;; (defun ir1-convert-special-bindings (start cont body aux-vars aux-vals - interface svars) + interface svars) (declare (type continuation start cont) (list body aux-vars aux-vals svars)) (cond ((null svars) - (ir1-convert-aux-bindings start cont body aux-vars aux-vals interface)) + (ir1-convert-dynamic-extent-bindings start cont body aux-vars aux-vals + interface)) (t (continuation-starts-block cont) (let ((cleanup (make-cleanup :kind :special-bind)) @@ -1535,7 +1655,7 @@ (ir1-convert next-cont nnext-cont '(%cleanup-point)) (ir1-convert-special-bindings nnext-cont cont body aux-vars aux-vals interface (rest svars)))))) - (undefined-value)) + (values)) ;;; IR1-Convert-Lambda-Body -- Internal @@ -1565,7 +1685,8 @@ (type (or continuation null) result)) (let* ((bind (make-bind)) (lambda (make-lambda :vars vars :bind bind)) - (result (or result (make-continuation)))) + (result (or result (make-continuation))) + (dynamic-extent-rest nil)) (setf (lambda-home lambda) lambda) (collect ((svars) (new-venv nil cons)) @@ -1577,21 +1698,31 @@ (svars var) (new-venv (cons (leaf-name specvar) specvar))) (t - (new-venv (cons (leaf-name var) var)))))) - - (let ((*lexical-environment* - (make-lexenv :variables (new-venv) :lambda lambda - :cleanup nil))) + (new-venv (cons (leaf-name var) var))))) + (let ((info (lambda-var-arg-info var))) + (when (and info + (eq :rest (arg-info-kind info)) + (leaf-dynamic-extent var)) + (setq dynamic-extent-rest var)))) + + (let* ((*lexical-environment* + (make-lexenv :variables (new-venv) :lambda lambda + :cleanup nil))) (setf (bind-lambda bind) lambda) (setf (node-lexenv bind) *lexical-environment*) - + (let ((cont1 (make-continuation)) (cont2 (make-continuation))) (continuation-starts-block cont1) (prev-link bind cont1) (use-continuation bind cont2) - (ir1-convert-special-bindings cont2 result body aux-vars aux-vals - interface (svars))) + (if dynamic-extent-rest + (with-dynamic-extent (cont2 result nnext-cont :rest) + (ir1-convert-special-bindings nnext-cont result body + aux-vars aux-vals + interface (svars))) + (ir1-convert-special-bindings cont2 result body aux-vars aux-vals + interface (svars)))) (let ((block (continuation-block result))) (when block @@ -2530,24 +2661,24 @@ "FUNCTION Name Return the lexically apparent definition of the function Name. Name may also be a lambda." - (if (consp thing) - (case (car thing) - ((lambda) - (reference-leaf start cont (ir1-convert-lambda thing nil 'function))) - ((instance-lambda) - (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)) - nil 'function))) - (setf (getf (functional-plist res) :fin-function) t) - (reference-leaf start cont res))) - (t - (if (valid-function-name-p thing) - (let ((var (find-lexically-apparent-function - thing "as the argument to FUNCTION"))) - (reference-leaf start cont var)) - (compiler-error "Illegal function name: ~S" thing)))) - (let ((var (find-lexically-apparent-function - thing "as the argument to FUNCTION"))) - (reference-leaf start cont var)))) + (flet ((reference-it () + (let ((fn (find-lexically-apparent-function + thing "as the argument to FUNCTION"))) + (reference-leaf start cont fn)))) + (if (consp thing) + (case (car thing) + ((lambda) + (reference-leaf start cont (ir1-convert-lambda thing nil 'function))) + ((instance-lambda) + (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)) + nil 'function))) + (setf (getf (functional-plist res) :fin-function) t) + (reference-leaf start cont res))) + (t + (if (valid-function-name-p thing) + (reference-it) + (compiler-error "Illegal function name: ~S" thing)))) + (reference-it)))) ;;;; Funcall: @@ -2883,7 +3014,6 @@ (values (vars) (vals) (names)))) - (def-ir1-translator let ((bindings &parse-body (body decls)) start cont) "LET ({(Var [Value]) | Var}*) Declaration* Form* @@ -2892,11 +3022,17 @@ evaluated." (multiple-value-bind (vars values) (extract-let-variables bindings 'let) - (let* ((*lexical-environment* (process-declarations decls vars nil cont)) - (fun-cont (make-continuation)) - (fun (ir1-convert-lambda-body body vars))) - (reference-leaf start fun-cont fun) - (ir1-convert-combination-args fun-cont cont values)))) + (let ((*lexical-environment* (process-declarations decls vars nil cont))) + (if (dynamic-extent-allocation-p vars values) + (with-dynamic-extent (start cont nnext-cont :bind) + (let ((fun-cont (make-continuation)) + (fun (ir1-convert-lambda-body body vars))) + (reference-leaf nnext-cont fun-cont fun) + (ir1-convert-combination-args fun-cont cont values))) + (let ((fun-cont (make-continuation)) + (fun (ir1-convert-lambda-body body vars))) + (reference-leaf start fun-cont fun) + (ir1-convert-combination-args fun-cont cont values)))))) (def-ir1-translator locally ((&parse-body (body decls)) start cont) @@ -2905,8 +3041,6 @@ where the given Declaration's have effect." (let* ((*lexical-environment* (process-declarations decls nil nil cont))) (ir1-convert-progn-body start cont body))) - - (def-ir1-translator let* ((bindings &parse-body (body decls)) start cont) @@ -2914,9 +3048,9 @@ Similar to LET, but the variables are bound sequentially, allowing each Value form to reference any of the previous Vars." (multiple-value-bind (vars values) - (extract-let-variables bindings 'let*) + (extract-let-variables bindings 'let*) (let ((*lexical-environment* (process-declarations decls vars nil cont))) - (ir1-convert-aux-bindings start cont body vars values nil)))) + (ir1-convert-dynamic-extent-bindings start cont body vars values nil)))) ;;;; Flet and Labels: @@ -2968,7 +3102,7 @@ do not enclose the definitions; any use of Name in the Forms will refer to the lexically apparent function definition in the enclosing environment." (multiple-value-bind (names defs) - (extract-flet-variables definitions 'flet) + (extract-flet-variables definitions 'flet) (let* ((fvars (mapcar #'(lambda (n d) (ir1-convert-lambda d n 'flet)) names defs)) diff --git a/compiler/ir2tran.lisp b/compiler/ir2tran.lisp index d5e0a88b6bc5b53c2d0598b651c066a301949b4e..75ff9c2130ecf51d9cf6b3fcf62409eba61ccdec 100644 --- a/compiler/ir2tran.lisp +++ b/compiler/ir2tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.73 2003/08/06 21:10:35 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.74 2003/08/25 20:51:00 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -32,6 +32,10 @@ compilation policy") (defvar *enable-stack-clearing* t "If non-NIL and the compilation policy allows, stack clearing is enabled.") +(defun ir2-stack-allocate (node) + (declare (type node node)) + (continuation-dynamic-extent (node-cont node))) + ;;;; Moves and type checks: @@ -218,15 +222,13 @@ compilation policy") (assert (eq (functional-kind leaf) :top-level-xep)) nil)))) (cond (closure - (let* ((this-env (node-environment node)) - (entry-fn (functional-entry-function leaf)) - (dynamic-extent - (or (leaf-dynamic-extent entry-fn) - (memq entry-fn - (lexenv-dynamic-extent (node-lexenv node)))))) + (let ((this-env (node-environment node)) + (dynamic-extent (ir2-stack-allocate node))) + (when *dynamic-extent-trace* + (format t "~&===> make-closure ~s (~d)~%" + dynamic-extent (length closure))) (vop make-closure node block entry (length closure) - dynamic-extent - res) + dynamic-extent res) (loop for what in closure and n from 0 do (unless (and (lambda-var-p what) (null (leaf-refs what))) @@ -236,7 +238,7 @@ compilation policy") n))))) (t (emit-move node block entry res)))) - (undefined-value)) + (values)) ;;; IR2-Convert-Set -- Internal @@ -711,15 +713,15 @@ compilation policy") ;;; (defun ir2-convert-let (node block fun) (declare (type combination node) (type ir2-block block) (type clambda fun)) - (mapc #'(lambda (var arg) - (when arg - (let ((src (continuation-tn node block arg)) - (dest (leaf-info var))) - (if (lambda-var-indirect var) - (do-make-value-cell node block src dest) - (emit-move node block src dest))))) - (lambda-vars fun) (basic-combination-args node)) - (undefined-value)) + (loop for var in (lambda-vars fun) + and arg in (basic-combination-args node) + when arg do + (let ((src (continuation-tn node block arg)) + (dest (leaf-info var))) + (if (lambda-var-indirect var) + (do-make-value-cell node block src dest) + (emit-move node block src dest)))) + (values)) ;;; EMIT-PSETQ-MOVES -- Internal @@ -1404,6 +1406,29 @@ compilation policy") nil) ((reference-tn-list locs t))))))))) + +;;;; Dynamic-Extent + +(defoptimizer (%dynamic-extent ir2-convert) ((kind sp) node block) + node block sp kind) + +(defoptimizer (%dynamic-extent-start ir2-convert) (() node block) + (let ((tn (environment-live-tn (make-stack-pointer-tn) + (node-environment node))) + (2cont (continuation-info (node-cont node)))) + (setf (ir2-continuation-locs 2cont) (list tn)) + (when *dynamic-extent-trace* + (format t "~&===> %dynamic-extent-start ~s ~s~%" tn + (node-cont node))) + (vop %dynamic-extent-start node block tn))) + +(defoptimizer (%dynamic-extent-end ir2-convert) ((kind sp) node block) + (let* ((sp (continuation-value sp)) + (tn (first (ir2-continuation-locs (continuation-info sp))))) + (when *dynamic-extent-trace* + (format t "~&===> %dynamic-extent-end ~s ~s ~s~%" + (continuation-value kind) sp tn)) + (vop %dynamic-extent-end node block tn))) ;;;; Special binding: @@ -1657,9 +1682,12 @@ compilation policy") (cont (node-cont node)) (res (continuation-result-tns cont - (list (primitive-type (specifier-type 'list)))))) + (list (primitive-type (specifier-type 'list))))) + (dynamic-extent (ir2-stack-allocate node))) + (when (and dynamic-extent *dynamic-extent-trace*) + (format t "~&===> list/list* ~d~%" (length args))) (vop* ,name node block (refs) ((first res) nil) - (length args)) + (length args) dynamic-extent) (move-continuation-result node block res cont))))) (frob list) (frob list*)) @@ -1776,8 +1804,7 @@ compilation policy") tn))))))) ((not (eq (ir2-block-next 2block) (block-info target))) (vop branch last 2block (block-label target))))))) - - (undefined-value)) + (values)) ;;; IR2-Convert-Block -- Internal @@ -1833,8 +1860,9 @@ compilation policy") (when (exit-entry node) (ir2-convert-exit node 2block))) (entry - (ir2-convert-entry node 2block))))) + (ir2-convert-entry node 2block)))) - (finish-ir2-block block) + (finish-ir2-block block) + (values))) - (undefined-value)) +;;; End of file. diff --git a/compiler/knownfun.lisp b/compiler/knownfun.lisp index 6cbb5af2baf1450f015c2f46622f164bdfcd27f9..d3c4b61ec451abfafb34213005fc3b26dcc425dd 100644 --- a/compiler/knownfun.lisp +++ b/compiler/knownfun.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/knownfun.lisp,v 1.25 2003/08/02 11:52:15 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/knownfun.lisp,v 1.26 2003/08/25 20:50:59 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -77,7 +77,10 @@ ;; ;; Function does explicit argument type checking, so the declared type should ;; not be asserted when a definition is compiled. - explicit-check) + explicit-check + ;; + ;; Safe to stack-allocate function args that are closures. + dynamic-extent-closure-safe) (defstruct (function-info (:print-function %print-function-info) diff --git a/compiler/mips/alloc.lisp b/compiler/mips/alloc.lisp index 34ebc9d138a9f1d3deb16b31eb82be70799053cd..55b510f4ca7ccca2306dab2203eb107032a3fa1f 100644 --- a/compiler/mips/alloc.lisp +++ b/compiler/mips/alloc.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.30 2003/08/06 21:10:35 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.31 2003/08/25 20:50:59 gerd Rel $") ;;; ;;; ********************************************************************** ;;; @@ -16,6 +16,21 @@ (in-package "MIPS") + +;;;; Dynamic-Extent (not implemented). + +(define-vop (%dynamic-extent-start) + (:args (saved-stack-pointer :scs (any-reg))) + (:results) + (:policy :safe) + (:generator 0)) + +(define-vop (%dynamic-extent-end) + (:args (saved-stack-pointer :scs (any-reg))) + (:results) + (:policy :safe) + (:generator 0)) + ;;;; LIST and LIST* @@ -27,7 +42,7 @@ (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) res) (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) - (:info num) + (:info num dynamic-extent) (:results (result :scs (descriptor-reg))) (:variant-vars star) (:policy :safe) @@ -213,7 +228,7 @@ (define-vop (fixed-alloc) (:args) - (:info name words type lowtag) + (:info name words type lowtag dynamic-extent) (:ignore name) (:results (result :scs (descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) temp) diff --git a/compiler/node.lisp b/compiler/node.lisp index 76283204878ddc9e90e2f873a8a4c626a1b91681..c87b3517761c4ba1382ecec5e6df6085630baf12 100644 --- a/compiler/node.lisp +++ b/compiler/node.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/node.lisp,v 1.42 2003/08/06 19:01:17 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/node.lisp,v 1.43 2003/08/25 20:50:59 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -233,7 +233,11 @@ (%type-check t :type (member t nil :deleted :no-check :error)) ;; ;; Something or other that the back end annotates this continuation with. - (info nil)) + (info nil) + ;; + ;; True if this value can be allocated with dynamic extent. + (dynamic-extent nil :type boolean)) + (defun %print-continuation (s stream d) (declare (ignore d)) @@ -531,7 +535,8 @@ ;; ;; The kind of thing that has to be cleaned up. (kind (required-argument) - :type (member :special-bind :catch :unwind-protect :block :tagbody)) + :type (member :special-bind :catch :unwind-protect :block :tagbody + :dynamic-extent)) ;; ;; The node that messes things up. This is the last node in the ;; non-messed-up environment. Null only temporarily. This could be deleted diff --git a/compiler/ppc/alloc.lisp b/compiler/ppc/alloc.lisp index 855ba5525b8158a657f0975a5e0db712df01cde9..26ea125a103ae96a7fca1cd25033dc2504308f92 100644 --- a/compiler/ppc/alloc.lisp +++ b/compiler/ppc/alloc.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/alloc.lisp,v 1.3 2003/08/06 21:10:35 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/alloc.lisp,v 1.4 2003/08/25 20:50:58 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,6 +18,21 @@ (in-package "PPC") + +;;;; Dynamic-Extent (not implemented). + +(define-vop (%dynamic-extent-start) + (:args (saved-stack-pointer :scs (any-reg))) + (:results) + (:policy :safe) + (:generator 0)) + +(define-vop (%dynamic-extent-end) + (:args (saved-stack-pointer :scs (any-reg))) + (:results) + (:policy :safe) + (:generator 0)) + ;;;; LIST and LIST* @@ -28,7 +43,7 @@ (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) res) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) - (:info num) + (:info num dynamic-extent) (:results (result :scs (descriptor-reg))) (:variant-vars star) (:policy :safe) @@ -163,7 +178,7 @@ (define-vop (fixed-alloc) (:args) - (:info name words type lowtag) + (:info name words type lowtag dynamic-extent) (:ignore name) (:results (result :scs (descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) temp) diff --git a/compiler/seqtran.lisp b/compiler/seqtran.lisp index ead63aeb683b52cbdd7b31eb51ab4f7b520fefbc..c741461a8b7f308312b99da5cd386092556e205f 100644 --- a/compiler/seqtran.lisp +++ b/compiler/seqtran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/seqtran.lisp,v 1.27 2003/04/27 13:58:59 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/seqtran.lisp,v 1.28 2003/08/25 20:50:59 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -37,6 +37,7 @@ (let ((temp (gensym)) (map-result (gensym))) `(let ((,map-result (list nil))) + (declare (dynamic-extent ,map-result)) (do-anonymous ((,temp ,map-result) . ,(do-clauses)) (,endtest (cdr ,map-result)) (setq ,temp (last (nconc ,temp ,call))))))) @@ -44,6 +45,7 @@ (let ((temp (gensym)) (map-result (gensym))) `(let ((,map-result (list nil))) + (declare (dynamic-extent ,map-result)) (do-anonymous ((,temp ,map-result) . ,(do-clauses)) (,endtest (cdr ,map-result)) (rplacd ,temp (setq ,temp (list ,call))))))) diff --git a/compiler/x86/alloc.lisp b/compiler/x86/alloc.lisp index d698cb9b25642d573203958408dada082de6f7cf..3d83f980e26332cfc2a82e0e0adb311a97336e2c 100644 --- a/compiler/x86/alloc.lisp +++ b/compiler/x86/alloc.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/alloc.lisp,v 1.10 2003/08/06 19:01:17 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/alloc.lisp,v 1.11 2003/08/25 20:50:58 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -21,6 +21,25 @@ (in-package :x86) + +;;;; Dynamic-Extent + +;;; +;;; Take an arg where to move the stack pointer instead of returning +;;; it via :results, because the former generates a single move. +;;; +(define-vop (%dynamic-extent-start) + (:args (saved-stack-pointer :scs (any-reg control-stack))) + (:results) + (:policy :safe) + (:generator 0 (inst mov saved-stack-pointer esp-tn))) + +(define-vop (%dynamic-extent-end) + (:args (saved-stack-pointer :scs (any-reg control-stack))) + (:results) + (:policy :safe) + (:generator 0 (inst mov esp-tn saved-stack-pointer))) + ;;;; LIST and LIST* @@ -28,7 +47,7 @@ (:args (things :more t)) (:temporary (:sc unsigned-reg) ptr temp) (:temporary (:sc unsigned-reg :to (:result 0) :target result) res) - (:info num) + (:info num dynamic-extent) (:results (result :scs (descriptor-reg))) (:variant-vars star) (:policy :safe) @@ -49,9 +68,12 @@ (move temp ,tn) temp)))) (storew reg ,list ,slot vm:list-pointer-type)))) - (let ((cons-cells (if star (1- num) num))) + (let ((cons-cells (if star (1- num) num)) + (*enable-pseudo-atomic* (unless dynamic-extent + *enable-pseudo-atomic*))) (pseudo-atomic - (allocation res (* (pad-data-block cons-size) cons-cells) node) + (allocation res (* (pad-data-block cons-size) cons-cells) node + dynamic-extent) (inst lea res (make-ea :byte :base res :disp list-pointer-type)) (move ptr res) @@ -195,16 +217,18 @@ (define-vop (fixed-alloc) (:args) - (:info name words type lowtag) + (:info name words type lowtag dynamic-extent) (:ignore name) (:results (result :scs (descriptor-reg))) (:node-var node) (:generator 50 - (pseudo-atomic - (allocation result (pad-data-block words) node) - (inst lea result (make-ea :byte :base result :disp lowtag)) - (when type - (storew (logior (ash (1- words) type-bits) type) result 0 lowtag))))) + (let ((*enable-pseudo-atomic* (unless dynamic-extent + *enable-pseudo-atomic*))) + (pseudo-atomic + (allocation result (pad-data-block words) node dynamic-extent) + (inst lea result (make-ea :byte :base result :disp lowtag)) + (when type + (storew (logior (ash (1- words) type-bits) type) result 0 lowtag)))))) (define-vop (var-alloc) (:args (extra :scs (any-reg))) diff --git a/compiler/x86/macros.lisp b/compiler/x86/macros.lisp index 46bafc1fddb708184b8e27234b19c89c98a8e829..a66cf61e85db86a8068648bb73c165ec054e08bd 100644 --- a/compiler/x86/macros.lisp +++ b/compiler/x86/macros.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/macros.lisp,v 1.20 2003/08/06 19:00:12 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/macros.lisp,v 1.21 2003/08/25 20:50:58 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -245,12 +245,10 @@ ;;; Allocate SIZE bytes from the stack, storing a pointer to the ;;; allocated memory in ALLOC-TN. ;;; -(defun stack-allocation (alloc-tn size) - (load-size alloc-tn alloc-tn size) - (inst neg alloc-tn) - (inst add alloc-tn esp-tn) - (inst and alloc-tn #xfffffff8) ;align on double-word boundary - (inst mov esp-tn alloc-tn) +(defun dynamic-extent-allocation (alloc-tn nbytes) + (inst sub esp-tn nbytes) + (inst and esp-tn #xfffffff8) + (inst mov alloc-tn esp-tn) (values)) (defun allocation (alloc-tn size &optional inline dynamic-extent) @@ -259,10 +257,8 @@ If Inline is a VOP node-var then it is used to make an appropriate speed vs size decision. If Dynamic-Extent is true, and otherwise appropriate, allocate from the stack." - (cond ((and inline - dynamic-extent - (trust-dynamic-extent-declaration-p inline)) - (stack-allocation alloc-tn size)) + (cond (dynamic-extent + (dynamic-extent-allocation alloc-tn size)) ((and *maybe-use-inline-allocation* (or (null inline) (policy inline (>= speed space))) diff --git a/docs/cmu-user/extensions.tex b/docs/cmu-user/extensions.tex index 415471be93f4f303f96fffacbc29ca66190629bf..bf8648c57f9b886fb837c66d8d670d28b275a216 100644 --- a/docs/cmu-user/extensions.tex +++ b/docs/cmu-user/extensions.tex @@ -2203,16 +2203,16 @@ actual arguments and constructs an effective method function from applicable methods, using the generic function's method combination. Effective methods can be precomputed at method load time instead of -when the generic function is called by setting -\code{pcl:*max-emf-precomputation-methods*} to a nonzero number. +when the generic function is called depending on the value of +\code{pcl:*max-emf-precomputation-methods*}. \begin{defvar}{pcl:}{*max-emf-precomputation-methods*} - If nonzero, precompute effective methods when methods are loaded, - and the method's generic function has less than the specified - number of methods. + If nonzero, the default value is 100, precompute effective methods + when methods are loaded, and the method's generic function has less + than the specified number of methods. - If zero, the default, compute effective methods only when the - generic function is called. + If zero, compute effective methods only when the generic function is + called. \end{defvar} @@ -2462,3 +2462,106 @@ innermost fwrapper. object from a function name. \end{defmac} +\section{Dynamic-Extent Declarations} +\cindex{dynamic-extent} + +On x86 and sparc, \cmucl{} can exploit \code{dynamic-extent} +declarations by allocating objects on the stack instead of the heap. + +You can tell \cmucl{} to trust or not trust \code{dynamic-extent} +declarations by setting the variable +\code{*trust-dynamic-extent-declarations*}. + +\begin{defvar}{ext:}{*trust-dynamic-extent-declarations*} + If the value of \code{*trust-dynamic-extent-declarations*} is + \code{NIL}, \code{dynamic-extent} declarations are effectively + ignored. + + If the value of this variable is a function, the function is called + with four arguments to determine if a \code{dynamic-extent} + declaration should be trusted. The arguments are the safety, + space, speed, and debug settings at the point where the + \code{dynamic-extent} declaration is used. If the function + returns true, the declaration is trusted, otherwise it is not + trusted. + + In all other cases, \code{dynamic-extent} declarations are + trusted. +\end{defvar} + +Please note that stack-allocation is inherently unsafe. If you make a +mistake, and a stack-allocated object or part of it escapes, \cmucl{} +is likely to crash, or format your hard disk. + +\subsection{\code{&rest} argument lists} +\cpsubindex{dynamic-extent}{rest lists} + +Rest argument lists can be allocated on the stack by declaring the +rest argument variable \code{dynamic-extent}. Examples: + +\begin{lisp} +(defun foo (x &rest rest) + (declare (dynamic-extent rest)) + ...) + +(defun bar () + (lambda (&rest rest) + (declare (dynamic-extent rest)) + ...)) +\end{lisp} + +\subsection{Closures} +\cpsubindex{dynamic-extent}{closures} + +Closures for local functions can be allocated on the stack if the +local function is declared \code{dynamic-extent}, and the closure +appears as an argument in the call of a named function. In the +example: + +\begin{lisp} +(defun foo (x) + (flet ((bar () x)) + (declare (dynamic-extent #'bar)) + (baz #'bar))) +\end{lisp} + +the closure passed to function \code{baz} is allocated on the stack. +Likewise in the example: + +\begin{lisp} +(defun foo (x) + (flet ((bar () x)) + (baz #'bar) + (locally (declare (dynamic-extent #'bar)) + (baz #'bar)))) +\end{lisp} + +\cpsubindex{dynamic-extent}{known CL functions} + +Stack-allocation of closures can also automatically take place when +calling certain known CL functions taking function arguments, for +example \code{some} or \code{find-if}. + +\subsection{\code{list}, \code{list*}, and \code{cons}} +\cpsubindex{dynamic-extent}{list, list*, cons} + +New conses allocated by \code{list}, \code{list*}, or \code{cons} +which are used to initialize variables can be allocated from the stack +if the variables are declared \code{dynamic-extent}. In the case of +\code{cons}, only the outermost cons cell is allocated from the stack; +this is an arbitrary restriction. + +\begin{lisp} +(let ((x (list 1 2)) + (y (list* 1 2 x)) + (z (cons 1 (cons 2 nil)))) + (declare (dynamic-extent x y z)) + ... + (setq x (list 2 3)) + ...) +\end{lisp} + +Please note that the \code{setq} of \code{x} in the example program +assigns to \code{x} a list that is allocated from the heap. This is +another arbitrary restriction that exists because other Lisps behave +that way. diff --git a/general-info/release-19a.txt b/general-info/release-19a.txt index 72c07ce3b2d7164ed48b2c4b79c944420f960173..c05b9152bb6b407b54d7f7a63a60f139dbe86713 100644 --- a/general-info/release-19a.txt +++ b/general-info/release-19a.txt @@ -180,13 +180,13 @@ New in this release: default to preserve current behavior. Set the version to :NEWEST to create versions. - LDB backtrace on x86. - - DYNAMIC-EXTENT support on x86 and sparc for &REST arg lists and - closures. Stack-allocation can be controlled with the new - variable EXT:*TRUST-DYNAMIC-EXTENT-DECLARATIONS*, which see. - Default is to stack-allocate if speed >= safety. Be warned - that all bets are off if a stack-allocated object or parts of - it escape; CMUCL might crash or format your hard disk. - - Generation GC (gencgc) available for Sparc/Solaris on an + - DYNAMIC-EXTENT support on x86 and sparc. Stack-allocation can + be controlled by the setting of + EXT:*TRUST-DYNAMIC-EXTENT-DECLARATIONS*. See also the CMU User + Manual. Be warned that all bets are off if a stack-allocated + object or parts of it escape; CMUCL might crash or format your + hard disk. + - Generational GC (gencgc) available for Sparc/Solaris on an experimental basis. Despite the name and feature, it is not conservative. @@ -230,11 +230,13 @@ New in this release: The default method of this generic function signals a continuable error of type PCL:NO-PRIMARY-METHOD-ERROR. - Effective methods are no longer precomputed at method load - time, for conformance with CLtS. - PCL:*MAX-EMF-PRECOMPUTATION-METHODS* can be set to a number > - 0 to allow effective method precomputation when the generic - function in question has less than the specified number of - methods. + time, if the generic function has more than + PCL:*MAX-EMF-PRECOMPUTATION-METHODS* methods (default 100). + - The loading of methods with invalid qualifiers no longer + signals an error, for standard's conformance. Instead, a + warning is printed at method load time. An error is + signaled if the generic function is called with arguments such + that the method is used. * Improvements to Hemlock, the Emacs-like editor: