Commit 5ac014db authored by gerd's avatar gerd
Browse files

Dynamic-extent closures for x86. Use boot15.lisp for 

	bootstrapping.

	(defun prn (fn)
	  (print (funcall fn)))

	(defun foo (x)
	  (flet ((bar () x))
	    (declare (dynamic-extent #'bar))
	    (prn #'bar)))

	=> The closure for BAR is allocated from the stack

	* src/compiler/node.lisp (lexenv): Add slot dynamic-extent.

	* src/compiler/ir1util.lisp (make-lexenv): Add keyword
	arg for dynamic-extent.

	* src/code/defstruct.lisp (%redefine-defstruct)
	[#+bootstrap-dynamic-extent]: Definition that corresponds
	to to the clobber-it restart.

	* src/compiler/ir1tran.lisp (process-dynamic-extent-declaration):
	Rewritten.

	* src/compiler/x86/alloc.lisp (make-closure): Add constant
	arg dynamic-extent, and use it for allocation.

	* src/compiler/ir2tran.lisp (ir2-convert-closure) [#+x86]:
	Pass dynamic-extent to the make-closure vop.
parent 289982f2

code/defstruct.lisp

+8 −1
Original line number Diff line number Diff line
@@ -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/defstruct.lisp,v 1.90 2003/06/20 10:34:37 gerd Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.91 2003/08/06 19:01:18 gerd Exp $")

;;;

;;; **********************************************************************

;;;
@@ -1583,6 +1583,13 @@ 
;;; Class to have the specified New-Layout.  We signal an error with some

;;; proceed options and return the layout that should be used.

;;;

#+bootstrap-dynamic-extent

(defun %redefine-defstruct (class old-layout new-layout)

  (declare (type class class) (type layout old-layout new-layout))

  (register-layout new-layout :invalidate nil

		   :destruct-layout old-layout))



#-bootstrap-dynamic-extent

(defun %redefine-defstruct (class old-layout new-layout)

  (declare (type class class) (type layout old-layout new-layout))

  (let ((name (class-proper-name class)))

compiler/ir1tran.lisp

+38 −26
Original line number Diff line number Diff line
@@ -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.159 2003/08/05 15:50:29 toy Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.160 2003/08/06 19:01:17 gerd Exp $")

;;;

;;; **********************************************************************

;;;
@@ -1141,27 +1141,39 @@ 
	(setf (lambda-var-ignorep var) t)))))

  (undefined-value))



(defun process-dynamic-extent-declaration (spec vars fvars)

  (declare (list spec vars fvars))

(defun process-dynamic-extent-declaration (spec vars fvars lexenv)

  (declare (list spec vars fvars) (type lexenv lexenv))

  (collect ((dynamic-extent))

    (dolist (name (cdr spec))

    (let ((var (find-in-bindings-or-fbindings name vars fvars)))

      (cond ((null var)

	     (if (or (lexenv-find name variables) (lexenv-find-function name))

		 (compiler-note

		  "Ignoring free dynamic-extent declaration for ~S." name)

		 (compiler-warning

		  "Dynamic-extent declaration for unknown variable ~S." name)))

      (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

	     (when (or (not (lambda-var-p var))

		       (let ((arg-info (lambda-var-arg-info var)))

			 (or (null arg-info)

			     (not (eq :rest (arg-info-kind arg-info))))))

	       (compiler-note

		"~@<Ignoring the dynamic-extent declaration of ~s.  ~

                  Dynamic-extent is currently only implemented for ~

                  rest args.~@:>" name))

	     (setf (leaf-dynamic-extent var) t)))))

  (values))

	     (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.")
@@ -1221,9 +1233,9 @@ 
						    `(values ,@types)))

			 cont res 'values))))

    (dynamic-extent

     (unless *suppress-dynamic-extent-declaration*

       (process-dynamic-extent-declaration spec vars fvars))

     res)

     (if *suppress-dynamic-extent-declaration*

	 res

	 (process-dynamic-extent-declaration spec vars fvars res)))

    (t

     (let ((what (first spec)))

       (cond ((member what type-specifier-symbols)

compiler/ir1util.lisp

+4 −3
Original line number Diff line number Diff line
@@ -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/ir1util.lisp,v 1.92 2003/06/02 16:29:23 emarsden Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.93 2003/08/06 19:01:17 gerd Exp $")

;;;

;;; **********************************************************************

;;;
@@ -410,7 +410,7 @@ 
;;; 

(defun make-lexenv (&key (default *lexical-environment*)

			 functions variables blocks tags type-restrictions

			 options

			 options dynamic-extent

			 (lambda (lexenv-lambda default))

			 (cleanup (lexenv-cleanup default))

			 (cookie (lexenv-cookie default))
@@ -427,7 +427,8 @@ 
     (frob tags lexenv-tags)

     (frob type-restrictions lexenv-type-restrictions)

     lambda cleanup cookie interface-cookie

     (frob options lexenv-options))))

     (frob options lexenv-options)

     (frob dynamic-extent lexenv-dynamic-extent))))





;;; MAKE-INTERFACE-COOKIE  --  Interface

compiler/ir2tran.lisp

+11 −3
Original line number Diff line number Diff line
@@ -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.71 2002/12/07 18:19:34 toy Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.72 2003/08/06 19:01:17 gerd Exp $")

;;;

;;; **********************************************************************

;;;
@@ -218,8 +218,16 @@ compilation policy") 
		    (assert (eq (functional-kind leaf) :top-level-xep))

		    nil))))

    (cond (closure

	   (let ((this-env (node-environment node)))

	     (vop make-closure node block entry (length closure) res)

	   (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))))))

	     #-x86 (declare (ignorable dynamic-extent))

	     (vop make-closure node block entry (length closure)

		  #+x86 dynamic-extent

		  res)

	     (loop for what in closure and n from 0 do

	       (unless (and (lambda-var-p what)

			    (null (leaf-refs what)))

compiler/node.lisp

+8 −3
Original line number Diff line number Diff line
@@ -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.41 2003/08/05 14:04:52 gerd Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/node.lisp,v 1.42 2003/08/06 19:01:17 gerd Exp $")

;;;

;;; **********************************************************************

;;;
@@ -32,7 +32,8 @@ 
	    (:constructor internal-make-lexenv

			  (functions variables blocks tags type-restrictions

				     lambda cleanup cookie

				     interface-cookie options)))

				     interface-cookie options

				     dynamic-extent)))

  ;;

  ;; Alist (name . what), where What is either a Functional (a local function),

  ;; a DEFINED-FUNCTION, representing an INLINE/NOTINLINE declaration, or
@@ -82,7 +83,11 @@ 
  ;;

  ;; AList of random options that are associated with the lexical

  ;; environment.  They can be established with COMPILER-OPTION-BIND.

  (options nil :type list))

  (options nil :type list)

  ;;

  ;; List of things declared dynamic-extent for which there is no

  ;; binding in the form containing the declaration.

  (dynamic-extent nil :type list))





;;; A Cont-Ref represents a reference to a continuation.