Commit 6bc8fe20 authored by Raymond Toy's avatar Raymond Toy
Browse files

Merge branch 'tcall-convention' of https://github.com/ellerh/cmucl into tcall-convention

parents 8a35f225 eac8d34c

Makefile

+6 −2
Original line number Diff line number Diff line
@@ -350,14 +350,18 @@ cross-build: 
	bin/create-target.sh xtarget

	cp src/tools/cross-scripts/cross-x86-x86.lisp xtarget/cross.lisp

ifeq ($(XBOOTFILE),)

	bin/cross-build-world.sh -crl \

	bin/cross-build-world.sh -cr \

		xtarget xcross xtarget/cross.lisp $(BOOTCMUCL)

else

	bin/cross-build-world.sh -crl \

	bin/cross-build-world.sh -cr \

		-B $(XBOOTFILE) xtarget xcross xtarget/cross.lisp $(BOOTCMUCL)

endif

	bin/rebuild-lisp.sh xtarget

	bin/load-world.sh -p xtarget "newlisp"

	bin/create-target.sh xstage2

	bin/build-world.sh xstage2 xtarget/lisp/lisp

	bin/rebuild-lisp.sh xstage2

	bin/load-world.sh xstage2 "newlisp2"



sanity:

	@if [ `echo $(TOPDIR) | egrep -c '^/'` -ne 1 ]; then		\

src/bootfiles/20c/tccxboot.lisp

+2 −2
Original line number Diff line number Diff line
@@ -3,7 +3,7 @@ 


(c::define-info-type function c::calling-convention symbol nil)

(c::define-info-type function lisp::linkage lisp::linkage nil)

(delete-file (compile-file "target:compiler/knownfun"))

(delete-file (compile-file "target:code/load"))

(delete-file (compile-file "target:compiler/knownfun" :load t))

(delete-file (compile-file "target:code/load" :load t))

src/code/exports.lisp

+1 −2
Original line number Diff line number Diff line
@@ -1760,8 +1760,7 @@ 
	   "TN-REF-NEXT" "TN-REF-NEXT-REF" "TN-REF-P" "TN-REF-TARGET"

	   "TN-REF-TN" "TN-REF-VOP" "TN-REF-WRITE-P" "TN-SC" "TN-VALUE"

	   "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR"

	   "TYPED-CALL-LOCAL" "TYPED-CALL-NAMED"

	   "TYPED-ENTRY-POINT-ALLOCATE-FRAME"

	   "TYPED-CALL-NAMED" "TYPED-ENTRY-POINT-ALLOCATE-FRAME"

	   "UNBIND" "UNBIND-TO-HERE"

	   "UNSAFE" "UNWIND" "UWP-ENTRY"

	   "VALUE-CELL-REF" "VALUE-CELL-SET" "VALUES-LIST"

src/code/fdefinition.lisp

+24 −15
Original line number Diff line number Diff line
@@ -288,11 +288,16 @@ 
		     (equal (cadr fname) name))

	    (return ep)))))



(defun find-typed-entry-point-for-function (xep name)

  (declare (type function xep))

  (when (= (kernel:get-type xep) vm:function-header-type)

    (let ((code (function-code-header xep)))

      (find-typed-entry-point-in-code code name))))



(defun find-typed-entry-point-for-fdefn (fdefn)

  (let ((xep (fdefn-function fdefn)))

    (when xep

      (let ((code (function-code-header xep)))

	(find-typed-entry-point-in-code code (fdefn-name fdefn))))))

    (when (functionp xep)

      (find-typed-entry-point-for-function xep (fdefn-name fdefn)))))



;; find-typed-entry-point is called at load-time and returns the

;; fdefn that should be called.
@@ -325,10 +330,10 @@ 
		    (cond (foundp info)

			  (t (setf (ext:info function linkage name)

				   (make-linkage)))))))

    (cond ((and nil (dolist (cs (listify (linkage-callsites linkage)))

    (cond ((dolist (cs (listify (linkage-callsites linkage)))

	     (let* ((ep-type (callsite-type cs)))

	       (when (function-types-compatible-p cs-type ep-type)

		 (return (callsite-fdefn cs)))))))

		 (return (callsite-fdefn cs))))))

	  ((let ((fdefn (fdefinition-object name nil)))

	     (when fdefn

	       (let ((fun (find-typed-entry-point-for-fdefn fdefn)))
@@ -388,17 +393,19 @@ 
  (declare (type function-type ftype))

  (let* ((atypes (function-type-required ftype))

	 (tmps (loop for nil in atypes collect (gensym)))

	 (*derive-function-types* nil)

	 (fun (compile 

	       nil

	       `(lambda ,tmps

		  (declare

		   (c::calling-convention :typed-no-xep)

		   (c::calling-convention :typed)

		   ,@(loop for tmp in tmps

			   for type in atypes

			   collect `(type ,(kernel:type-specifier type) ,tmp)))

		  (the ,(kernel:type-specifier

			 (kernel:function-type-returns ftype))

		    (funcall (function ,name) . ,tmps))))))

		    (funcall ',name . ,tmps)))))

	 (fun (find-typed-entry-point-for-function fun nil)))

    (validate-adapter-type fun ftype)

    fun))
@@ -462,27 +469,29 @@ 
(defun check-function-redefinition (name new-fun)

  (multiple-value-bind (linkage foundp) (ext:info function linkage name)

    (when foundp

      (let* ((new-code (function-code-header new-fun))

	     (new-tep (find-typed-entry-point-in-code new-code name))

	     (new-type (extract-function-type new-tep)))

      (let* ((new-tep (find-typed-entry-point-for-function new-fun name))

	     (new-type (if new-tep

			   (extract-function-type new-tep)

			   (specifier-type '(function * *)))))

	(dolist (cs (listify (linkage-callsites linkage)))

	  (let ((cs-type (callsite-type cs))

		(fdefn (callsite-fdefn cs)))

	    (cond ((function-types-compatible-p cs-type new-type)

	    (cond ((and new-tep

			(function-types-compatible-p cs-type new-type))

		   (patch-fdefn fdefn new-tep))

		  ((dolist (fun (listify (linkage-adapters linkage)))

		     (let ((ep-type (kernel:extract-function-type fun)))

		       (when (function-types-compatible-p cs-type ep-type)

			 (patch-fdefn fdefn fun)

			 (patch-fdefn fdefn fun `(:adapter ,name))

			 (return t)))))

		  (t

		   (let ((fun (generate-adapter-function cs-type name)))

		     (push-unlistified fun (linkage-adapters linkage))

		     (patch-fdefn fdefn fun))))))))))

		     (patch-fdefn fdefn fun `(:adapter ,name)))))))))))



(defun patch-fdefn (fdefn new-fun)

(defun patch-fdefn (fdefn new-fun &optional name)

  (setf (kernel:fdefn-function fdefn) new-fun)

  (let ((name (kernel:%function-name new-fun)))

  (let ((name (or name (kernel:%function-name new-fun))))

    (kernel:%set-fdefn-name fdefn name))

  fdefn)

src/compiler/debug.lisp

+4 −2
Original line number Diff line number Diff line
@@ -235,7 +235,8 @@ 
       (check-function-reached ef functional)

       (unless (or (member functional (optional-dispatch-entry-points ef))

		   (eq functional (optional-dispatch-more-entry ef))

		   (eq functional (optional-dispatch-main-entry ef)))

		   (eq functional (optional-dispatch-main-entry ef))

		   (eq functional (optional-dispatch-typed-entry ef)))

	 (barf ":Optional ~S not an e-p for its OPTIONAL-DISPATCH ~S." 

	       functional ef))))

    (:top-level
@@ -927,7 +928,8 @@ 
	  (unless (or (eq (global-conflicts-kind conf) :write)

		      (eq tn pc)

		      (eq tn fp)

		      (and (external-entry-point-p fun)

		      (and (or (external-entry-point-p fun)

			       (typed-entry-point-p fun))

			   (tn-offset tn))

		      (member (tn-kind tn) '(:environment :debug-environment))

		      (member tn vars :key #'leaf-info)