December 2012 - cmucl-cvs - mailman3.common-lisp.net

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-12-22-g7838879
by Raymond Toy 28 Dec '12

28 Dec '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 78388799a95d5e551f776037eafeb2ef81a58acc (commit) from 58446794c98fcac9dda80e3fad8f58f361521c6d (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 78388799a95d5e551f776037eafeb2ef81a58acc Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Dec 27 11:22:59 2012 -0800 Update from commit logs. diff --git a/src/general-info/release-20e.txt b/src/general-info/release-20e.txt index aff9643..585d8a0 100644 --- a/src/general-info/release-20e.txt +++ b/src/general-info/release-20e.txt @@ -24,13 +24,27 @@ New in this release: * Changes * ASDF2 updated to version 2.26. + * DEFINE-COMPILER-MACRO now has source-locationinformation for the + macro definition. + * :ALIEN-CALLBACK added to *FEATURES* for platforms that support + alien callbacks. + * The sparc port can be built using gcc once again. + * The old Cheney stop-and-copy GC supported on sparc once again. + However, there are no plans on supplying sparc binaries with + this GC. * ANSI compliance fixes: * Bugfixes: + * REPLACE and friends on strings was limited to strings less than + the maximum possible size. This has been fixed so strings of any + supported length can be handled. (See ticket #66 and #68.) * Trac Tickets: * Ticket #52 reopened. + * Ticket #66 fixed. + * Ticket #67 fixed. + * Ticket #68 fixed. * Other changes: * -8 option for build-all.sh is deprecated since we don't ----------------------------------------------------------------------- Summary of changes: src/general-info/release-20e.txt | 14 ++++++++++++++ 1 files changed, 14 insertions(+), 0 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-12-21-g5844679
by Raymond Toy 26 Dec '12

26 Dec '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 58446794c98fcac9dda80e3fad8f58f361521c6d (commit) via 440a04a8d9587f19574a95187c5b38496706decd (commit) via 2850805391ed11896e0d18fa09683f8eba1964cf (commit) from 02f4566a61fa5857150f69398e9a0a9af2652e7f (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 58446794c98fcac9dda80e3fad8f58f361521c6d Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Dec 26 14:10:33 2012 -0800 Fix bitrot: set GC_SRC to gc.c if FEATURE_GENCGC is not defined. diff --git a/src/lisp/Config.sparc_common b/src/lisp/Config.sparc_common index 3b07c14..16f99fb 100644 --- a/src/lisp/Config.sparc_common +++ b/src/lisp/Config.sparc_common @@ -25,6 +25,8 @@ endif ifdef FEATURE_GENCGC GENCGC = -DGENCGC GC_SRC = gencgc.c +else +GC_SRC = gc.c endif # Enable support for SSE2. If FEATURE_X87 is set, we want SSE2 commit 440a04a8d9587f19574a95187c5b38496706decd Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Dec 26 14:10:04 2012 -0800 Fix bitrot: support scavenging unicode strings.. diff --git a/src/lisp/gc.c b/src/lisp/gc.c index dc75e15..6af7a15 100644 --- a/src/lisp/gc.c +++ b/src/lisp/gc.c @@ -1202,7 +1202,7 @@ size_unboxed(lispobj * where) #define NWORDS(x,y) (CEILING((x),(y)) / (y)) static int -scav_string(lispobj * where, lispobj object) +size_string(lispobj * where) { struct vector *vector; int length, nwords; @@ -1212,43 +1212,30 @@ scav_string(lispobj * where, lispobj object) vector = (struct vector *) where; length = fixnum_value(vector->length) + 1; +#ifndef UNICODE nwords = CEILING(NWORDS(length, 4) + 2, 2); +#else + /* + * Strings are just like arrays with 16-bit elements, and contain + * one more element than the slot length indicates. + */ + nwords = CEILING(NWORDS(length, 2) + 2, 2); +#endif return nwords; } -static lispobj -trans_string(lispobj object) +static int +scav_string(lispobj * where, lispobj object) { - struct vector *vector; - int length, nwords; - - gc_assert(Pointerp(object)); - - /* NOTE: Strings contain one more byte of data than the length */ - /* slot indicates. */ - - vector = (struct vector *) PTR(object); - length = fixnum_value(vector->length) + 1; - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return copy_object(object, nwords); + return size_string(where); } -static int -size_string(lispobj * where) +static lispobj +trans_string(lispobj object) { - struct vector *vector; - int length, nwords; - - /* NOTE: Strings contain one more byte of data than the length */ - /* slot indicates. */ - - vector = (struct vector *) where; - length = fixnum_value(vector->length) + 1; - nwords = CEILING(NWORDS(length, 4) + 2, 2); - - return nwords; + gc_assert(Pointerp(object)); + return copy_object(object, size_string((lispobj *) PTR(object))); } static int commit 2850805391ed11896e0d18fa09683f8eba1964cf Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Dec 26 11:42:00 2012 -0800 Forgot to load c-callback and alien-callback in the appropriate places. diff --git a/src/compiler/loadbackend.lisp b/src/compiler/loadbackend.lisp index de8608b..be9cf00 100644 --- a/src/compiler/loadbackend.lisp +++ b/src/compiler/loadbackend.lisp @@ -56,6 +56,8 @@ (if (target-featurep :sse2) (load "vm:sse2-c-call") (load "vm:x87-c-call"))) +(when (target-featurep :alien-callback) + (load "vm:c-callback")) (load "vm:print") (load "vm:alloc") (load "vm:call") diff --git a/src/tools/worldload.lisp b/src/tools/worldload.lisp index a6f063a..b167662 100644 --- a/src/tools/worldload.lisp +++ b/src/tools/worldload.lisp @@ -168,6 +168,9 @@ (maybe-byte-load "target:code/intl") +#+alien-callback +(maybe-byte-load "target:code/alien-callback") + ;;; PCL. ;;; ----------------------------------------------------------------------- Summary of changes: src/compiler/loadbackend.lisp | 2 + src/lisp/Config.sparc_common | 2 + src/lisp/gc.c | 45 ++++++++++++++-------------------------- src/tools/worldload.lisp | 3 ++ 4 files changed, 23 insertions(+), 29 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-12-18-g02f4566
by Raymond Toy 26 Dec '12

26 Dec '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 02f4566a61fa5857150f69398e9a0a9af2652e7f (commit) via c26b49e619c393dfddc156258fe24efd1bcafc1e (commit) from 8b625663a224043fc416f4c0c5f92b6a7b9d7232 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 02f4566a61fa5857150f69398e9a0a9af2652e7f Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Dec 26 10:23:17 2012 -0800 Add :alien-callback to *faatures* for platforms that support it. bootfiles/20d/boot-2012-12-1.lisp:: Add :alien-callback to *features* bin/build.sh:: Change bootstrap directory to 20d. code/lispinit.lisp:: * Register :alien-callback feature if enabled. * Heap overflow checking depends on gencgc, so register that only if both are enabled. tools/comcom.lisp:: Compile c-callback only if :alien-callback is a feature. tools/worldcom.lisp: Compile alien-callback onlf if :alien-callback is a feature. diff --git a/bin/build.sh b/bin/build.sh index 0ac13c8..f451ac1 100755 --- a/bin/build.sh +++ b/bin/build.sh @@ -39,7 +39,7 @@ ENABLE2="yes" ENABLE3="yes" ENABLE4="yes" -version=20c +version=20d SRCDIR=src BINDIR=bin TOOLDIR=$BINDIR diff --git a/src/bootfiles/20d/boot-2012-12-1.lisp b/src/bootfiles/20d/boot-2012-12-1.lisp new file mode 100644 index 0000000..58dc316 --- /dev/null +++ b/src/bootfiles/20d/boot-2012-12-1.lisp @@ -0,0 +1,6 @@ +;; Add :alien-callback to *features* to build callback support for +;; platforms that support alien callbacks. + +#+(or x86 sparc ppc) +(pushnew :alien-callback *features*) + diff --git a/src/code/lispinit.lisp b/src/code/lispinit.lisp index f5548b2..81a6e20 100644 --- a/src/code/lispinit.lisp +++ b/src/code/lispinit.lisp @@ -39,12 +39,16 @@ #+stack-checking (sys:register-lisp-runtime-feature :stack-checking) -#+heap-overflow-check +;; Currently, heap-overflow-check depends on gencgc. +#+(and heap-overflow-check gencgc) (sys:register-lisp-runtime-feature :heap-overflow-check) #+double-double (sys:register-lisp-feature :double-double) +#+alien-callback +(sys:register-lisp-feature :alien-callback) + ;;; Make the error system enable interrupts. (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum diff --git a/src/tools/comcom.lisp b/src/tools/comcom.lisp index 0953dc0..2205e11 100644 --- a/src/tools/comcom.lisp +++ b/src/tools/comcom.lisp @@ -197,7 +197,8 @@ (vmdir "target:compiler/sse2-c-call") (vmdir "target:compiler/x87-c-call")) :byte-compile *byte-compile*)) -(comf (vmdir "target:compiler/c-callback")) +(when (c:target-featurep :alien-callback) + (comf (vmdir "target:compiler/c-callback"))) (comf (vmdir "target:compiler/cell")) (comf (vmdir "target:compiler/values") :byte-compile *byte-compile*) (comf (vmdir "target:compiler/alloc")) diff --git a/src/tools/worldcom.lisp b/src/tools/worldcom.lisp index 9a74818..f8ac65a 100644 --- a/src/tools/worldcom.lisp +++ b/src/tools/worldcom.lisp @@ -138,7 +138,8 @@ (setf (fdefinition 'lisp::%deftype) *original-%deftype*) (comf "target:code/alieneval") -(comf "target:code/alien-callback") +(when (c:target-featurep :alien-callback) + (comf "target:code/alien-callback")) (comf "target:code/c-call") (comf "target:code/sap") commit c26b49e619c393dfddc156258fe24efd1bcafc1e Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Dec 24 08:46:02 2012 -0800 Clean up: move byte-bash-copy near bit-bash-copy, and remove debugging prints. diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index 8f94a97..a9bb688 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -466,33 +466,13 @@ (32bit-logical-andc2 orig mask))))))))))))))) (undefined-value)) - -;;;; The actual bashers. - -(defun bit-bash-fill (value dst dst-offset length) - (declare (type unit value) (type offset dst-offset length)) - (locally - (declare (optimize (speed 3) (safety 0))) - (do-constant-bit-bash dst dst-offset length value - #'%raw-bits #'%set-raw-bits))) - -(defun system-area-fill (value dst dst-offset length) - (declare (type unit value) (type offset dst-offset length)) - (locally - (declare (optimize (speed 3) (safety 0))) - (multiple-value-bind (dst dst-offset) - (fix-sap-and-offset dst dst-offset) - (do-constant-bit-bash dst dst-offset length value - #'word-sap-ref #'%set-word-sap-ref)))) +;;;; DO-UNARY-BYTE-BASH -(defun bit-bash-copy (src src-offset dst dst-offset length) - (declare (type offset src-offset dst-offset length)) - (locally - (declare (optimize (speed 3) (safety 0)) - (inline do-unary-bit-bash)) - (do-unary-bit-bash src src-offset dst dst-offset length - #'%raw-bits #'%set-raw-bits #'%raw-bits))) +;;;; Like DO-UNARY-BIT-BASH, but we only handle objects that are at +;;;; least byte in size. The offsets and lengths are byte offsets and +;;;; lengths, instead of bits. +(declaim (inline do-unary-byte-bash)) (defun do-unary-byte-bash (src src-offset dst dst-offset length dst-ref-fn dst-set-fn src-ref-fn) (declare (type offset src-offset dst-offset length) @@ -507,17 +487,14 @@ (type byte-offset src-byte-offset)) (cond ((<= (+ dst-byte-offset length) unit-bytes) - #+nil(format t "case 1, one word~%") ;; We are only writing one word, so it doesn't matter what order ;; we do it in. But we might be reading from multiple words, so take ;; care. (cond ((zerop length) - #+nil(format t "case 1a: 0 length~%") ;; Actually, we aren't even writing one word. This is real easy. ) ((= length unit-bytes) - #+nil(format t "case 1b~%") ;; dst-byte-offset must be equal to zero, or we would be writing ;; multiple words. If src-byte-offset is also zero, then we ;; just transfer the single word. Otherwise we have to extract bits @@ -533,7 +510,6 @@ (funcall src-ref-fn src (1+ src-word-offset)) (* vm:byte-bits (- src-byte-offset))))))) (t - #+nil(format t "case 1c~%") ;; We are only writing some portion of the dst word, so we need to ;; preserve the extra bits. Also, we still don't know if we need ;; one or two source words. @@ -572,7 +548,6 @@ (32bit-logical-and value mask) (32bit-logical-andc2 orig mask))))))) ((= src-byte-offset dst-byte-offset) - #+nil(format t "case 2, aligned~%") ;; The source and dst are aligned, so we don't need to shift ;; anything. But we have to pick the direction of the loop ;; in case the source and dst are really the same thing. @@ -583,10 +558,8 @@ (declare (type word-offset interior)) (cond ((<= dst-offset src-offset) - #+nil(format t " case 2a: L-R~%") ;; We need to loop from left to right (unless (zerop dst-byte-offset) - #+nil(format t " case 2a1: dst-byte-offset = ~D~%" dst-byte-offset) ;; We are only writing part of the first word, so mask off the ;; bits we want to preserve. (let ((mask (end-mask (- dst-byte-offset))) @@ -605,7 +578,6 @@ (incf src-word-offset) (incf dst-word-offset)) (unless (zerop final-bytes) - #+nil(format t " case 2a2: final-bytes = ~D~%" final-bytes) ;; We are only writing part of the last word. (let ((mask (start-mask (* vm:byte-bits final-bytes))) (orig (funcall dst-ref-fn dst dst-word-offset)) @@ -616,12 +588,10 @@ (32bit-logical-and value mask) (32bit-logical-andc2 orig mask)))))) (t - #+nil(format t " case 2b: R-L~%") ;; We need to loop from right to left. (incf dst-word-offset words) (incf src-word-offset words) (unless (zerop final-bytes) - #+nil(format t " case 2b1: R-L final-bytes = ~D~%" final-bytes) (let ((mask (start-mask (* vm:byte-bits final-bytes))) (orig (funcall dst-ref-fn dst dst-word-offset)) (value (funcall src-ref-fn src src-word-offset))) @@ -636,7 +606,6 @@ (funcall dst-set-fn dst dst-word-offset (funcall src-ref-fn src src-word-offset))) (unless (zerop dst-byte-offset) - #+nil(format t " case 2b2: R-L dst-byte-offset = ~D~%" dst-byte-offset) (decf src-word-offset) (decf dst-word-offset) (let ((mask (end-mask (* vm:byte-bits (- dst-byte-offset)))) @@ -648,7 +617,6 @@ (32bit-logical-and value mask) (32bit-logical-andc2 orig mask)))))))))) (t - #+nil(format t "case 3, unaligned~%") ;; They aren't aligned. (multiple-value-bind (words final-bytes) (floor (+ dst-byte-offset length) unit-bytes) @@ -659,7 +627,6 @@ (type word-offset interior)) (cond ((<= dst-offset src-offset) - #+nil(format t "case 3a: L-R~%") ;; We need to loop from left to right (let ((prev 0) (next (funcall src-ref-fn src src-word-offset))) @@ -708,7 +675,6 @@ (32bit-logical-and value mask) (32bit-logical-andc2 orig mask)))))))) (t - #+nil(format t "case 3b: L-R~%") ;; We need to loop from right to left. (incf dst-word-offset words) (incf src-word-offset @@ -759,6 +725,33 @@ (32bit-logical-andc2 orig mask))))))))))))))) (undefined-value)) + +;;;; The actual bashers. + +(defun bit-bash-fill (value dst dst-offset length) + (declare (type unit value) (type offset dst-offset length)) + (locally + (declare (optimize (speed 3) (safety 0))) + (do-constant-bit-bash dst dst-offset length value + #'%raw-bits #'%set-raw-bits))) + +(defun system-area-fill (value dst dst-offset length) + (declare (type unit value) (type offset dst-offset length)) + (locally + (declare (optimize (speed 3) (safety 0))) + (multiple-value-bind (dst dst-offset) + (fix-sap-and-offset dst dst-offset) + (do-constant-bit-bash dst dst-offset length value + #'word-sap-ref #'%set-word-sap-ref)))) + +(defun bit-bash-copy (src src-offset dst dst-offset length) + (declare (type offset src-offset dst-offset length)) + (locally + (declare (optimize (speed 3) (safety 0)) + (inline do-unary-bit-bash)) + (do-unary-bit-bash src src-offset dst dst-offset length + #'%raw-bits #'%set-raw-bits #'%raw-bits))) + (defun byte-bash-copy (src src-offset dst dst-offset length) (declare (type offset src-offset dst-offset length)) (locally ----------------------------------------------------------------------- Summary of changes: bin/build.sh | 2 +- src/bootfiles/20d/boot-2012-12-1.lisp | 6 +++ src/code/bit-bash.lisp | 71 +++++++++++++++------------------ src/code/lispinit.lisp | 6 ++- src/tools/comcom.lisp | 3 +- src/tools/worldcom.lisp | 3 +- 6 files changed, 48 insertions(+), 43 deletions(-) create mode 100644 src/bootfiles/20d/boot-2012-12-1.lisp hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-12-16-g8b62566
by Raymond Toy 24 Dec '12

24 Dec '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 8b625663a224043fc416f4c0c5f92b6a7b9d7232 (commit) from aa5f43846440d0fc20be6cb1edc5196ac6736165 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 8b625663a224043fc416f4c0c5f92b6a7b9d7232 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Dec 24 08:39:32 2012 -0800 Regenerated from sparc port. diff --git a/src/i18n/locale/cmucl-sparc-vm.pot b/src/i18n/locale/cmucl-sparc-vm.pot index 5117276..e8a69ef 100644 --- a/src/i18n/locale/cmucl-sparc-vm.pot +++ b/src/i18n/locale/cmucl-sparc-vm.pot @@ -782,7 +782,7 @@ msgstr "" msgid "Method ~S not defined for ~S" msgstr "" -#: src/compiler/sparc/c-call.lisp +#: src/compiler/sparc/c-callback.lisp msgid "" "Cons up a piece of code which calls call-callback with INDEX and a\n" "pointer to the arguments." ----------------------------------------------------------------------- Summary of changes: src/i18n/locale/cmucl-sparc-vm.pot | 2 +- 1 files changed, 1 insertions(+), 1 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-12-15-gaa5f438
by Raymond Toy 23 Dec '12

23 Dec '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via aa5f43846440d0fc20be6cb1edc5196ac6736165 (commit) via b845fa969a45dd0519d1b775a15facd521a7647f (commit) from cf48b6dccb205acec059a87602f3f1182c781a6e (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit aa5f43846440d0fc20be6cb1edc5196ac6736165 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Dec 23 12:15:46 2012 -0800 Regenerated. diff --git a/src/i18n/locale/cmucl-x86-vm.pot b/src/i18n/locale/cmucl-x86-vm.pot index 4ecc409..14dd9b1 100644 --- a/src/i18n/locale/cmucl-x86-vm.pot +++ b/src/i18n/locale/cmucl-x86-vm.pot @@ -316,7 +316,7 @@ msgstr "" msgid "Method ~S not defined for ~S" msgstr "" -#: src/compiler/x86/c-call.lisp +#: src/compiler/x86/c-callback.lisp msgid "" "Cons up a piece of code which calls call-callback with INDEX and a\n" "pointer to the arguments." diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot index 7dabde4..2d3c5ad 100644 --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -2004,26 +2004,26 @@ msgstr "" msgid "Can't use :out or :in-out on pointer-like type:~% ~S" msgstr "" -#: src/code/alieneval.lisp +#: src/code/alien-callback.lisp msgid "Vector of all callbacks." msgstr "" #: src/compiler/tn.lisp src/compiler/main.lisp src/code/describe.lisp #: src/code/debug-int.lisp src/code/debug-info.lisp #: src/code/foreign-linkage.lisp src/code/reader.lisp src/code/stream.lisp -#: src/code/hash-new.lisp src/code/array.lisp src/code/alieneval.lisp +#: src/code/hash-new.lisp src/code/array.lisp src/code/alien-callback.lisp msgid "~S is not an array with a fill-pointer." msgstr "" -#: src/code/alieneval.lisp +#: src/code/alien-callback.lisp msgid "Unable to mprotect ~S bytes (~S) at ~S (~S). Callbacks may not work." msgstr "" -#: src/code/alieneval.lisp +#: src/code/alien-callback.lisp msgid "Return the trampoline pointer for the callback NAME." msgstr "" -#: src/code/alieneval.lisp +#: src/code/alien-callback.lisp msgid "" "~\n" "Attempt to redefine callback with incompatible return type.\n" @@ -2031,20 +2031,20 @@ msgid "" " New type is: ~A" msgstr "" -#: src/code/alieneval.lisp +#: src/code/alien-callback.lisp msgid "~\n" "Create new trampoline (old trampoline calls old lisp function)." msgstr "" -#: src/code/alieneval.lisp +#: src/code/alien-callback.lisp msgid "Unsupported argument type: ~A" msgstr "" -#: src/code/alieneval.lisp +#: src/code/alien-callback.lisp msgid "Unsupported return type: ~A" msgstr "" -#: src/code/alieneval.lisp +#: src/code/alien-callback.lisp msgid "" "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*)\n" " {doc-string} {decls}* {FORM}*)\n" @@ -2153,6 +2153,10 @@ msgid "The number of bits to process at a time." msgstr "" #: src/code/bit-bash.lisp +msgid "The number of bytes to process at a time." +msgstr "" + +#: src/code/bit-bash.lisp msgid "" "The maximum number of bits that can be dealt with during a single call." msgstr "" @@ -16786,7 +16790,7 @@ msgid "" msgstr "" #: src/compiler/disassem.lisp -msgid "Instructions either aren't related or conflict in some way:~% ~s" +msgid "Instructions either aren't related or conflict in some way:~%" msgstr "" #: src/compiler/disassem.lisp commit b845fa969a45dd0519d1b775a15facd521a7647f Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Dec 23 12:15:12 2012 -0800 Fix a few compiler notes. diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index d0a3703..3a663a8 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -640,11 +640,9 @@ (unless (constant-continuation-p y) (give-up)) (let ((val (continuation-value y))) - (multiple-value-bind (frac exp sign) - (decode-float val) - (unless (= frac 0.5) - (give-up)) - `(* x (float (/ ,val) x))))) + (unless (= (decode-float val) 0.5) + (give-up)) + `(* x (float (/ ,val) x)))) ;; Convert 2*x to x+x. (deftransform * ((x y) (float real) * :when :both) diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index b4b43f7..5751abb 100644 --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -908,7 +908,6 @@ (:arg-types unsigned-num) (:results (result :scs (unsigned-reg))) (:result-types positive-fixnum) - (:temporary (:sc unsigned-reg :from (:argument 0)) temp) (:guard (backend-featurep :sse3)) (:generator 2 (inst popcnt result arg))) diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index e22a013..2417c04 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -556,7 +556,8 @@ (defun prefilter-reg-r (value dstate) (declare (type reg value) - (type disassem:disassem-state dstate)) + (type disassem:disassem-state dstate) + (ignore dstate)) value) ;;; This is a sort of bogus prefilter that just @@ -3115,6 +3116,7 @@ (imm :type 'imm-data)) (defun emit-sse-inst (segment dst src prefix opcode &key operand-size) + (declare (ignore operand-size)) (when prefix (emit-byte segment prefix)) (emit-byte segment #x0f) @@ -3223,11 +3225,13 @@ ;; MOVHPS (respectively). I (rtoy) don't know how to fix that; ;; instead. just print a note with the correct instruction name. (defun movlps-control (chunk inst stream dstate) + (declare (ignore inst)) (when stream (when (>= (ldb (byte 8 16) chunk) #xc0) (disassem:note "MOVHLPS" dstate)))) (defun movhps-control (chunk inst stream dstate) + (declare (ignore inst)) (when stream (when (>= (ldb (byte 8 16) chunk) #xc0) (disassem:note "MOVLHPS" dstate)))) diff --git a/src/compiler/x86/sse2-c-call.lisp b/src/compiler/x86/sse2-c-call.lisp index 811de98..a5bd80f 100644 --- a/src/compiler/x86/sse2-c-call.lisp +++ b/src/compiler/x86/sse2-c-call.lisp @@ -34,7 +34,6 @@ :from :eval :to :result) ecx) (:temporary (:sc unsigned-reg :offset edx-offset :from :eval :to :result) edx) - (:temporary (:sc double-stack) temp) (:node-var node) (:vop-var vop) (:save-p t) @@ -77,7 +76,6 @@ (define-vop (alloc-number-stack-space) (:info amount) (:results (result :scs (sap-reg any-reg))) - (:node-var node) (:generator 0 (assert (location= result esp-tn)) @@ -98,7 +96,6 @@ (define-vop (dealloc-number-stack-space) (:info amount) - (:node-var node) (:generator 0 (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) ----------------------------------------------------------------------- Summary of changes: src/compiler/float-tran.lisp | 8 +++----- src/compiler/x86/arith.lisp | 1 - src/compiler/x86/insts.lisp | 6 +++++- src/compiler/x86/sse2-c-call.lisp | 3 --- src/i18n/locale/cmucl-x86-vm.pot | 2 +- src/i18n/locale/cmucl.pot | 24 ++++++++++++++---------- 6 files changed, 23 insertions(+), 21 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-12-13-gcf48b6d
by Raymond Toy 23 Dec '12

23 Dec '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via cf48b6dccb205acec059a87602f3f1182c781a6e (commit) via 5d37fbf143530c391429d52fa07873e648675d86 (commit) via 0df4a14d0f2e83c6b6fdd9a5fd2b7cb024100660 (commit) from abc43728326721c0862a483035ad328400eca845 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit cf48b6dccb205acec059a87602f3f1182c781a6e Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Dec 23 11:25:48 2012 -0800 Move the alien callback support into its own files. compiler/ppc/c-callback.lisp:: compiler/sparc/c-callback.lisp:: compiler/x86/c-callback.lisp:: New file containing the callback code from c-call.lisp. compiler/ppc/c-call.lisp:: compiler/sparc/c-call.lisp:: compiler/x86/c-call.lisp:: Removed the callback code. code/alien-callback.lisp:: New file containing the alien callback code. code/alieneval.lisp:: Removed the alien callback code. tools/comcom.lisp:: Compile c-callback.lisp tools/worldcom.lisp: Compile alien-callback.lisp. diff --git a/src/code/alien-callback.lisp b/src/code/alien-callback.lisp new file mode 100644 index 0000000..b6e73be --- /dev/null +++ b/src/code/alien-callback.lisp @@ -0,0 +1,417 @@ +;;; -*- Package: ALIEN -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: src/code/alieneval.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains any the part of the Alien implementation that +;;; is not part of the compiler. +;;; +(in-package "ALIEN") +(use-package "EXT") +(use-package "SYSTEM") + +(intl:textdomain "cmucl") + +(export '(alien * array struct union enum function integer signed unsigned + boolean values single-float double-float long-float + system-area-pointer def-alien-type def-alien-variable sap-alien + extern-alien with-alien slot deref addr cast alien-sap alien-size + alien-funcall def-alien-routine make-alien free-alien + null-alien + def-callback callback + callback-funcall)) + +(in-package "ALIEN-INTERNALS") +(in-package "ALIEN") + +(import '(alien alien-value alien-value-type parse-alien-type + unparse-alien-type alien-type-= alien-subtype-p alien-typep + + def-alien-type-class def-alien-type-translator def-alien-type-method + invoke-alien-type-method + + alien-type alien-type-p alien-type-bits alien-type-alignment + alien-integer-type alien-integer-type-p alien-integer-type-signed + alien-boolean-type alien-boolean-type-p + alien-enum-type alien-enum-type-p + alien-float-type alien-float-type-p + alien-single-float-type alien-single-float-type-p + alien-double-float-type alien-double-float-type-p + alien-long-float-type alien-long-float-type-p + alien-pointer-type alien-pointer-type-p alien-pointer-type-to + make-alien-pointer-type + alien-array-type alien-array-type-p alien-array-type-element-type + alien-array-type-dimensions + alien-record-type alien-record-type-p alien-record-type-fields + alien-record-field alien-record-field-p alien-record-field-name + alien-record-field-type alien-record-field-offset + alien-function-type alien-function-type-p make-alien-function-type + alien-function-type-result-type alien-function-type-arg-types + alien-values-type alien-values-type-p alien-values-type-values + *values-type-okay* + + %set-slot %slot-addr %set-deref %deref-addr + + %heap-alien %set-heap-alien %heap-alien-addr + heap-alien-info heap-alien-info-p heap-alien-info-type + heap-alien-info-sap-form + + local-alien %set-local-alien %local-alien-addr + local-alien-info local-alien-info-p local-alien-info-type + local-alien-info-force-to-memory-p + %local-alien-forced-to-memory-p + make-local-alien dispose-local-alien note-local-alien-type + + %cast %sap-alien align-offset + + extract-alien-value deposit-alien-value naturalize deport + compute-lisp-rep-type compute-alien-rep-type + compute-extract-lambda compute-deposit-lambda + compute-naturalize-lambda compute-deport-lambda) + "ALIEN-INTERNALS") + +(export '(alien alien-value alien-value-type parse-alien-type + unparse-alien-type alien-type-= alien-subtype-p alien-typep + + def-alien-type-class def-alien-type-translator def-alien-type-method + invoke-alien-type-method + + alien-type alien-type-p alien-type-bits alien-type-alignment + alien-integer-type alien-integer-type-p alien-integer-type-signed + alien-boolean-type alien-boolean-type-p + alien-enum-type alien-enum-type-p + alien-float-type alien-float-type-p + alien-single-float-type alien-single-float-type-p + alien-double-float-type alien-double-float-type-p + alien-long-float-type alien-long-float-type-p + alien-pointer-type alien-pointer-type-p alien-pointer-type-to + make-alien-pointer-type + alien-array-type alien-array-type-p alien-array-type-element-type + alien-array-type-dimensions + alien-record-type alien-record-type-p alien-record-type-fields + alien-record-field alien-record-field-p alien-record-field-name + alien-record-field-type alien-record-field-offset + alien-function-type alien-function-type-p make-alien-function-type + alien-function-type-result-type alien-function-type-arg-types + alien-values-type alien-values-type-p alien-values-type-values + *values-type-okay* + + %set-slot %slot-addr %set-deref %deref-addr + + %heap-alien %set-heap-alien %heap-alien-addr + heap-alien-info heap-alien-info-p heap-alien-info-type + heap-alien-info-sap-form + + local-alien %set-local-alien %local-alien-addr + local-alien-info local-alien-info-p local-alien-info-type + local-alien-info-force-to-memory-p + %local-alien-forced-to-memory-p + make-local-alien dispose-local-alien note-local-alien-type + + %cast %sap-alien align-offset + + extract-alien-value deposit-alien-value naturalize deport + compute-lisp-rep-type compute-alien-rep-type + compute-extract-lambda compute-deposit-lambda + compute-naturalize-lambda compute-deport-lambda) + "ALIEN-INTERNALS") + + +;;;; Alien callback support +;;;; +;;;; This is basically the implementation posted by Helmut Eller, +;;;; posted to cmucl-imp on 04/13/2003. It has been modified to live +;;;; in the ALIEN package and to fit the same style as the ALIEN +;;;; package. + +;;; This package provides a mechanism for defining callbacks: lisp +;;; functions which can be called from foreign code. The user +;;; interface consists of the macros DEFCALLBACK and CALLBACK. (See +;;; the doc-strings for details.) +;;; +;;; Below are two examples. The first example defines a callback FOO +;;; and calls it with alien-funcall. The second illustrates the use +;;; of the libc qsort function. +;;; +;;; The implementation generates a piece machine code -- a +;;; "trampoline" -- for each callback function. A pointer to this +;;; trampoline can then be passed to foreign code. The trampoline is +;;; allocated with malloc and is not moved by the GC. +;;; +;;; When called, the trampoline passes a pointer to the arguments +;;; (essentially the stack pointer) together with an index to +;;; CALL-CALLBACK. CALL-CALLBACK uses the index to find the +;;; corresponding lisp function and calls this function with the +;;; argument pointer. The lisp function uses the pointer to copy the +;;; arguments from the stack to local variables. On return, the lisp +;;; function stores the result into the location given by the argument +;;; pointer, and the trampoline code copies the return value from +;;; there into the right return register. +;;; +;;; The address of CALL-CALLBACK is used in every trampoline and must +;;; not be moved by the gc. It is therefore necessary to either +;;; include this package into the image (core) or to purify before +;;; creating any trampolines (or to invent some other trick). +;;; +;;; Examples: + +#|| +;;; Example 1: + +(alien:def-callback foo (c-call:int (arg1 c-call:int) (arg2 c-call:int)) + (format t "~&foo: ~S, ~S~%" arg1 arg2) + (+ arg1 arg2)) + +(alien:alien-funcall (alien:sap-alien (alien:callback foo) + (function c-call:int c-call:int c-call:int)) + 555 444444) + +;;; Example 2: + +(alien:def-alien-routine qsort c-call:void + (base (* t)) + (nmemb c-call:int) + (size c-call:int) + (compar (* (function c-call:int (* t) (* t))))) + +(alien:def-callback my< (c-call:int (arg1 (* c-call:double)) + (arg2 (* c-call:double))) + (let ((a1 (alien:deref arg1)) + (a2 (alien:deref arg2))) + (cond ((= a1 a2) 0) + ((< a1 a2) -1) + (t +1)))) + +(let ((a (make-array 10 :element-type 'double-float + :initial-contents '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0 + 2.5d0 0.0d0 0.1d0 0.2d0 0.3d0)))) + (print a) + (qsort (sys:vector-sap a) + (length a) + (alien:alien-size c-call:double :bytes) + (alien:callback my<)) + (print a)) + +||# + +(defstruct (callback + (:constructor make-callback (trampoline lisp-fn function-type))) + "A callback consists of a piece assembly code -- the trampoline -- +and a lisp function. We store the function type (including return +type and arg types), so we can detect incompatible redefinitions." + (trampoline (required-argument) :type system-area-pointer) + (lisp-fn (required-argument) :type (function (fixnum fixnum) (values))) + (function-type (required-argument) :type alien::alien-function-type)) + +(declaim (type (vector callback) *callbacks*)) +(defvar *callbacks* (make-array 10 :element-type 'callback + :fill-pointer 0 :adjustable t) + "Vector of all callbacks.") + +(defun call-callback (index sp-fixnum ret-addr) + (declare (type fixnum index sp-fixnum ret-addr) + (optimize speed)) + (funcall (callback-lisp-fn (aref *callbacks* index)) + sp-fixnum ret-addr)) + +(defun create-callback (lisp-fn fn-type) + (let* ((index (fill-pointer *callbacks*)) + (tramp (vm:make-callback-trampoline index fn-type)) + (cb (make-callback tramp lisp-fn fn-type))) + (vector-push-extend cb *callbacks*) + cb)) + +(defun address-of-call-callback () + (kernel:get-lisp-obj-address #'call-callback)) + +(defun address-of-funcall3 () + (sys:sap-int (alien-sap (extern-alien "funcall3" (function (* t)))))) + +;;; Some abbreviations for alien-type classes. The $ suffix is there +;;; to prevent name clashes. + +(deftype void$ () '(satisfies alien-void-type-p)) +(deftype integer$ () 'alien-integer-type) +(deftype integer-64$ () '(satisfies alien-integer-64-type-p)) +(deftype signed-integer$ () '(satisfies alien-signed-integer-type-p)) +(deftype pointer$ () 'alien-pointer-type) +(deftype single$ () 'alien-single-float-type) +(deftype double$ () 'alien-double-float-type) +(deftype sap$ () '(satisfies alien-sap-type=)) + +(defun alien-sap-type= (type) + (alien-type-= type (parse-alien-type 'system-area-pointer))) + +(defun alien-void-type-p (type) + (and (alien-values-type-p type) + (null (alien-values-type-values type)))) + +(defun alien-integer-64-type-p (type) + (and (alien-integer-type-p type) + (= (alien-type-bits type) 64))) + +(defun alien-signed-integer-type-p (type) + (and (alien-integer-type-p type) + (alien-integer-type-signed type))) + +(defun segment-to-trampoline (segment length) + (let* ((code (alien-funcall + (extern-alien "malloc" (function system-area-pointer unsigned)) + length)) + (fill-pointer code)) + ;; Make sure the malloc'ed area is executable. + (let* ((page-size (get-page-size)) + ;; mprotect wants address on a page boundary, so round down + ;; the address and round up the length + (code-base (sys:int-sap (* page-size + (floor (sys:sap-int code) page-size)))) + (len (* page-size (ceiling length page-size)))) + (unless (unix::unix-mprotect code-base len + (logior unix:prot_exec unix:prot_read unix:prot_write)) + (warn (intl:gettext "Unable to mprotect ~S bytes (~S) at ~S (~S). Callbacks may not work.") + len length code-base code))) + (new-assem:segment-map-output segment + (lambda (sap length) + (kernel:system-area-copy sap 0 fill-pointer 0 + (* length vm:byte-bits)) + (setf fill-pointer (sys:sap+ fill-pointer length)))) + code)) + +(defun symbol-trampoline (symbol) + (callback-trampoline (symbol-value symbol))) + +(defmacro callback (name) + "Return the trampoline pointer for the callback NAME." + `(symbol-trampoline ',name)) + +;; Convenience macro to make it easy to call callbacks. +(defmacro callback-funcall (name &rest args) + `(alien-funcall (sap-alien (callback ,name) + ,(unparse-alien-type + (callback-function-type (symbol-value name)))) + ,@args)) + +(defun define-callback-function (name lisp-fn fn-type) + (declare (type symbol name) + (type function lisp-fn)) + (flet ((register-new-callback () + (setf (symbol-value name) + (create-callback lisp-fn fn-type)))) + (if (and (boundp name) + (callback-p (symbol-value name))) + ;; try do redefine the existing callback + (let ((callback (find (symbol-trampoline name) *callbacks* + :key #'callback-trampoline :test #'sys:sap=))) + (cond (callback + (let ((old-type (callback-function-type callback))) + (cond ((vm::compatible-function-types-p old-type fn-type) + ;; (format t "~&; Redefining callback ~A~%" name) + (setf (callback-lisp-fn callback) lisp-fn) + (setf (callback-function-type callback) fn-type) + callback) + (t + (let ((e (format nil (intl:gettext "~ +Attempt to redefine callback with incompatible return type. + Old type was: ~A + New type is: ~A") old-type fn-type)) + (c (format nil (intl:gettext "~ +Create new trampoline (old trampoline calls old lisp function).")))) + (cerror c e) + (register-new-callback)))))) + (t (register-new-callback)))) + (register-new-callback)))) + +(defun word-aligned-bits (type) + (align-offset (alien-type-bits type) vm:word-bits)) + +(defun argument-size (spec) + (let ((type (parse-alien-type spec))) + (typecase type + ((or integer$ single$ double$ pointer$ sap$) + (ceiling (word-aligned-bits type) vm:byte-bits)) + (t (error (intl:gettext "Unsupported argument type: ~A") spec))))) + +(defun parse-return-type (spec) + (let ((*values-type-okay* t)) + (parse-alien-type spec))) + +(defun parse-function-type (return-type arg-specs) + (parse-alien-type + `(function ,return-type ,@(mapcar #'second arg-specs)))) + +(defun return-exp (spec sap body) + (flet ((store (spec) `(setf (deref (sap-alien ,sap (* ,spec))) ,body))) + (let ((type (parse-return-type spec))) + (typecase type + (void$ body) + (signed-integer$ + (store `(signed ,(word-aligned-bits type)))) + (integer$ + (store `(unsigned ,(word-aligned-bits type)))) + ((or single$ double$ pointer$ sap$) + (store spec)) + (t (error (intl:gettext "Unsupported return type: ~A") spec)))))) + +(defmacro def-callback (name (return-type &rest arg-specs) &parse-body (body decls doc)) + "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*) + {doc-string} {decls}* {FORM}*) + +Define a function which can be called by foreign code. The pointer +returned by (callback NAME), when called by foreign code, invokes the +lisp function. The lisp function expects alien arguments of the +specified ARG-TYPEs and returns an alien of type RETURN-TYPE. + +If (callback NAME) is already a callback function pointer, its value +is not changed (though it's arranged that an updated version of the +lisp callback function will be called). This feature allows for +incremental redefinition of callback functions." + (let ((sp-fixnum (gensym (string :sp-fixnum-))) + (ret-addr (gensym (string :ret-addr-))) + (sp (gensym (string :sp-))) + (ret (gensym (string :ret-)))) + `(progn + (defun ,name (,sp-fixnum ,ret-addr) + ,@(when doc (list doc)) + (declare (type fixnum ,sp-fixnum ,ret-addr)) + ,@decls + ;; We assume sp-fixnum is word aligned and pass it untagged to + ;; this function. The shift compensates this. + (let ((,sp (sys:int-sap (bignum:%ashl (ldb (byte vm:word-bits 0) ,sp-fixnum) + 2))) + (,ret (sys:int-sap (bignum:%ashl (ldb (byte vm:word-bits 0) ,ret-addr) + 2)))) + (declare (ignorable ,sp ,ret)) + ;; Copy all arguments to local variables. + (with-alien ,(loop for offset = 0 then (+ offset + (argument-size type)) + for (name type) in arg-specs + collect `(,name ,type + :local ,(vm:callback-accessor-form type sp offset))) + ,(return-exp return-type ret `(progn ,@body)) + (values)))) + (define-callback-function + ',name #',name ',(parse-function-type return-type arg-specs))))) + +;;; dumping support + +(defun restore-callbacks () + ;; Create new trampolines on reload. + (loop for cb across *callbacks* + for i from 0 + do (setf (callback-trampoline cb) + (vm:make-callback-trampoline i (callback-function-type cb))))) + +;; *after-save-initializations* contains +;; new-assem::forget-output-blocks, and the assembler may not work +;; before forget-output-blocks was called. We add 'restore-callback at +;; the end of *after-save-initializations* to sidestep this problem. +(setf *after-save-initializations* + (append *after-save-initializations* (list 'restore-callbacks))) + +;;; callback.lisp ends here diff --git a/src/code/alieneval.lisp b/src/code/alieneval.lisp index c8f0fb8..124f74e 100644 --- a/src/code/alieneval.lisp +++ b/src/code/alieneval.lisp @@ -2078,296 +2078,3 @@ If so return true; otherwise call ALTERNATIVE." (values ,@temps ,@(results)))) `(values (alien-funcall ,lisp-name ,@(alien-args)) ,@(results)))))))) - -;;;; Alien callback support -;;;; -;;;; This is basically the implementation posted by Helmut Eller, -;;;; posted to cmucl-imp on 04/13/2003. It has been modified to live -;;;; in the ALIEN package and to fit the same style as the ALIEN -;;;; package. - -;;; This package provides a mechanism for defining callbacks: lisp -;;; functions which can be called from foreign code. The user -;;; interface consists of the macros DEFCALLBACK and CALLBACK. (See -;;; the doc-strings for details.) -;;; -;;; Below are two examples. The first example defines a callback FOO -;;; and calls it with alien-funcall. The second illustrates the use -;;; of the libc qsort function. -;;; -;;; The implementation generates a piece machine code -- a -;;; "trampoline" -- for each callback function. A pointer to this -;;; trampoline can then be passed to foreign code. The trampoline is -;;; allocated with malloc and is not moved by the GC. -;;; -;;; When called, the trampoline passes a pointer to the arguments -;;; (essentially the stack pointer) together with an index to -;;; CALL-CALLBACK. CALL-CALLBACK uses the index to find the -;;; corresponding lisp function and calls this function with the -;;; argument pointer. The lisp function uses the pointer to copy the -;;; arguments from the stack to local variables. On return, the lisp -;;; function stores the result into the location given by the argument -;;; pointer, and the trampoline code copies the return value from -;;; there into the right return register. -;;; -;;; The address of CALL-CALLBACK is used in every trampoline and must -;;; not be moved by the gc. It is therefore necessary to either -;;; include this package into the image (core) or to purify before -;;; creating any trampolines (or to invent some other trick). -;;; -;;; Examples: - -#|| -;;; Example 1: - -(alien:def-callback foo (c-call:int (arg1 c-call:int) (arg2 c-call:int)) - (format t "~&foo: ~S, ~S~%" arg1 arg2) - (+ arg1 arg2)) - -(alien:alien-funcall (alien:sap-alien (alien:callback foo) - (function c-call:int c-call:int c-call:int)) - 555 444444) - -;;; Example 2: - -(alien:def-alien-routine qsort c-call:void - (base (* t)) - (nmemb c-call:int) - (size c-call:int) - (compar (* (function c-call:int (* t) (* t))))) - -(alien:def-callback my< (c-call:int (arg1 (* c-call:double)) - (arg2 (* c-call:double))) - (let ((a1 (alien:deref arg1)) - (a2 (alien:deref arg2))) - (cond ((= a1 a2) 0) - ((< a1 a2) -1) - (t +1)))) - -(let ((a (make-array 10 :element-type 'double-float - :initial-contents '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0 - 2.5d0 0.0d0 0.1d0 0.2d0 0.3d0)))) - (print a) - (qsort (sys:vector-sap a) - (length a) - (alien:alien-size c-call:double :bytes) - (alien:callback my<)) - (print a)) - -||# - -(defstruct (callback - (:constructor make-callback (trampoline lisp-fn function-type))) - "A callback consists of a piece assembly code -- the trampoline -- -and a lisp function. We store the function type (including return -type and arg types), so we can detect incompatible redefinitions." - (trampoline (required-argument) :type system-area-pointer) - (lisp-fn (required-argument) :type (function (fixnum fixnum) (values))) - (function-type (required-argument) :type alien::alien-function-type)) - -(declaim (type (vector callback) *callbacks*)) -(defvar *callbacks* (make-array 10 :element-type 'callback - :fill-pointer 0 :adjustable t) - "Vector of all callbacks.") - -(defun call-callback (index sp-fixnum ret-addr) - (declare (type fixnum index sp-fixnum ret-addr) - (optimize speed)) - (funcall (callback-lisp-fn (aref *callbacks* index)) - sp-fixnum ret-addr)) - -(defun create-callback (lisp-fn fn-type) - (let* ((index (fill-pointer *callbacks*)) - (tramp (vm:make-callback-trampoline index fn-type)) - (cb (make-callback tramp lisp-fn fn-type))) - (vector-push-extend cb *callbacks*) - cb)) - -(defun address-of-call-callback () - (kernel:get-lisp-obj-address #'call-callback)) - -(defun address-of-funcall3 () - (sys:sap-int (alien-sap (extern-alien "funcall3" (function (* t)))))) - -;;; Some abbreviations for alien-type classes. The $ suffix is there -;;; to prevent name clashes. - -(deftype void$ () '(satisfies alien-void-type-p)) -(deftype integer$ () 'alien-integer-type) -(deftype integer-64$ () '(satisfies alien-integer-64-type-p)) -(deftype signed-integer$ () '(satisfies alien-signed-integer-type-p)) -(deftype pointer$ () 'alien-pointer-type) -(deftype single$ () 'alien-single-float-type) -(deftype double$ () 'alien-double-float-type) -(deftype sap$ () '(satisfies alien-sap-type=)) - -(defun alien-sap-type= (type) - (alien-type-= type (parse-alien-type 'system-area-pointer))) - -(defun alien-void-type-p (type) - (and (alien-values-type-p type) - (null (alien-values-type-values type)))) - -(defun alien-integer-64-type-p (type) - (and (alien-integer-type-p type) - (= (alien-type-bits type) 64))) - -(defun alien-signed-integer-type-p (type) - (and (alien-integer-type-p type) - (alien-integer-type-signed type))) - -(defun segment-to-trampoline (segment length) - (let* ((code (alien-funcall - (extern-alien "malloc" (function system-area-pointer unsigned)) - length)) - (fill-pointer code)) - ;; Make sure the malloc'ed area is executable. - (let* ((page-size (get-page-size)) - ;; mprotect wants address on a page boundary, so round down - ;; the address and round up the length - (code-base (sys:int-sap (* page-size - (floor (sys:sap-int code) page-size)))) - (len (* page-size (ceiling length page-size)))) - (unless (unix::unix-mprotect code-base len - (logior unix:prot_exec unix:prot_read unix:prot_write)) - (warn (intl:gettext "Unable to mprotect ~S bytes (~S) at ~S (~S). Callbacks may not work.") - len length code-base code))) - (new-assem:segment-map-output segment - (lambda (sap length) - (kernel:system-area-copy sap 0 fill-pointer 0 - (* length vm:byte-bits)) - (setf fill-pointer (sys:sap+ fill-pointer length)))) - code)) - -(defun symbol-trampoline (symbol) - (callback-trampoline (symbol-value symbol))) - -(defmacro callback (name) - "Return the trampoline pointer for the callback NAME." - `(symbol-trampoline ',name)) - -;; Convenience macro to make it easy to call callbacks. -(defmacro callback-funcall (name &rest args) - `(alien-funcall (sap-alien (callback ,name) - ,(unparse-alien-type - (callback-function-type (symbol-value name)))) - ,@args)) - -(defun define-callback-function (name lisp-fn fn-type) - (declare (type symbol name) - (type function lisp-fn)) - (flet ((register-new-callback () - (setf (symbol-value name) - (create-callback lisp-fn fn-type)))) - (if (and (boundp name) - (callback-p (symbol-value name))) - ;; try do redefine the existing callback - (let ((callback (find (symbol-trampoline name) *callbacks* - :key #'callback-trampoline :test #'sys:sap=))) - (cond (callback - (let ((old-type (callback-function-type callback))) - (cond ((vm::compatible-function-types-p old-type fn-type) - ;; (format t "~&; Redefining callback ~A~%" name) - (setf (callback-lisp-fn callback) lisp-fn) - (setf (callback-function-type callback) fn-type) - callback) - (t - (let ((e (format nil (intl:gettext "~ -Attempt to redefine callback with incompatible return type. - Old type was: ~A - New type is: ~A") old-type fn-type)) - (c (format nil (intl:gettext "~ -Create new trampoline (old trampoline calls old lisp function).")))) - (cerror c e) - (register-new-callback)))))) - (t (register-new-callback)))) - (register-new-callback)))) - -(defun word-aligned-bits (type) - (align-offset (alien-type-bits type) vm:word-bits)) - -(defun argument-size (spec) - (let ((type (parse-alien-type spec))) - (typecase type - ((or integer$ single$ double$ pointer$ sap$) - (ceiling (word-aligned-bits type) vm:byte-bits)) - (t (error (intl:gettext "Unsupported argument type: ~A") spec))))) - -(defun parse-return-type (spec) - (let ((*values-type-okay* t)) - (parse-alien-type spec))) - -(defun parse-function-type (return-type arg-specs) - (parse-alien-type - `(function ,return-type ,@(mapcar #'second arg-specs)))) - -(defun return-exp (spec sap body) - (flet ((store (spec) `(setf (deref (sap-alien ,sap (* ,spec))) ,body))) - (let ((type (parse-return-type spec))) - (typecase type - (void$ body) - (signed-integer$ - (store `(signed ,(word-aligned-bits type)))) - (integer$ - (store `(unsigned ,(word-aligned-bits type)))) - ((or single$ double$ pointer$ sap$) - (store spec)) - (t (error (intl:gettext "Unsupported return type: ~A") spec)))))) - -(defmacro def-callback (name (return-type &rest arg-specs) &parse-body (body decls doc)) - "(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*) - {doc-string} {decls}* {FORM}*) - -Define a function which can be called by foreign code. The pointer -returned by (callback NAME), when called by foreign code, invokes the -lisp function. The lisp function expects alien arguments of the -specified ARG-TYPEs and returns an alien of type RETURN-TYPE. - -If (callback NAME) is already a callback function pointer, its value -is not changed (though it's arranged that an updated version of the -lisp callback function will be called). This feature allows for -incremental redefinition of callback functions." - (let ((sp-fixnum (gensym (string :sp-fixnum-))) - (ret-addr (gensym (string :ret-addr-))) - (sp (gensym (string :sp-))) - (ret (gensym (string :ret-)))) - `(progn - (defun ,name (,sp-fixnum ,ret-addr) - ,@(when doc (list doc)) - (declare (type fixnum ,sp-fixnum ,ret-addr)) - ,@decls - ;; We assume sp-fixnum is word aligned and pass it untagged to - ;; this function. The shift compensates this. - (let ((,sp (sys:int-sap (bignum:%ashl (ldb (byte vm:word-bits 0) ,sp-fixnum) - 2))) - (,ret (sys:int-sap (bignum:%ashl (ldb (byte vm:word-bits 0) ,ret-addr) - 2)))) - (declare (ignorable ,sp ,ret)) - ;; Copy all arguments to local variables. - (with-alien ,(loop for offset = 0 then (+ offset - (argument-size type)) - for (name type) in arg-specs - collect `(,name ,type - :local ,(vm:callback-accessor-form type sp offset))) - ,(return-exp return-type ret `(progn ,@body)) - (values)))) - (define-callback-function - ',name #',name ',(parse-function-type return-type arg-specs))))) - -;;; dumping support - -(defun restore-callbacks () - ;; Create new trampolines on reload. - (loop for cb across *callbacks* - for i from 0 - do (setf (callback-trampoline cb) - (vm:make-callback-trampoline i (callback-function-type cb))))) - -;; *after-save-initializations* contains -;; new-assem::forget-output-blocks, and the assembler may not work -;; before forget-output-blocks was called. We add 'restore-callback at -;; the end of *after-save-initializations* to sidestep this problem. -(setf *after-save-initializations* - (append *after-save-initializations* (list 'restore-callbacks))) - -;;; callback.lisp ends here diff --git a/src/compiler/ppc/c-call.lisp b/src/compiler/ppc/c-call.lisp index 4fd20b6..1d08a2e 100644 --- a/src/compiler/ppc/c-call.lisp +++ b/src/compiler/ppc/c-call.lisp @@ -386,250 +386,3 @@ (inst addi nsp-tn nsp-tn delta)) (t (inst lwz nsp-tn nsp-tn 0))))))) - - -(export '(make-callback-trampoline callback-accessor-form - compatible-function-types-p)) - -(defun callback-accessor-form (type sp offset) - (let ((parsed-type (alien::parse-alien-type type))) - (typecase parsed-type - (alien::integer-64$ - ;; Get both words of a 64-bit integer and combine together, in - ;; a big-endian fashion. - `(let ((hi (alien:deref (sap-alien (sys:sap+ ,sp ,offset) - ,(if (alien-integer-type-signed parsed-type) - '(* c-call:int) - '(* c-call:unsigned-int))))) - (lo (alien:deref (sap-alien (sys:sap+ ,sp - (+ ,offset vm:word-bytes)) - (* c-call:unsigned-int))))) - (+ (ash hi vm:word-bits) lo))) - (alien::integer$ - ;; We can access machine integers directly, but we need to get - ;; the offset right, since the offset we're given is the start - ;; of the object, and we're a big-endian machine. - (let ((byte-offset - (- vm:word-bytes - (ceiling (alien::alien-integer-type-bits parsed-type) - vm:byte-bits)))) - `(deref (sap-alien (sys:sap+ ,sp ,(+ byte-offset offset)) - (* ,type))))) - (t - ;; This should work for everything else. - `(deref (sap-alien (sys:sap+ ,sp ,offset) - (* ,type))))))) - -(defun compatible-function-types-p (fun-type1 fun-type2) - (labels ((type-words (type) - (ceiling (alien-type-bits type) vm:word-bits)) - (compatible-type-p (type1 type2) - (let ((float1 (alien-float-type-p type1)) - (float2 (alien-float-type-p type2))) - (and (if float1 - float2 - (not float2)) - (= (type-words type1) (type-words type2)))))) - (let ((args1 (alien-function-type-arg-types fun-type1)) - (args2 (alien-function-type-arg-types fun-type2)) - (ret1 (alien-function-type-result-type fun-type1)) - (ret2 (alien-function-type-result-type fun-type2))) - (and (= (length args1) (length args2)) - (every #'compatible-type-p args1 args2) - (compatible-type-p ret1 ret2))))) - -(defun make-callback-trampoline (index fn-type) - (let ((return-type (alien-function-type-result-type fn-type)) - (arg-types (alien::alien-function-type-arg-types fn-type))) - (make-callback-trampoline-segment index arg-types return-type))) - -(defun make-callback-trampoline-segment (index argument-types return-type) - "Return an sb-assem:segment which calls call-callback with INDEX and -a pointer to the arguments." - (declare (type (unsigned-byte 16) index) - (optimize (debug 3))) - (flet ((make-gpr (n) - (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n)) - (make-fpr (n) - (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) - :offset n)) - (round-up-16 (n) - ;; Round up to a multiple of 16. Darwin wants that for the - ;; stack pointer. - (* 16 (ceiling n 16)))) - - ;; The "Mach-O Runtime Conventions" document for OS X almost specifies - ;; the calling convention (it neglects to mention that the linkage area - ;; is 24 bytes). - (let* ((segment (make-segment)) - (save-gprs (mapcar #'make-gpr '(13 24))) - - (argument-words - (mapcar (lambda (arg) (ceiling (alien-type-bits arg) vm:word-bits)) - argument-types)) - (linkage-area-size 24)) - (assemble (segment) - - (let ((sp (make-gpr 1))) - - ;; To save our arguments, we follow the algorithm sketched in the - ;; "PowerPC Calling Conventions" section of that document. - (let ((words-processed 0) - (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10))) - (fprs (mapcar #'make-fpr '(1 2 3 4 5 6 7 8 9 10 11 12 13)))) - (flet ((handle-arg (type words) - (let ((integerp (not (alien-float-type-p type))) - (offset (+ (* words-processed vm:word-bytes) - linkage-area-size))) - (cond - (integerp - (dotimes (k words) - (let ((gpr (pop gprs))) - (when gpr - (inst stw gpr sp offset) - (incf words-processed) - (incf offset vm:word-bytes))))) - ;; The handling of floats is a little ugly because we - ;; hard-code the number of words for single- and - ;; double-floats. - ((alien-single-float-type-p type) - (pop gprs) - (let ((fpr (pop fprs))) - (inst stfs fpr sp offset)) - (incf words-processed)) - ((alien-double-float-type-p type) - (setf gprs (cddr gprs)) - (let ((fpr (pop fprs))) - (inst stfd fpr sp offset)) - (incf words-processed 2)))))) - (mapc #'handle-arg argument-types argument-words))) - - ;; The args have been saved to memory. - ;; - ;; The stack frame is something like this: - ;; - ;; stack arg n - ;; ... - ;; stack arg 1 - ;; stack arg 0 - ;; save arg 7 - ;; save arg 6 - ;; save arg 5 - ;; save arg 4 - ;; save arg 3 - ;; save arg 2 - ;; save arg 1 - ;; save arg 0 - ;; 24 bytes for linkage area - ;; -> sp points to the bottom of the linkage area - ;; - ;; Set aside space for our stack frame. We need enough room - ;; for the callback return area, some space to save the - ;; non-volatile (callee-saved) registers, space to save the - ;; args for the function we're calling, and the linkage - ;; area. The space is rounded up to a multiple of 16 bytes - ;; because the stack should be aligned to a multiple of 16 - ;; bytes. - ;; - ;; Our stack frame will look something like this now: - ;; - ;; Offset Value - ;; 64 Caller's frame (see above) - ;; 56/60 return area (1 or 2 words) - ;; 48 filler (unused) - ;; 44 save r24 - ;; 40 save r13 - ;; 36 save arg 3 - ;; 32 save arg 2 - ;; 28 save arg 1 - ;; 24 save arg 0 - ;; 0 linkage area (24 bytes) - ;; - ;; - ;; The return area is allocated at the top of the frame. - ;; When we call funcall3, the linkage table entry is used, - ;; which unconditionally uses r13 and r24. (See - ;; lisp/ppc-arch.c.) So these need to be saved. funcall3, - ;; which calls call_into_lisp, will take care of saving all - ;; the remaining registers that could be used. - - ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to - ;; be because they're word-aligned. Kinda gross, but - ;; hey.... - - (let* ((return-area-words (ceiling (or (alien-type-bits return-type) - 0) - vm:word-bits)) - (save-words (length save-gprs)) - (args-size (* 4 vm:word-bytes)) - (frame-size - (round-up-16 (+ linkage-area-size - (* return-area-words vm:word-bytes) - (* save-words vm:word-bytes) - args-size)))) - (destructuring-bind (r0 arg1 arg2 arg3 arg4) - (mapcar #'make-gpr '(0 3 4 5 6)) - ;; Setup the args for the call. We call - ;; funcall3(call-callback, index, arg-pointer, - ;; return-area-address) - (inst lr arg1 (alien::address-of-call-callback)) - (inst li arg2 (fixnumize index)) - (inst addi arg3 sp linkage-area-size) - (inst addi arg4 sp (- (* return-area-words vm:word-bytes))) - - ;; Save sp, setup the frame - (inst mflr r0) - (inst stw r0 sp (* 2 vm:word-bytes)) - (inst stwu sp sp (- frame-size)) - - ;; Save the caller-saved registers that the linkage - ;; table trampoline clobbers. - (let ((save-offset (+ linkage-area-size args-size))) - (dolist (r save-gprs) - (inst stw r sp save-offset) - (incf save-offset vm:word-bytes))) - - ;; Make the call - (inst lr r0 (alien::address-of-funcall3)) - (inst mtlr r0) - (inst blrl) - - (let ((return-offset (- frame-size - (* return-area-words vm:word-bytes)))) - (etypecase return-type - ((or alien::integer$ alien::pointer$ alien::sap$ - alien::integer-64$) - (loop repeat return-area-words - with gprs = (mapcar #'make-gpr '(3 4)) - for gpr = (pop gprs) - for offset from return-offset by vm:word-bytes - do (inst lwz gpr sp offset))) - (alien::single$ - ;; Get the FP value into F1 - (let ((f1 (make-fpr 1))) - (inst lfs f1 sp return-offset))) - (alien::double$ - ;; Get the FP value into F1 - (let ((f1 (make-fpr 1))) - (inst lfd f1 sp return-offset))) - (alien::void$ - ;; Nothing to do - ))) - - ;; Restore the GPRS we saved. - (let ((save-offset (+ linkage-area-size args-size))) - (dolist (r save-gprs) - (inst lwz r sp save-offset) - (incf save-offset vm:word-bytes))) - - ;; All done. Restore sp and lr and return. - (inst lwz r0 sp (+ frame-size (* 2 vm:word-bytes))) - (inst mtlr r0) - (inst addic sp sp frame-size) - - ;; And back we go! - (inst blr))))) - - (let ((length (finalize-segment segment))) - (prog1 (alien::segment-to-trampoline segment length) - (release-segment segment)))))) diff --git a/src/compiler/ppc/c-callback.lisp b/src/compiler/ppc/c-callback.lisp new file mode 100644 index 0000000..2ebd6f4 --- /dev/null +++ b/src/compiler/ppc/c-callback.lisp @@ -0,0 +1,266 @@ +;;; -*- Package: PPC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group(a)cs.cmu.edu. +;;; +(ext:file-comment + "$Header: src/compiler/ppc/c-call.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the VOPs and other necessary machine specific support +;;; routines for call-out to C. +;;; +;;; Written by William Lott. +;;; +(in-package "PPC") + + +(export '(make-callback-trampoline callback-accessor-form + compatible-function-types-p)) + +(defun callback-accessor-form (type sp offset) + (let ((parsed-type (alien::parse-alien-type type))) + (typecase parsed-type + (alien::integer-64$ + ;; Get both words of a 64-bit integer and combine together, in + ;; a big-endian fashion. + `(let ((hi (alien:deref (sap-alien (sys:sap+ ,sp ,offset) + ,(if (alien-integer-type-signed parsed-type) + '(* c-call:int) + '(* c-call:unsigned-int))))) + (lo (alien:deref (sap-alien (sys:sap+ ,sp + (+ ,offset vm:word-bytes)) + (* c-call:unsigned-int))))) + (+ (ash hi vm:word-bits) lo))) + (alien::integer$ + ;; We can access machine integers directly, but we need to get + ;; the offset right, since the offset we're given is the start + ;; of the object, and we're a big-endian machine. + (let ((byte-offset + (- vm:word-bytes + (ceiling (alien::alien-integer-type-bits parsed-type) + vm:byte-bits)))) + `(deref (sap-alien (sys:sap+ ,sp ,(+ byte-offset offset)) + (* ,type))))) + (t + ;; This should work for everything else. + `(deref (sap-alien (sys:sap+ ,sp ,offset) + (* ,type))))))) + +(defun compatible-function-types-p (fun-type1 fun-type2) + (labels ((type-words (type) + (ceiling (alien-type-bits type) vm:word-bits)) + (compatible-type-p (type1 type2) + (let ((float1 (alien-float-type-p type1)) + (float2 (alien-float-type-p type2))) + (and (if float1 + float2 + (not float2)) + (= (type-words type1) (type-words type2)))))) + (let ((args1 (alien-function-type-arg-types fun-type1)) + (args2 (alien-function-type-arg-types fun-type2)) + (ret1 (alien-function-type-result-type fun-type1)) + (ret2 (alien-function-type-result-type fun-type2))) + (and (= (length args1) (length args2)) + (every #'compatible-type-p args1 args2) + (compatible-type-p ret1 ret2))))) + +(defun make-callback-trampoline (index fn-type) + (let ((return-type (alien-function-type-result-type fn-type)) + (arg-types (alien::alien-function-type-arg-types fn-type))) + (make-callback-trampoline-segment index arg-types return-type))) + +(defun make-callback-trampoline-segment (index argument-types return-type) + "Return an sb-assem:segment which calls call-callback with INDEX and +a pointer to the arguments." + (declare (type (unsigned-byte 16) index) + (optimize (debug 3))) + (flet ((make-gpr (n) + (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n)) + (make-fpr (n) + (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) + :offset n)) + (round-up-16 (n) + ;; Round up to a multiple of 16. Darwin wants that for the + ;; stack pointer. + (* 16 (ceiling n 16)))) + + ;; The "Mach-O Runtime Conventions" document for OS X almost specifies + ;; the calling convention (it neglects to mention that the linkage area + ;; is 24 bytes). + (let* ((segment (make-segment)) + (save-gprs (mapcar #'make-gpr '(13 24))) + + (argument-words + (mapcar (lambda (arg) (ceiling (alien-type-bits arg) vm:word-bits)) + argument-types)) + (linkage-area-size 24)) + (assemble (segment) + + (let ((sp (make-gpr 1))) + + ;; To save our arguments, we follow the algorithm sketched in the + ;; "PowerPC Calling Conventions" section of that document. + (let ((words-processed 0) + (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10))) + (fprs (mapcar #'make-fpr '(1 2 3 4 5 6 7 8 9 10 11 12 13)))) + (flet ((handle-arg (type words) + (let ((integerp (not (alien-float-type-p type))) + (offset (+ (* words-processed vm:word-bytes) + linkage-area-size))) + (cond + (integerp + (dotimes (k words) + (let ((gpr (pop gprs))) + (when gpr + (inst stw gpr sp offset) + (incf words-processed) + (incf offset vm:word-bytes))))) + ;; The handling of floats is a little ugly because we + ;; hard-code the number of words for single- and + ;; double-floats. + ((alien-single-float-type-p type) + (pop gprs) + (let ((fpr (pop fprs))) + (inst stfs fpr sp offset)) + (incf words-processed)) + ((alien-double-float-type-p type) + (setf gprs (cddr gprs)) + (let ((fpr (pop fprs))) + (inst stfd fpr sp offset)) + (incf words-processed 2)))))) + (mapc #'handle-arg argument-types argument-words))) + + ;; The args have been saved to memory. + ;; + ;; The stack frame is something like this: + ;; + ;; stack arg n + ;; ... + ;; stack arg 1 + ;; stack arg 0 + ;; save arg 7 + ;; save arg 6 + ;; save arg 5 + ;; save arg 4 + ;; save arg 3 + ;; save arg 2 + ;; save arg 1 + ;; save arg 0 + ;; 24 bytes for linkage area + ;; -> sp points to the bottom of the linkage area + ;; + ;; Set aside space for our stack frame. We need enough room + ;; for the callback return area, some space to save the + ;; non-volatile (callee-saved) registers, space to save the + ;; args for the function we're calling, and the linkage + ;; area. The space is rounded up to a multiple of 16 bytes + ;; because the stack should be aligned to a multiple of 16 + ;; bytes. + ;; + ;; Our stack frame will look something like this now: + ;; + ;; Offset Value + ;; 64 Caller's frame (see above) + ;; 56/60 return area (1 or 2 words) + ;; 48 filler (unused) + ;; 44 save r24 + ;; 40 save r13 + ;; 36 save arg 3 + ;; 32 save arg 2 + ;; 28 save arg 1 + ;; 24 save arg 0 + ;; 0 linkage area (24 bytes) + ;; + ;; + ;; The return area is allocated at the top of the frame. + ;; When we call funcall3, the linkage table entry is used, + ;; which unconditionally uses r13 and r24. (See + ;; lisp/ppc-arch.c.) So these need to be saved. funcall3, + ;; which calls call_into_lisp, will take care of saving all + ;; the remaining registers that could be used. + + ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to + ;; be because they're word-aligned. Kinda gross, but + ;; hey.... + + (let* ((return-area-words (ceiling (or (alien-type-bits return-type) + 0) + vm:word-bits)) + (save-words (length save-gprs)) + (args-size (* 4 vm:word-bytes)) + (frame-size + (round-up-16 (+ linkage-area-size + (* return-area-words vm:word-bytes) + (* save-words vm:word-bytes) + args-size)))) + (destructuring-bind (r0 arg1 arg2 arg3 arg4) + (mapcar #'make-gpr '(0 3 4 5 6)) + ;; Setup the args for the call. We call + ;; funcall3(call-callback, index, arg-pointer, + ;; return-area-address) + (inst lr arg1 (alien::address-of-call-callback)) + (inst li arg2 (fixnumize index)) + (inst addi arg3 sp linkage-area-size) + (inst addi arg4 sp (- (* return-area-words vm:word-bytes))) + + ;; Save sp, setup the frame + (inst mflr r0) + (inst stw r0 sp (* 2 vm:word-bytes)) + (inst stwu sp sp (- frame-size)) + + ;; Save the caller-saved registers that the linkage + ;; table trampoline clobbers. + (let ((save-offset (+ linkage-area-size args-size))) + (dolist (r save-gprs) + (inst stw r sp save-offset) + (incf save-offset vm:word-bytes))) + + ;; Make the call + (inst lr r0 (alien::address-of-funcall3)) + (inst mtlr r0) + (inst blrl) + + (let ((return-offset (- frame-size + (* return-area-words vm:word-bytes)))) + (etypecase return-type + ((or alien::integer$ alien::pointer$ alien::sap$ + alien::integer-64$) + (loop repeat return-area-words + with gprs = (mapcar #'make-gpr '(3 4)) + for gpr = (pop gprs) + for offset from return-offset by vm:word-bytes + do (inst lwz gpr sp offset))) + (alien::single$ + ;; Get the FP value into F1 + (let ((f1 (make-fpr 1))) + (inst lfs f1 sp return-offset))) + (alien::double$ + ;; Get the FP value into F1 + (let ((f1 (make-fpr 1))) + (inst lfd f1 sp return-offset))) + (alien::void$ + ;; Nothing to do + ))) + + ;; Restore the GPRS we saved. + (let ((save-offset (+ linkage-area-size args-size))) + (dolist (r save-gprs) + (inst lwz r sp save-offset) + (incf save-offset vm:word-bytes))) + + ;; All done. Restore sp and lr and return. + (inst lwz r0 sp (+ frame-size (* 2 vm:word-bytes))) + (inst mtlr r0) + (inst addic sp sp frame-size) + + ;; And back we go! + (inst blr))))) + + (let ((length (finalize-segment segment))) + (prog1 (alien::segment-to-trampoline segment length) + (release-segment segment)))))) diff --git a/src/compiler/sparc/c-call.lisp b/src/compiler/sparc/c-call.lisp index 042854e..c3a18be 100644 --- a/src/compiler/sparc/c-call.lisp +++ b/src/compiler/sparc/c-call.lisp @@ -312,205 +312,3 @@ (t (inst li temp delta) (inst add nsp-tn temp))))))) - -;;; Support for callbacks to Lisp. -(export '(make-callback-trampoline callback-accessor-form - compatible-function-types-p)) - -(defun callback-accessor-form (type sp offset) - (let ((parsed-type (alien::parse-alien-type type))) - (typecase parsed-type - (alien::double$ - ;; Due to sparc calling conventions, a double arg doesn't have to - ;; be aligned on a double word boundary. We have to get the two - ;; words separately and create the double from them. Doubles are - ;; stored in big-endian order, naturally. - `(kernel:make-double-float - (alien:deref (sap-alien (sys:sap+ ,sp ,offset) (* c-call:int))) - (alien:deref (sap-alien (sys:sap+ ,sp (+ ,offset vm:word-bytes)) - (* c-call:unsigned-int))))) - (alien::integer-64$ - ;; Same as for double, above - `(let ((hi (alien:deref (sap-alien (sys:sap+ ,sp ,offset) - ,(if (alien-integer-type-signed parsed-type) - '(* c-call:int) - '(* c-call:unsigned-int))))) - (lo (alien:deref (sap-alien (sys:sap+ ,sp - (+ ,offset vm:word-bytes)) - (* c-call:unsigned-int))))) - (+ (ash hi vm:word-bits) lo))) - (alien::integer$ - ;; All other objects can be accessed directly. But we need to - ;; get the offset right, since the offset we're given is the - ;; start of the object, and we're a big-endian machine. - (let ((byte-offset - (- vm:word-bytes - (ceiling (alien::alien-integer-type-bits parsed-type) - vm:byte-bits)))) - `(deref (sap-alien (sys:sap+ ,sp ,(+ byte-offset offset)) - (* ,type))))) - (t - `(deref (sap-alien (sys:sap+ ,sp ,offset) - (* ,type))))))) - -(defun compatible-function-types-p (type1 type2) - (flet ((machine-rep (type) - (etypecase type - (alien::integer-64$ :dword) - ((or alien::integer$ alien::pointer$ alien::sap$) :word) - (alien::single$ :single) - (alien::double$ :double) - (alien::void$ :void)))) - (let ((type1 (alien-function-type-result-type type1)) - (type2 (alien-function-type-result-type type2))) - (eq (machine-rep type1) (machine-rep type2))))) - -(defun make-callback-trampoline (index fn-type) - "Cons up a piece of code which calls call-callback with INDEX and a -pointer to the arguments." - (let ((return-type (alien-function-type-result-type fn-type))) - (flet ((def-reg-tn (offset) - (c:make-random-tn :kind :normal - :sc (c:sc-or-lose 'vm::unsigned-reg) - :offset offset))) - (let* ((segment (make-segment)) - ;; Window save area (16 registers) - (window-save-size (* 16 vm:word-bytes)) - ;; Structure return pointer area (1 register) - (struct-return-size vm:word-bytes) - ;; Register save area (6 registers) - (reg-save-area-size (* 6 vm:word-bytes)) - ;; Local var. Should be large enough to hold a double-float or long - (return-value-size (* 2 vm:word-bytes)) - ;; Frame size: the register window, the arg save area, the - ;; structure return area, and return-value-area, all - ;; rounded to a multiple of eight. - (framesize (* 8 (ceiling (+ window-save-size struct-return-size - reg-save-area-size - return-value-size) - 8))) - ;; Offset from FP where the first arg is located. - (arg0-save-offset (+ window-save-size struct-return-size)) - ;; Establish the registers we need - (%g0 (def-reg-tn vm::zero-offset)) - (%o0 (def-reg-tn vm::nl0-offset)) - (%o1 (def-reg-tn vm::nl1-offset)) - (%o2 (def-reg-tn vm::nl2-offset)) - (%o3 (def-reg-tn vm::nl3-offset)) - (%o7 (def-reg-tn vm::nargs-offset)) - (%sp (def-reg-tn vm::nsp-offset)) ; aka %o6 - (%l0 (def-reg-tn vm::a0-offset)) - (%i0 (def-reg-tn vm::cname-offset)) - (%i1 (def-reg-tn vm::lexenv-offset)) - (%i2 (def-reg-tn 26)) - (%i3 (def-reg-tn vm::nfp-offset)) - (%i4 (def-reg-tn vm::cfunc-offset)) - (%i5 (def-reg-tn vm::code-offset)) - (%fp (def-reg-tn 30)) - (%i7 (def-reg-tn vm::lip-offset)) - (f0-s (c:make-random-tn :kind :normal - :sc (c:sc-or-lose 'vm::single-reg) - :offset 0)) - (f0-d (c:make-random-tn :kind :normal - :sc (c:sc-or-lose 'vm::double-reg) - :offset 0)) - ) - ;; The generated assembly roughly corresponds to this C code: - ;; - ;; tramp(int a0, int a1, int a2, int a3, int a4, int a5, ...) - ;; { - ;; double result; - ;; funcall3(call-callback, <index>, &a0, &result); - ;; return <cast> result; - ;; } - ;; - ;; Except, of course, the result is the appropriate result type - ;; for the trampoline. - ;; - (assemble (segment) - ;; Save old %fp, etc. establish our call frame with local vars - ;; %i contains the input args - (inst save %sp %sp (- framesize)) - ;; The stack frame now looks like - ;; - ;; TOP (high memory) - ;; - ;; argn - ;; ... - ;; arg6 - ;; arg5 - ;; arg4 - ;; arg3 - ;; arg2 - ;; arg1 - ;; arg0 - ;; struct_return - ;; window-save-area <- %fp + 64 - ;; <- %fp - ;; local-vars-extra-args (8-bytes) - ;; arg5-save - ;; arg4-save - ;; arg3-save - ;; arg2-save - ;; arg1-save - ;; arg0-save - ;; struct_return - ;; window-save-area - ;; <- %sp - - ;; Save all %i arg register values on the stack. (We - ;; might not always need to save all, but this is safe - ;; and easy.) - (inst st %i0 %fp (+ arg0-save-offset (* 0 vm:word-bytes))) - (inst st %i1 %fp (+ arg0-save-offset (* 1 vm:word-bytes))) - (inst st %i2 %fp (+ arg0-save-offset (* 2 vm:word-bytes))) - (inst st %i3 %fp (+ arg0-save-offset (* 3 vm:word-bytes))) - (inst st %i4 %fp (+ arg0-save-offset (* 4 vm:word-bytes))) - (inst st %i5 %fp (+ arg0-save-offset (* 5 vm:word-bytes))) - - ;; Set up our args to call funcall3 - ;; - ;; %o0 = address of call-callback - ;; %o1 = index - ;; %o2 = pointer to the arguments of the caller (address - ;; of arg0 above) - ;; %o3 = pointer to return area - - (inst li %o0 (alien::address-of-call-callback)) - (inst li %o1 (ash index vm:fixnum-tag-bits)) - (inst add %o2 %fp arg0-save-offset) - (inst add %o3 %fp (- return-value-size)) - - ;; And away we go to funcall3! - (let ((addr (alien::address-of-funcall3))) - (inst sethi %l0 (ldb (byte 22 10) addr)) - (inst jal %o7 %l0 (ldb (byte 10 0) addr)) - (inst nop)) - - ;; Ok, we're back. The value returned is actually - ;; stored in the return area. Need to get that into - ;; the right registers for return. - (etypecase return-type - (alien::integer-64$ - ;; A 64-bit bignum, stored big-endian - (inst ld %i0 %fp (- return-value-size)) - (inst ld %i1 %fp (- (- return-value-size vm:word-bytes)))) - ((or alien::integer$ alien::pointer$ alien::sap$) - (inst ld %i0 %fp (- return-value-size))) - (alien::single$ - ;; Get the FP value into F0 - (inst ldf f0-s %fp (- return-value-size)) - ) - (alien::double$ - (inst lddf f0-d %fp (- return-value-size))) - (alien::void$ - )) - - (inst jal %g0 %i7 8) - (inst restore %g0 %g0 %g0) - ) - (let ((length (finalize-segment segment))) - (prog1 (alien::segment-to-trampoline segment length) - (release-segment segment))))))) - - diff --git a/src/compiler/sparc/c-callback.lisp b/src/compiler/sparc/c-callback.lisp new file mode 100644 index 0000000..ac97f9c --- /dev/null +++ b/src/compiler/sparc/c-callback.lisp @@ -0,0 +1,215 @@ +;;; -*- Package: SPARC -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: src/compiler/sparc/c-call.lisp $") + +(in-package "SPARC") +(intl:textdomain "cmucl-sparc-vm") +(use-package "ALIEN") +(use-package "ALIEN-INTERNALS") + +;;; Support for callbacks to Lisp. +(export '(make-callback-trampoline callback-accessor-form + compatible-function-types-p)) + +(defun callback-accessor-form (type sp offset) + (let ((parsed-type (alien::parse-alien-type type))) + (typecase parsed-type + (alien::double$ + ;; Due to sparc calling conventions, a double arg doesn't have to + ;; be aligned on a double word boundary. We have to get the two + ;; words separately and create the double from them. Doubles are + ;; stored in big-endian order, naturally. + `(kernel:make-double-float + (alien:deref (sap-alien (sys:sap+ ,sp ,offset) (* c-call:int))) + (alien:deref (sap-alien (sys:sap+ ,sp (+ ,offset vm:word-bytes)) + (* c-call:unsigned-int))))) + (alien::integer-64$ + ;; Same as for double, above + `(let ((hi (alien:deref (sap-alien (sys:sap+ ,sp ,offset) + ,(if (alien-integer-type-signed parsed-type) + '(* c-call:int) + '(* c-call:unsigned-int))))) + (lo (alien:deref (sap-alien (sys:sap+ ,sp + (+ ,offset vm:word-bytes)) + (* c-call:unsigned-int))))) + (+ (ash hi vm:word-bits) lo))) + (alien::integer$ + ;; All other objects can be accessed directly. But we need to + ;; get the offset right, since the offset we're given is the + ;; start of the object, and we're a big-endian machine. + (let ((byte-offset + (- vm:word-bytes + (ceiling (alien::alien-integer-type-bits parsed-type) + vm:byte-bits)))) + `(deref (sap-alien (sys:sap+ ,sp ,(+ byte-offset offset)) + (* ,type))))) + (t + `(deref (sap-alien (sys:sap+ ,sp ,offset) + (* ,type))))))) + +(defun compatible-function-types-p (type1 type2) + (flet ((machine-rep (type) + (etypecase type + (alien::integer-64$ :dword) + ((or alien::integer$ alien::pointer$ alien::sap$) :word) + (alien::single$ :single) + (alien::double$ :double) + (alien::void$ :void)))) + (let ((type1 (alien-function-type-result-type type1)) + (type2 (alien-function-type-result-type type2))) + (eq (machine-rep type1) (machine-rep type2))))) + +(defun make-callback-trampoline (index fn-type) + "Cons up a piece of code which calls call-callback with INDEX and a +pointer to the arguments." + (let ((return-type (alien-function-type-result-type fn-type))) + (flet ((def-reg-tn (offset) + (c:make-random-tn :kind :normal + :sc (c:sc-or-lose 'vm::unsigned-reg) + :offset offset))) + (let* ((segment (make-segment)) + ;; Window save area (16 registers) + (window-save-size (* 16 vm:word-bytes)) + ;; Structure return pointer area (1 register) + (struct-return-size vm:word-bytes) + ;; Register save area (6 registers) + (reg-save-area-size (* 6 vm:word-bytes)) + ;; Local var. Should be large enough to hold a double-float or long + (return-value-size (* 2 vm:word-bytes)) + ;; Frame size: the register window, the arg save area, the + ;; structure return area, and return-value-area, all + ;; rounded to a multiple of eight. + (framesize (* 8 (ceiling (+ window-save-size struct-return-size + reg-save-area-size + return-value-size) + 8))) + ;; Offset from FP where the first arg is located. + (arg0-save-offset (+ window-save-size struct-return-size)) + ;; Establish the registers we need + (%g0 (def-reg-tn vm::zero-offset)) + (%o0 (def-reg-tn vm::nl0-offset)) + (%o1 (def-reg-tn vm::nl1-offset)) + (%o2 (def-reg-tn vm::nl2-offset)) + (%o3 (def-reg-tn vm::nl3-offset)) + (%o7 (def-reg-tn vm::nargs-offset)) + (%sp (def-reg-tn vm::nsp-offset)) ; aka %o6 + (%l0 (def-reg-tn vm::a0-offset)) + (%i0 (def-reg-tn vm::cname-offset)) + (%i1 (def-reg-tn vm::lexenv-offset)) + (%i2 (def-reg-tn 26)) + (%i3 (def-reg-tn vm::nfp-offset)) + (%i4 (def-reg-tn vm::cfunc-offset)) + (%i5 (def-reg-tn vm::code-offset)) + (%fp (def-reg-tn 30)) + (%i7 (def-reg-tn vm::lip-offset)) + (f0-s (c:make-random-tn :kind :normal + :sc (c:sc-or-lose 'vm::single-reg) + :offset 0)) + (f0-d (c:make-random-tn :kind :normal + :sc (c:sc-or-lose 'vm::double-reg) + :offset 0)) + ) + ;; The generated assembly roughly corresponds to this C code: + ;; + ;; tramp(int a0, int a1, int a2, int a3, int a4, int a5, ...) + ;; { + ;; double result; + ;; funcall3(call-callback, <index>, &a0, &result); + ;; return <cast> result; + ;; } + ;; + ;; Except, of course, the result is the appropriate result type + ;; for the trampoline. + ;; + (assemble (segment) + ;; Save old %fp, etc. establish our call frame with local vars + ;; %i contains the input args + (inst save %sp %sp (- framesize)) + ;; The stack frame now looks like + ;; + ;; TOP (high memory) + ;; + ;; argn + ;; ... + ;; arg6 + ;; arg5 + ;; arg4 + ;; arg3 + ;; arg2 + ;; arg1 + ;; arg0 + ;; struct_return + ;; window-save-area <- %fp + 64 + ;; <- %fp + ;; local-vars-extra-args (8-bytes) + ;; arg5-save + ;; arg4-save + ;; arg3-save + ;; arg2-save + ;; arg1-save + ;; arg0-save + ;; struct_return + ;; window-save-area + ;; <- %sp + + ;; Save all %i arg register values on the stack. (We + ;; might not always need to save all, but this is safe + ;; and easy.) + (inst st %i0 %fp (+ arg0-save-offset (* 0 vm:word-bytes))) + (inst st %i1 %fp (+ arg0-save-offset (* 1 vm:word-bytes))) + (inst st %i2 %fp (+ arg0-save-offset (* 2 vm:word-bytes))) + (inst st %i3 %fp (+ arg0-save-offset (* 3 vm:word-bytes))) + (inst st %i4 %fp (+ arg0-save-offset (* 4 vm:word-bytes))) + (inst st %i5 %fp (+ arg0-save-offset (* 5 vm:word-bytes))) + + ;; Set up our args to call funcall3 + ;; + ;; %o0 = address of call-callback + ;; %o1 = index + ;; %o2 = pointer to the arguments of the caller (address + ;; of arg0 above) + ;; %o3 = pointer to return area + + (inst li %o0 (alien::address-of-call-callback)) + (inst li %o1 (ash index vm:fixnum-tag-bits)) + (inst add %o2 %fp arg0-save-offset) + (inst add %o3 %fp (- return-value-size)) + + ;; And away we go to funcall3! + (let ((addr (alien::address-of-funcall3))) + (inst sethi %l0 (ldb (byte 22 10) addr)) + (inst jal %o7 %l0 (ldb (byte 10 0) addr)) + (inst nop)) + + ;; Ok, we're back. The value returned is actually + ;; stored in the return area. Need to get that into + ;; the right registers for return. + (etypecase return-type + (alien::integer-64$ + ;; A 64-bit bignum, stored big-endian + (inst ld %i0 %fp (- return-value-size)) + (inst ld %i1 %fp (- (- return-value-size vm:word-bytes)))) + ((or alien::integer$ alien::pointer$ alien::sap$) + (inst ld %i0 %fp (- return-value-size))) + (alien::single$ + ;; Get the FP value into F0 + (inst ldf f0-s %fp (- return-value-size)) + ) + (alien::double$ + (inst lddf f0-d %fp (- return-value-size))) + (alien::void$ + )) + + (inst jal %g0 %i7 8) + (inst restore %g0 %g0 %g0) + ) + (let ((length (finalize-segment segment))) + (prog1 (alien::segment-to-trampoline segment length) + (release-segment segment))))))) + + diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index 7efd0b9..4554a0e 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -244,68 +244,3 @@ (ash symbol-value-slot word-shift) (- other-pointer-type))) delta))))) - -;;; Support for callbacks to Lisp. -(export '(make-callback-trampoline callback-accessor-form - compatible-function-types-p)) - -(defun callback-accessor-form (type sp offset) - `(alien:deref (sap-alien - (sys:sap+ ,sp ,offset) - (* ,type)))) - -(defun compatible-function-types-p (type1 type2) - (flet ((machine-rep (type) - (etypecase type - (alien::integer-64$ :dword) - ((or alien::integer$ alien::pointer$ alien::sap$) :word) - (alien::single$ :single) - (alien::double$ :double) - (alien::void$ :void)))) - (let ((type1 (alien-function-type-result-type type1)) - (type2 (alien-function-type-result-type type2))) - (eq (machine-rep type1) (machine-rep type2))))) - -(defun make-callback-trampoline (index fn-type) - "Cons up a piece of code which calls call-callback with INDEX and a -pointer to the arguments." - (let* ((return-type (alien-function-type-result-type fn-type)) - (segment (make-segment)) - (eax x86::eax-tn) - (edx x86::edx-tn) - (ebp x86::ebp-tn) - (esp x86::esp-tn) - ([ebp-8] (x86::make-ea :dword :base ebp :disp -8)) - ([ebp-4] (x86::make-ea :dword :base ebp :disp -4))) - (assemble (segment) - (inst push ebp) ; save old frame pointer - (inst mov ebp esp) ; establish new frame - (inst mov eax esp) ; - (inst sub eax 8) ; place for result - (inst push eax) ; arg2 - (inst add eax 16) ; arguments - (inst push eax) ; arg1 - (inst push (ash index 2)) ; arg0 - (inst push (alien::address-of-call-callback)) ; function - (inst mov eax (alien::address-of-funcall3)) - (inst call eax) - ;; now put the result into the right register - (etypecase return-type - (alien::integer-64$ - (inst mov eax [ebp-8]) - (inst mov edx [ebp-4])) - ((or alien::integer$ alien::pointer$ alien::sap$) - (inst mov eax [ebp-8])) - (alien::single$ - (inst fld [ebp-8])) - (alien::double$ - (inst fldd [ebp-8])) - (alien::void$ )) - (inst mov esp ebp) ; discard frame - (inst pop ebp) ; restore frame pointer - (inst ret)) - (let* ((length (finalize-segment segment))) - (prog1 (alien::segment-to-trampoline segment length) - (release-segment segment))))) - - diff --git a/src/compiler/x86/c-callback.lisp b/src/compiler/x86/c-callback.lisp new file mode 100644 index 0000000..b9e27fc --- /dev/null +++ b/src/compiler/x86/c-callback.lisp @@ -0,0 +1,80 @@ +;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group(a)cs.cmu.edu. +;;; +(ext:file-comment + "$Header: src/compiler/x86/c-call.lisp $") + +(in-package :x86) +(use-package :alien) +(use-package :alien-internals) +(intl:textdomain "cmucl-x86-vm") + +;;; Support for callbacks to Lisp. +(export '(make-callback-trampoline callback-accessor-form + compatible-function-types-p)) + +(defun callback-accessor-form (type sp offset) + `(alien:deref (sap-alien + (sys:sap+ ,sp ,offset) + (* ,type)))) + +(defun compatible-function-types-p (type1 type2) + (flet ((machine-rep (type) + (etypecase type + (alien::integer-64$ :dword) + ((or alien::integer$ alien::pointer$ alien::sap$) :word) + (alien::single$ :single) + (alien::double$ :double) + (alien::void$ :void)))) + (let ((type1 (alien-function-type-result-type type1)) + (type2 (alien-function-type-result-type type2))) + (eq (machine-rep type1) (machine-rep type2))))) + +(defun make-callback-trampoline (index fn-type) + "Cons up a piece of code which calls call-callback with INDEX and a +pointer to the arguments." + (let* ((return-type (alien-function-type-result-type fn-type)) + (segment (make-segment)) + (eax x86::eax-tn) + (edx x86::edx-tn) + (ebp x86::ebp-tn) + (esp x86::esp-tn) + ([ebp-8] (x86::make-ea :dword :base ebp :disp -8)) + ([ebp-4] (x86::make-ea :dword :base ebp :disp -4))) + (assemble (segment) + (inst push ebp) ; save old frame pointer + (inst mov ebp esp) ; establish new frame + (inst mov eax esp) ; + (inst sub eax 8) ; place for result + (inst push eax) ; arg2 + (inst add eax 16) ; arguments + (inst push eax) ; arg1 + (inst push (ash index 2)) ; arg0 + (inst push (alien::address-of-call-callback)) ; function + (inst mov eax (alien::address-of-funcall3)) + (inst call eax) + ;; now put the result into the right register + (etypecase return-type + (alien::integer-64$ + (inst mov eax [ebp-8]) + (inst mov edx [ebp-4])) + ((or alien::integer$ alien::pointer$ alien::sap$) + (inst mov eax [ebp-8])) + (alien::single$ + (inst fld [ebp-8])) + (alien::double$ + (inst fldd [ebp-8])) + (alien::void$ )) + (inst mov esp ebp) ; discard frame + (inst pop ebp) ; restore frame pointer + (inst ret)) + (let* ((length (finalize-segment segment))) + (prog1 (alien::segment-to-trampoline segment length) + (release-segment segment))))) + + diff --git a/src/tools/comcom.lisp b/src/tools/comcom.lisp index a968506..0953dc0 100644 --- a/src/tools/comcom.lisp +++ b/src/tools/comcom.lisp @@ -197,6 +197,7 @@ (vmdir "target:compiler/sse2-c-call") (vmdir "target:compiler/x87-c-call")) :byte-compile *byte-compile*)) +(comf (vmdir "target:compiler/c-callback")) (comf (vmdir "target:compiler/cell")) (comf (vmdir "target:compiler/values") :byte-compile *byte-compile*) (comf (vmdir "target:compiler/alloc")) diff --git a/src/tools/worldcom.lisp b/src/tools/worldcom.lisp index fac9428..9a74818 100644 --- a/src/tools/worldcom.lisp +++ b/src/tools/worldcom.lisp @@ -138,6 +138,7 @@ (setf (fdefinition 'lisp::%deftype) *original-%deftype*) (comf "target:code/alieneval") +(comf "target:code/alien-callback") (comf "target:code/c-call") (comf "target:code/sap") commit 5d37fbf143530c391429d52fa07873e648675d86 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Dec 23 10:57:48 2012 -0800 Get rid of the unused bit-bash-<foo> symbols. diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 5a9bdaf..b127c27 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -2110,10 +2110,7 @@ "ARRAY-RANK" "ARRAY-TOTAL-SIZE" "ARRAY-TYPE" "ARRAY-TYPE-COMPLEXP" "ARRAY-TYPE-DIMENSIONS" "ARRAY-TYPE-ELEMENT-TYPE" "ARRAY-TYPE-P" "ARRAY-TYPE-SPECIALIZED-ELEMENT-TYPE" "ASH-INDEX" "BASE-CHAR-P" - "BINDING-STACK-POINTER-SAP" "BIT-BASH-AND" "BIT-BASH-ANDC1" - "BIT-BASH-ANDC2" "BIT-BASH-CLEAR" "BIT-BASH-COPY" "BIT-BASH-EQV" - "BIT-BASH-IOR" "BIT-BASH-LOGNAND" "BIT-BASH-LOGNOR" "BIT-BASH-NOT" - "BIT-BASH-ORC1" "BIT-BASH-ORC2" "BIT-BASH-SET" "BIT-BASH-XOR" "BIT-INDEX" + "BINDING-STACK-POINTER-SAP" "BIT-BASH-COPY" "BIT-INDEX" "BYTE-BASH-COPY" "BOGUS-ARGUMENT-TO-VALUES-LIST-ERROR" "BOOLE-CODE" "BOOLEAN" "BYTE-SPECIFIER" "CALLABLE" "CHAR-INT" commit 0df4a14d0f2e83c6b6fdd9a5fd2b7cb024100660 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Dec 23 10:56:50 2012 -0800 Use BYTE-BASH-COPY in the string transforms for SUBSEQ and COPY-SEQ. diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index aa8cd4f..f8ecf24 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -218,25 +218,25 @@ (size (- end start)) (result (make-string size))) (declare (optimize (safety 0))) - (bit-bash-copy string - (the index - (+ (the index (* start vm:char-bits)) - vector-data-bit-offset)) - result - vector-data-bit-offset - (the index (* size vm:char-bits))) - result)) + (byte-bash-copy string + (the vm::offset + (+ (the vm::offset (* start vm:char-bytes)) + vector-data-byte-offset)) + result + vector-data-byte-offset + (the vm::offset (* size vm:char-bytes))) + result)) (deftransform copy-seq ((seq) (simple-string)) '(let* ((len (length seq)) (res (make-string len))) (declare (optimize (safety 0))) (bit-bash-copy seq - vector-data-bit-offset + vector-data-byte-offset res - vector-data-bit-offset - (the index (* len vm:char-bits))) - res)) + vector-data-byte-offset + (the vm::offset (* len vm:char-bytes))) + res)) (deftransform replace ((string1 string2 &key (start1 0) (start2 0) end1 end2) @@ -254,7 +254,7 @@ (locally (declare (optimize (safety 0))) - (byte-bash-copy string2 + (vm::byte-bash-copy string2 (the vm::offset (+ (the vm::offset (* start2 vm:char-bytes)) vector-data-byte-offset)) ----------------------------------------------------------------------- Summary of changes: src/code/alien-callback.lisp | 417 ++++++++++++++++++++++++++++++++++++ src/code/alieneval.lisp | 293 ------------------------- src/code/exports.lisp | 5 +- src/compiler/generic/vm-tran.lisp | 26 ++-- src/compiler/ppc/c-call.lisp | 247 --------------------- src/compiler/ppc/c-callback.lisp | 266 +++++++++++++++++++++++ src/compiler/sparc/c-call.lisp | 202 ----------------- src/compiler/sparc/c-callback.lisp | 215 +++++++++++++++++++ src/compiler/x86/c-call.lisp | 65 ------ src/compiler/x86/c-callback.lisp | 80 +++++++ src/tools/comcom.lisp | 1 + src/tools/worldcom.lisp | 1 + 12 files changed, 994 insertions(+), 824 deletions(-) create mode 100644 src/code/alien-callback.lisp create mode 100644 src/compiler/ppc/c-callback.lisp create mode 100644 src/compiler/sparc/c-callback.lisp create mode 100644 src/compiler/x86/c-callback.lisp hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-12-10-gabc4372
by Raymond Toy 23 Dec '12

23 Dec '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via abc43728326721c0862a483035ad328400eca845 (commit) via bfac8ad73346d1adf54d3aefcdca2b4a498e9315 (commit) from 3be4fc215fa2a4d23dc145e6cfa9519492525bc1 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit abc43728326721c0862a483035ad328400eca845 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Dec 23 10:38:36 2012 -0800 Fix ticket:68 by adding {{{BYTE-BASH-COPY}}} code/bit-bash.lisp:: Add {{{BYTE-BASH-COPY}}} for copying bytes code/exports.lisp:: Add {{{BYTE-BASH-COPY}}} compiler/generic/vm-fndb.lisp:: Add {{{BYTE-BASH-COPY}}} compiler/generic/vm-tran.lisp:: Call {{{BYTE-BASH-COPY}}} in the deftransform for {{{REPLACE}}}. diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index 459925a..8f94a97 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -27,6 +27,9 @@ (defconstant unit-bits vm:word-bits "The number of bits to process at a time.") +(defconstant unit-bytes vm:word-bytes + "The number of bytes to process at a time.") + (defconstant max-bits (1- (ash 1 vm:word-bits)) "The maximum number of bits that can be dealt with during a single call.") @@ -40,6 +43,9 @@ (deftype bit-offset () `(integer 0 (,unit-bits))) +(deftype byte-offset () + `(integer 0 (,unit-bytes))) + (deftype bit-count () `(integer 1 (,unit-bits))) @@ -487,6 +493,280 @@ (do-unary-bit-bash src src-offset dst dst-offset length #'%raw-bits #'%set-raw-bits #'%raw-bits))) +(defun do-unary-byte-bash (src src-offset dst dst-offset length + dst-ref-fn dst-set-fn src-ref-fn) + (declare (type offset src-offset dst-offset length) + (type function dst-ref-fn dst-set-fn src-ref-fn)) + (multiple-value-bind (dst-word-offset dst-byte-offset) + (floor dst-offset unit-bytes) + (declare (type word-offset dst-word-offset) + (type byte-offset dst-byte-offset)) + (multiple-value-bind (src-word-offset src-byte-offset) + (floor src-offset unit-bytes) + (declare (type word-offset src-word-offset) + (type byte-offset src-byte-offset)) + (cond + ((<= (+ dst-byte-offset length) unit-bytes) + #+nil(format t "case 1, one word~%") + ;; We are only writing one word, so it doesn't matter what order + ;; we do it in. But we might be reading from multiple words, so take + ;; care. + (cond + ((zerop length) + #+nil(format t "case 1a: 0 length~%") + ;; Actually, we aren't even writing one word. This is real easy. + ) + ((= length unit-bytes) + #+nil(format t "case 1b~%") + ;; dst-byte-offset must be equal to zero, or we would be writing + ;; multiple words. If src-byte-offset is also zero, then we + ;; just transfer the single word. Otherwise we have to extract bits + ;; from two src words. + (funcall dst-set-fn dst dst-word-offset + (if (zerop src-byte-offset) + (funcall src-ref-fn src src-word-offset) + (32bit-logical-or + (shift-towards-start + (funcall src-ref-fn src src-word-offset) + (* vm:byte-bits src-byte-offset)) + (shift-towards-end + (funcall src-ref-fn src (1+ src-word-offset)) + (* vm:byte-bits (- src-byte-offset))))))) + (t + #+nil(format t "case 1c~%") + ;; We are only writing some portion of the dst word, so we need to + ;; preserve the extra bits. Also, we still don't know if we need + ;; one or two source words. + (let ((mask (shift-towards-end (start-mask (* vm:byte-bits length)) + (* vm:byte-bits dst-byte-offset))) + (orig (funcall dst-ref-fn dst dst-word-offset)) + (value + (if (> src-byte-offset dst-byte-offset) + ;; The source starts further into the word than does + ;; the dst, so the source could extend into the next + ;; word. If it does, we have to merge the two words, + ;; and if not, we can just shift the first word. + (let ((src-bit-shift (* vm:byte-bits (- src-byte-offset dst-byte-offset)))) + (if (> (+ src-byte-offset length) unit-bytes) + (32bit-logical-or + (shift-towards-start + (funcall src-ref-fn src src-word-offset) + src-bit-shift) + (shift-towards-end + (funcall src-ref-fn src (1+ src-word-offset)) + (- src-bit-shift))) + (shift-towards-start + (funcall src-ref-fn src src-word-offset) + src-bit-shift))) + ;; The dst starts further into the word than does the + ;; source, so we know the source can't extend into + ;; a second word (or else the dst would too, and we + ;; wouldn't be in this branch). + (shift-towards-end + (funcall src-ref-fn src src-word-offset) + (* vm:byte-bits (- dst-byte-offset src-byte-offset)))))) + (declare (type unit mask orig value)) + ;; Replace the dst word. + (funcall dst-set-fn dst dst-word-offset + (32bit-logical-or + (32bit-logical-and value mask) + (32bit-logical-andc2 orig mask))))))) + ((= src-byte-offset dst-byte-offset) + #+nil(format t "case 2, aligned~%") + ;; The source and dst are aligned, so we don't need to shift + ;; anything. But we have to pick the direction of the loop + ;; in case the source and dst are really the same thing. + (multiple-value-bind (words final-bytes) + (floor (+ dst-byte-offset length) unit-bytes) + (declare (type word-offset words) (type byte-offset final-bytes)) + (let ((interior (floor (- length final-bytes) unit-bytes))) + (declare (type word-offset interior)) + (cond + ((<= dst-offset src-offset) + #+nil(format t " case 2a: L-R~%") + ;; We need to loop from left to right + (unless (zerop dst-byte-offset) + #+nil(format t " case 2a1: dst-byte-offset = ~D~%" dst-byte-offset) + ;; We are only writing part of the first word, so mask off the + ;; bits we want to preserve. + (let ((mask (end-mask (- dst-byte-offset))) + (orig (funcall dst-ref-fn dst dst-word-offset)) + (value (funcall src-ref-fn src src-word-offset))) + (declare (type unit mask orig value)) + (funcall dst-set-fn dst dst-word-offset + (32bit-logical-or (32bit-logical-and value mask) + (32bit-logical-andc2 orig mask)))) + (incf src-word-offset) + (incf dst-word-offset)) + ;; Just copy the interior words. + (dotimes (i interior) + (funcall dst-set-fn dst dst-word-offset + (funcall src-ref-fn src src-word-offset)) + (incf src-word-offset) + (incf dst-word-offset)) + (unless (zerop final-bytes) + #+nil(format t " case 2a2: final-bytes = ~D~%" final-bytes) + ;; We are only writing part of the last word. + (let ((mask (start-mask (* vm:byte-bits final-bytes))) + (orig (funcall dst-ref-fn dst dst-word-offset)) + (value (funcall src-ref-fn src src-word-offset))) + (declare (type unit mask orig value)) + (funcall dst-set-fn dst dst-word-offset + (32bit-logical-or + (32bit-logical-and value mask) + (32bit-logical-andc2 orig mask)))))) + (t + #+nil(format t " case 2b: R-L~%") + ;; We need to loop from right to left. + (incf dst-word-offset words) + (incf src-word-offset words) + (unless (zerop final-bytes) + #+nil(format t " case 2b1: R-L final-bytes = ~D~%" final-bytes) + (let ((mask (start-mask (* vm:byte-bits final-bytes))) + (orig (funcall dst-ref-fn dst dst-word-offset)) + (value (funcall src-ref-fn src src-word-offset))) + (declare (type unit mask orig value)) + (funcall dst-set-fn dst dst-word-offset + (32bit-logical-or + (32bit-logical-and value mask) + (32bit-logical-andc2 orig mask))))) + (dotimes (i interior) + (decf src-word-offset) + (decf dst-word-offset) + (funcall dst-set-fn dst dst-word-offset + (funcall src-ref-fn src src-word-offset))) + (unless (zerop dst-byte-offset) + #+nil(format t " case 2b2: R-L dst-byte-offset = ~D~%" dst-byte-offset) + (decf src-word-offset) + (decf dst-word-offset) + (let ((mask (end-mask (* vm:byte-bits (- dst-byte-offset)))) + (orig (funcall dst-ref-fn dst dst-word-offset)) + (value (funcall src-ref-fn src src-word-offset))) + (declare (type unit mask orig value)) + (funcall dst-set-fn dst dst-word-offset + (32bit-logical-or + (32bit-logical-and value mask) + (32bit-logical-andc2 orig mask)))))))))) + (t + #+nil(format t "case 3, unaligned~%") + ;; They aren't aligned. + (multiple-value-bind (words final-bytes) + (floor (+ dst-byte-offset length) unit-bytes) + (declare (type word-offset words) (type byte-offset final-bytes)) + (let ((src-shift (mod (- src-byte-offset dst-byte-offset) unit-bytes)) + (interior (floor (- length final-bytes) unit-bytes))) + (declare (type byte-offset src-shift) + (type word-offset interior)) + (cond + ((<= dst-offset src-offset) + #+nil(format t "case 3a: L-R~%") + ;; We need to loop from left to right + (let ((prev 0) + (next (funcall src-ref-fn src src-word-offset))) + (declare (type unit prev next)) + (flet ((get-next-src () + (setf prev next) + (setf next (funcall src-ref-fn src + (incf src-word-offset))))) + (declare (inline get-next-src)) + (unless (zerop dst-byte-offset) + (when (> src-byte-offset dst-byte-offset) + (get-next-src)) + (let ((mask (end-mask (* vm:byte-bits (- dst-byte-offset)))) + (orig (funcall dst-ref-fn dst dst-word-offset)) + (value (32bit-logical-or + (shift-towards-start prev (* vm:byte-bits src-shift)) + (shift-towards-end next (* vm:byte-bits (- src-shift)))))) + (declare (type unit mask orig value)) + (funcall dst-set-fn dst dst-word-offset + (32bit-logical-or + (32bit-logical-and value mask) + (32bit-logical-andc2 orig mask))) + (incf dst-word-offset))) + (dotimes (i interior) + (get-next-src) + (let ((value (32bit-logical-or + (shift-towards-end next (* vm:byte-bits (- src-shift))) + (shift-towards-start prev (* vm:byte-bits src-shift))))) + (declare (type unit value)) + (funcall dst-set-fn dst dst-word-offset value) + (incf dst-word-offset))) + (unless (zerop final-bytes) + (let ((value + (if (> (+ final-bytes src-shift) unit-bytes) + (progn + (get-next-src) + (32bit-logical-or + (shift-towards-end next (* vm:byte-bits (- src-shift))) + (shift-towards-start prev (* vm:byte-bits src-shift)))) + (shift-towards-start next (* vm:byte-bits src-shift)))) + (mask (start-mask (* vm:byte-bits final-bytes))) + (orig (funcall dst-ref-fn dst dst-word-offset))) + (declare (type unit mask orig value)) + (funcall dst-set-fn dst dst-word-offset + (32bit-logical-or + (32bit-logical-and value mask) + (32bit-logical-andc2 orig mask)))))))) + (t + #+nil(format t "case 3b: L-R~%") + ;; We need to loop from right to left. + (incf dst-word-offset words) + (incf src-word-offset + (1- (ceiling (+ src-byte-offset length) unit-bytes))) + (let ((next 0) + (prev (funcall src-ref-fn src src-word-offset))) + (declare (type unit prev next)) + (flet ((get-next-src () + (setf next prev) + (setf prev (funcall src-ref-fn src + (decf src-word-offset))))) + (declare (inline get-next-src)) + (unless (zerop final-bytes) + (when (> final-bytes (- unit-bytes src-shift)) + (get-next-src)) + (let ((value (32bit-logical-or + (shift-towards-end next (* vm:byte-bits (- src-shift))) + (shift-towards-start prev (* vm:byte-bits src-shift)))) + (mask (start-mask (* vm:byte-bits final-bytes))) + (orig (funcall dst-ref-fn dst dst-word-offset))) + (declare (type unit mask orig value)) + (funcall dst-set-fn dst dst-word-offset + (32bit-logical-or + (32bit-logical-and value mask) + (32bit-logical-andc2 orig mask))))) + (decf dst-word-offset) + (dotimes (i interior) + (get-next-src) + (let ((value (32bit-logical-or + (shift-towards-end next (* vm:byte-bits (- src-shift))) + (shift-towards-start prev (* vm:byte-bits src-shift))))) + (declare (type unit value)) + (funcall dst-set-fn dst dst-word-offset value) + (decf dst-word-offset))) + (unless (zerop dst-byte-offset) + (if (> src-byte-offset dst-byte-offset) + (get-next-src) + (setf next prev prev 0)) + (let ((mask (end-mask (* vm:byte-bits (- dst-byte-offset)))) + (orig (funcall dst-ref-fn dst dst-word-offset)) + (value (32bit-logical-or + (shift-towards-start prev (* vm:byte-bits src-shift)) + (shift-towards-end next (* vm:byte-bits (- src-shift)))))) + (declare (type unit mask orig value)) + (funcall dst-set-fn dst dst-word-offset + (32bit-logical-or + (32bit-logical-and value mask) + (32bit-logical-andc2 orig mask))))))))))))))) + (undefined-value)) + +(defun byte-bash-copy (src src-offset dst dst-offset length) + (declare (type offset src-offset dst-offset length)) + (locally + (declare (optimize (speed 3) (safety 0)) + (inline do-unary-bit-bash)) + (do-unary-byte-bash src src-offset dst dst-offset length + #'%raw-bits #'%set-raw-bits #'%raw-bits))) + (defun system-area-copy (src src-offset dst dst-offset length) (declare (type offset src-offset dst-offset length)) (locally diff --git a/src/code/exports.lisp b/src/code/exports.lisp index a46d5bb..5a9bdaf 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -2113,8 +2113,9 @@ "BINDING-STACK-POINTER-SAP" "BIT-BASH-AND" "BIT-BASH-ANDC1" "BIT-BASH-ANDC2" "BIT-BASH-CLEAR" "BIT-BASH-COPY" "BIT-BASH-EQV" "BIT-BASH-IOR" "BIT-BASH-LOGNAND" "BIT-BASH-LOGNOR" "BIT-BASH-NOT" - "BIT-BASH-ORC1" "BIT-BASH-ORC2" "BIT-BASH-SET" "BIT-BASH-XOR" - "BIT-INDEX" "BOGUS-ARGUMENT-TO-VALUES-LIST-ERROR" "BOOLE-CODE" + "BIT-BASH-ORC1" "BIT-BASH-ORC2" "BIT-BASH-SET" "BIT-BASH-XOR" "BIT-INDEX" + "BYTE-BASH-COPY" + "BOGUS-ARGUMENT-TO-VALUES-LIST-ERROR" "BOOLE-CODE" "BOOLEAN" "BYTE-SPECIFIER" "CALLABLE" "CHAR-INT" "SEQUENCE-COUNT" "CHECK-FOR-CIRCULARITY" "CODE-COMPONENT" "CODE-COMPONENT-P" diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 80e5630..893b201 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -306,7 +306,7 @@ t ()) -(defknown bit-bash-copy +(defknown (bit-bash-copy byte-bash-copy) ((simple-unboxed-array (*)) vm::offset (simple-unboxed-array (*)) vm::offset vm::offset) t diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index a90c87f..aa8cd4f 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -208,6 +208,7 @@ ;;;; Simple string transforms: (defconstant vector-data-bit-offset (* vm:vector-data-offset vm:word-bits)) +(defconstant vector-data-byte-offset (* vm:vector-data-offset vm:word-bytes)) (deftransform subseq ((string start &optional (end nil)) (simple-string t &optional t)) @@ -253,20 +254,20 @@ (locally (declare (optimize (safety 0))) - (bit-bash-copy string2 + (byte-bash-copy string2 (the vm::offset - (+ (the vm::offset (* start2 vm:char-bits)) - vector-data-bit-offset)) + (+ (the vm::offset (* start2 vm:char-bytes)) + vector-data-byte-offset)) string1 (the vm::offset - (+ (the vm::offset (* start1 vm:char-bits)) - vector-data-bit-offset)) + (+ (the vm::offset (* start1 vm:char-bytes)) + vector-data-byte-offset)) (the vm::offset (* (min (the vm::offset (- (or end1 (length string1)) start1)) (the vm::offset (- (or end2 (length string2)) start2))) - vm:char-bits))) + vm:char-bytes))) string1))) ;; The original version of this deftransform seemed to cause the commit bfac8ad73346d1adf54d3aefcdca2b4a498e9315 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Dec 22 12:47:45 2012 -0800 Fix bitrot in interrupt_maybe_gc. diff --git a/src/lisp/interrupt.c b/src/lisp/interrupt.c index 0bbff65..f03e27e 100644 --- a/src/lisp/interrupt.c +++ b/src/lisp/interrupt.c @@ -372,26 +372,28 @@ gc_trigger_hit(HANDLER_ARGS) boolean interrupt_maybe_gc(HANDLER_ARGS) { + ucontext_t *ucontext = (ucontext_t *) context; + if (!foreign_function_call_active #ifndef INTERNAL_GC_TRIGGER - && gc_trigger_hit(signal, code, context) + && gc_trigger_hit(signal, code, ucontext) #endif ) { #ifndef INTERNAL_GC_TRIGGER clear_auto_gc_trigger(); #endif - if (arch_pseudo_atomic_atomic(context)) { + if (arch_pseudo_atomic_atomic(ucontext)) { maybe_gc_pending = TRUE; if (pending_signal == 0) { - copy_sigmask(&pending_mask, &context->uc_sigmask); - FILLBLOCKSET(&context->uc_sigmask); + copy_sigmask(&pending_mask, &ucontext->uc_sigmask); + FILLBLOCKSET(&ucontext->uc_sigmask); } - arch_set_pseudo_atomic_interrupted(context); + arch_set_pseudo_atomic_interrupted(ucontext); } else { - fake_foreign_function_call(context); + fake_foreign_function_call(ucontext); funcall0(SymbolFunction(MAYBE_GC)); - undo_fake_foreign_function_call(context); + undo_fake_foreign_function_call(ucontext); } return TRUE; ----------------------------------------------------------------------- Summary of changes: src/code/bit-bash.lisp | 280 +++++++++++++++++++++++++++++++++++++ src/code/exports.lisp | 5 +- src/compiler/generic/vm-fndb.lisp | 2 +- src/compiler/generic/vm-tran.lisp | 13 +- src/lisp/interrupt.c | 16 ++- 5 files changed, 300 insertions(+), 16 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-12-8-g3be4fc2
by Raymond Toy 22 Dec '12

22 Dec '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 3be4fc215fa2a4d23dc145e6cfa9519492525bc1 (commit) from cdf11377fbdb369d3a3810dd9bd01a8a73007255 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 3be4fc215fa2a4d23dc145e6cfa9519492525bc1 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Dec 22 12:46:45 2012 -0800 Fix ticket:67 Check that the start and end indices make sense for the given strings. This is important before we start bashing random parts of the string, potentially overwriting other objects. diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 3376163..a90c87f 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -240,22 +240,34 @@ (deftransform replace ((string1 string2 &key (start1 0) (start2 0) end1 end2) (simple-string simple-string &rest t)) - '(locally (declare (optimize (safety 0))) - (bit-bash-copy string2 - (the vm::offset - (+ (the vm::offset (* start2 vm:char-bits)) - vector-data-bit-offset)) - string1 - (the vm::offset - (+ (the vm::offset (* start1 vm:char-bits)) - vector-data-bit-offset)) - (the vm::offset - (* (min (the vm::offset (- (or end1 (length string1)) - start1)) - (the vm::offset (- (or end2 (length string2)) - start2))) - vm:char-bits))) - string1)) + '(progn + ;; Make sure the indices make sense before we go bashing bits + ;; around! + (assert (<= 0 start1)) + (assert (<= start1 (or end1 (length string1)))) + (assert (<= (or end1 (length string1)) (length string1))) + + (assert (<= 0 start2)) + (assert (<= start2 (or end2 (length string2)))) + (assert (<= (or end2 (length string2)) (length string2))) + + (locally + (declare (optimize (safety 0))) + (bit-bash-copy string2 + (the vm::offset + (+ (the vm::offset (* start2 vm:char-bits)) + vector-data-bit-offset)) + string1 + (the vm::offset + (+ (the vm::offset (* start1 vm:char-bits)) + vector-data-bit-offset)) + (the vm::offset + (* (min (the vm::offset (- (or end1 (length string1)) + start1)) + (the vm::offset (- (or end2 (length string2)) + start2))) + vm:char-bits))) + string1))) ;; The original version of this deftransform seemed to cause the ;; compiler to spend huge amounts of time deriving the type of the ----------------------------------------------------------------------- Summary of changes: src/compiler/generic/vm-tran.lisp | 44 +++++++++++++++++++++++------------- 1 files changed, 28 insertions(+), 16 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-12-7-gcdf1137
by Raymond Toy 22 Dec '12

22 Dec '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via cdf11377fbdb369d3a3810dd9bd01a8a73007255 (commit) from 683d11688c0a5c0f4a44fdc301706f14913fa5ed (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit cdf11377fbdb369d3a3810dd9bd01a8a73007255 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Dec 22 08:29:09 2012 -0800 Fix ticket:60. This fixes the immediate issue, but there are still problems with very long strings. The bit-index for such strings won't fit in an (unsigned-byte 32). vm-fndb.lisp: o Correct the defknown to have the correct arg types (vm::offset instead of index). vm-tran.lisp: o Update deftransform to use vm::offset instead of index. diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 0c726f3..80e5630 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -307,8 +307,8 @@ ()) (defknown bit-bash-copy - ((simple-unboxed-array (*)) index - (simple-unboxed-array (*)) index index) + ((simple-unboxed-array (*)) vm::offset + (simple-unboxed-array (*)) vm::offset vm::offset) t ()) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 62bf92b..3376163 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -240,22 +240,22 @@ (deftransform replace ((string1 string2 &key (start1 0) (start2 0) end1 end2) (simple-string simple-string &rest t)) - '(locally (declare (optimize (safety 0))) - (bit-bash-copy string2 - (the index - (+ (the index (* start2 vm:char-bits)) - vector-data-bit-offset)) - string1 - (the index - (+ (the index (* start1 vm:char-bits)) - vector-data-bit-offset)) - (the index - (* (min (the index (- (or end1 (length string1)) - start1)) - (the index (- (or end2 (length string2)) - start2))) - vm:char-bits))) - string1)) + '(locally (declare (optimize (safety 0))) + (bit-bash-copy string2 + (the vm::offset + (+ (the vm::offset (* start2 vm:char-bits)) + vector-data-bit-offset)) + string1 + (the vm::offset + (+ (the vm::offset (* start1 vm:char-bits)) + vector-data-bit-offset)) + (the vm::offset + (* (min (the vm::offset (- (or end1 (length string1)) + start1)) + (the vm::offset (- (or end2 (length string2)) + start2))) + vm:char-bits))) + string1)) ;; The original version of this deftransform seemed to cause the ;; compiler to spend huge amounts of time deriving the type of the ----------------------------------------------------------------------- Summary of changes: src/compiler/generic/vm-fndb.lisp | 4 ++-- src/compiler/generic/vm-tran.lisp | 32 ++++++++++++++++---------------- 2 files changed, 18 insertions(+), 18 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-12-6-g683d116
by Raymond Toy 22 Dec '12

22 Dec '12

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 683d11688c0a5c0f4a44fdc301706f14913fa5ed (commit) from 75a020cf12f776c5fee74905887e62b6cccca48e (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 683d11688c0a5c0f4a44fdc301706f14913fa5ed Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Dec 20 19:38:57 2012 -0800 Reinstate ability to compile with gcc on sparc. Config.sparc_common: o Enable ASSEM_SRC, ARCH_SRC, OS_SRC, OS_LIBS again Config.sparc_gcc: o Don't use -traditional-cpp when creating dependencies because that causes the old (varargs.h) version of va_start to be used instead of the stdard.h version we want. Config.sparc_sunc: o Remove ASSEM_SRC, ARCH_SRC, OS_SRC, OS_LINK_FLAGS, and OS_LIBS since they're in Config.sparc_common. diff --git a/src/lisp/Config.sparc_common b/src/lisp/Config.sparc_common index 027d495..3b07c14 100644 --- a/src/lisp/Config.sparc_common +++ b/src/lisp/Config.sparc_common @@ -50,11 +50,11 @@ CPPFLAGS = -I. -I$(PATH1) -DSOLARIS -DSVR4 $(CC_V8PLUS) $(LINKAGE) $(GENCGC) $(U CFLAGS = -g $(CC_V8PLUS) NM = $(PATH1)/solaris-nm -#ASSEM_SRC = sparc-assem.S -#ARCH_SRC = sparc-arch.c +ASSEM_SRC = sparc-assem.S +ARCH_SRC = sparc-arch.c DEPEND=$(CC) -#OS_SRC = solaris-os.c os-common.c undefineds.c elf.c k_rem_pio2.c +OS_SRC = solaris-os.c os-common.c undefineds.c elf.c k_rem_pio2.c OS_LINK_FLAGS= -#OS_LIBS= -lsocket -lnsl -ldl +OS_LIBS= -lsocket -lnsl -ldl EXEC_FINAL_OBJ = exec-final.o diff --git a/src/lisp/Config.sparc_gcc b/src/lisp/Config.sparc_gcc index b0d27ad..d08af18 100644 --- a/src/lisp/Config.sparc_gcc +++ b/src/lisp/Config.sparc_gcc @@ -26,5 +26,5 @@ endif CC = gcc -O -Wall CPP = gcc -E -DEPEND_FLAGS = -MM -traditional-cpp +DEPEND_FLAGS = -MM ASFLAGS = -g -traditional-cpp $(AS_V8PLUS) diff --git a/src/lisp/Config.sparc_sunc b/src/lisp/Config.sparc_sunc index acd54ed..1072f7b 100644 --- a/src/lisp/Config.sparc_sunc +++ b/src/lisp/Config.sparc_sunc @@ -20,13 +20,6 @@ CC_V8PLUS = -m32 -xarch=sparc AS_V8PLUS = -m32 -xarch=sparc endif -ASSEM_SRC = sparc-assem.S -ARCH_SRC = sparc-arch.c - -OS_SRC = solaris-os.c os-common.c undefineds.c elf.c k_rem_pio2.c -OS_LINK_FLAGS= -OS_LIBS= -lsocket -lnsl -ldl - CC = cc -xlibmieee -O CPP = cc -E DEPEND_FLAGS = -xM ----------------------------------------------------------------------- Summary of changes: src/lisp/Config.sparc_common | 8 ++++---- src/lisp/Config.sparc_gcc | 2 +- src/lisp/Config.sparc_sunc | 7 ------- 3 files changed, 5 insertions(+), 12 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0