diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/build-order.lisp-expr sbcl-0.9.14/build-order.lisp-expr --- ../sbcl-sources/sbcl-0.9.14/build-order.lisp-expr 2006-06-26 11:48:45.000000000 -0400 +++ sbcl-0.9.14/build-order.lisp-expr 2006-07-03 22:12:23.000000000 -0400 @@ -68,7 +68,7 @@ ;; use. It might be pretty tedious, though, working through any ;; transforms and translators and optimizers and so forth to make sure ;; that they can handle the change. -- WHN 19990919 - ("src/code/defsetfs") + ("src/code/defsetfs" :target-os) ("src/code/cold-init-helper-macros") @@ -96,7 +96,7 @@ ("src/code/defbangtype") ("src/code/defbangmacro") - ("src/code/defbangconstant") + ("src/code/defbangconstant" :target-os) ("src/code/primordial-extensions") @@ -174,7 +174,7 @@ ("src/compiler/early-backend") ;; "src/code/toplevel.lisp" si the first to need this. It's generated ;; automatically by grovel_headers.c, i.e. it's not in CVS. - ("output/stuff-groveled-from-headers" :not-host) + ;("output/stuff-groveled-from-headers" :not-host) ;; a comment from classic CMU CL: ;; "These guys can supposedly come in any order, but not really. @@ -215,7 +215,7 @@ ("src/code/string" :not-host) ("src/code/mipsstrops" :not-host) - ("src/code/unix" :not-host) + ;("src/code/unix" :not-host) #!+win32 ("src/code/win32" :not-host) #!+mach ("src/code/mach" :not-host) @@ -248,7 +248,7 @@ ;; FIXME: do we really want to keep this? -- CSR, 2002-08-31 #!+rt ("src/code/rt-vm" :not-host) - #!-win32 ("src/code/target-signal" :not-host) ; needs OS-CONTEXT-T from x86-vm + ;#!-win32 ("src/code/target-signal" :not-host) ; needs OS-CONTEXT-T from x86-vm #!+win32 ("src/code/target-exception" :not-host) ("src/code/symbol" :not-host) @@ -276,8 +276,8 @@ ("src/code/error-error" :not-host) ; needs WITH-STANDARD-IO-SYNTAX macro - ("src/code/serve-event" :not-host) - ("src/code/fd-stream" :not-host) + ;("src/code/serve-event" :not-host) + ;("src/code/fd-stream" :not-host) ("src/code/module" :not-host) @@ -286,8 +286,8 @@ ("src/code/query" :not-host) ("src/code/sort" :not-host) - ("src/code/time" :not-host) - ("src/code/timer" :not-host) + ;("src/code/time" :not-host) + ;("src/code/timer" :not-host) ("src/code/weak" :not-host) ("src/code/final" :not-host) @@ -471,7 +471,7 @@ #!+linkage-table ("src/code/linkage-table" :not-host) #!+(and os-provides-dlopen (not win32)) ("src/code/foreign-load" :not-host) #!+(and os-provides-dlopen win32) ("src/code/win32-foreign-load" :not-host) - ("src/code/foreign") + ;("src/code/foreign") ("src/code/fop") ; needs macros from code/load.lisp @@ -650,36 +650,36 @@ ("src/code/target-pathname" :not-host) ; needs "code/pathname" ("src/code/unix-pathname" :not-host) ("src/code/win32-pathname" :not-host) - ("src/code/filesys" :not-host) ; needs HOST from "code/pathname" + ;("src/code/filesys" :not-host) ; needs HOST from "code/pathname" - ("src/code/save" :not-host) ; uses the definition of PATHNAME + ;("src/code/save" :not-host) ; uses the definition of PATHNAME ; from "code/pathname" ("src/code/sharpm" :not-host) ; uses stuff from "code/reader" ("src/code/alloc" :not-host) - ("src/code/target-thread" :not-host) + ;("src/code/target-thread" :not-host) ;; defines SB!DI:DO-DEBUG-FUN-BLOCKS, needed by target-disassem.lisp ("src/code/gc" :not-host) ("src/code/purify" :not-host) ("src/code/debug-int" :not-host) ;; target-only assemblerish stuff - ("src/compiler/target-disassem" :not-host) + ;("src/compiler/target-disassem" :not-host) ("src/compiler/target/target-insts" :not-host) ("src/code/debug" :not-host) - ("src/code/octets" :not-host) + ;("src/code/octets" :not-host) #!+sb-unicode - ("src/code/external-formats/enc-cyr" :not-host) + ;("src/code/external-formats/enc-cyr" :not-host) #!+sb-unicode - ("src/code/external-formats/enc-dos" :not-host) + ;("src/code/external-formats/enc-dos" :not-host) #!+sb-unicode - ("src/code/external-formats/enc-iso" :not-host) + ;("src/code/external-formats/enc-iso" :not-host) #!+sb-unicode - ("src/code/external-formats/enc-win" :not-host) + ;("src/code/external-formats/enc-win" :not-host) #!+sb-unicode - ("src/code/external-formats/eucjp" :not-host) + ;("src/code/external-formats/eucjp" :not-host) ;; The code here can't be compiled until CONDITION and ;; DEFINE-CONDITION are defined and SB!DEBUG:*STACK-TOP-HINT* is @@ -694,7 +694,7 @@ ;; FIXME: Does this really need stuff from compiler/dump.lisp? ("src/compiler/target-dump" :not-host) ; needs stuff from compiler/dump.lisp - ("src/code/cold-init" :not-host) ; needs (SETF EXTERN-ALIEN) macroexpansion + ;("src/code/cold-init" :not-host) ; needs (SETF EXTERN-ALIEN) macroexpansion ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; target macros and DECLAIMs installed at build-the-cross-compiler time @@ -732,4 +732,12 @@ ;; anything else in cold build because after all it used to be ;; postponed 'til warm init with no problems. - ("src/pcl/walk")) + ("src/pcl/walk") + + ("src/os/tramps" :not-host :assem :target-os :not-genesis) + ("src/os/interrupt-stubs" :not-host :assem :target-os) + ("src/os/idle" :not-host :assem :target-os) + ("src/os/test" :not-host :target-os :trace-file) + ("src/os/display" :not-host :target-os :trace-file) + ("src/os/ata-hd" :not-host :target-os :trace-file) + ("src/os/system-vops")) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/make-stuff-happen.lisp sbcl-0.9.14/make-stuff-happen.lisp --- ../sbcl-sources/sbcl-0.9.14/make-stuff-happen.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/make-stuff-happen.lisp 2006-07-02 04:27:04.000000000 -0400 @@ -0,0 +1,124 @@ +;;; (We want to have some limit on print length and print level during +;;; bootstrapping because PRINT-OBJECT only gets set up rather late, +;;; and running without PRINT-OBJECT it's easy to fall into printing +;;; enormous (or infinitely circular) low-level representations of +;;; things.) +(setf *print-level* 5 *print-length* 5) + +(load "src/cold/shared.lisp") +;(load "tools-for-build/ldso-stubs.lisp") +(in-package "SB-COLD") +(setf *host-obj-prefix* "obj/from-host/") +(setf *target-obj-prefix* "obj/from-xc/") +(load "src/cold/set-up-cold-packages.lisp") +(load "src/cold/defun-load-or-cload-xcompiler.lisp") +(load-or-cload-xcompiler #'host-cload-stem) + +;;; Let's check that the type system, and various other things, are +;;; reasonably sane. (It's easy to spend a long time wandering around +;;; confused trying to debug cross-compilation if it isn't.) +(when (find :sb-test *shebang-features*) + (load "tests/type.before-xc.lisp") + (load "tests/info.before-xc.lisp") + (load "tests/vm.before-xc.lisp")) +(load "tools-for-build/ucd.lisp") + +;;; Generate character database tables. +(sb-cold::slurp-ucd) +(sb-cold::output) + +(defun proclaim-target-optimization () + (let ((debug (if (position :sb-show *shebang-features*) 2 1))) + (sb-xc:proclaim + `(optimize + (compilation-speed 1) (debug ,debug) + ;; CLISP's pretty-printer is fragile and tends to cause stack + ;; corruption or fail internal assertions, as of 2003-04-20; we + ;; therefore turn off as many notes as possible. + (sb!ext:inhibit-warnings #-clisp 2 #+clisp 3) + ;; SAFETY = SPEED (and < 3) should provide reasonable safety, + ;; but might skip some unreasonably expensive stuff + ;; (e.g. %DETECT-STACK-EXHAUSTION in sbcl-0.7.2). + (safety 2) (space 1) (speed 2) + ;; sbcl-internal optimization declarations: + ;; + ;; never insert stepper conditions + (sb!c:insert-step-conditions 0) + ;; always stack-allocate if requested + (sb!c::stack-allocate-dynamic-extent 3))))) +(compile 'proclaim-target-optimization) + +(defun in-target-cross-compilation-mode (fun) + "Call FUN with everything set up appropriately for cross-compiling + a target file." + (let (;; In order to increase microefficiency of the target Lisp, + ;; enable old CMU CL defined-function-types-never-change + ;; optimizations. (ANSI says users aren't supposed to + ;; redefine our functions anyway; and developers can + ;; fend for themselves.) + #!-sb-fluid + (sb!ext:*derive-function-types* t) + ;; Let the target know that we're the cross-compiler. + (*features* (cons :sb-xc *features*)) + ;; We need to tweak the readtable.. + (*readtable* (copy-readtable))) + ;; ..in order to make backquotes expand into target code + ;; instead of host code. + ;; FIXME: Isn't this now taken care of automatically by + ;; toplevel forms in the xcompiler backq.lisp file? + (set-macro-character #\` #'sb!impl::backquote-macro) + (set-macro-character #\, #'sb!impl::comma-macro) + ;; Control optimization policy. + (proclaim-target-optimization) + ;; Specify where target machinery lives. + (with-additional-nickname ("SB-XC" "SB!XC") + (funcall fun)))) +(compile 'in-target-cross-compilation-mode) + +(setf *target-compile-file* #'sb-xc:compile-file) +(setf *target-assemble-file* #'sb!c:assemble-file) +(setf *in-target-compilation-mode-fn* #'in-target-cross-compilation-mode) + +;; For compiler debugging +#+nil +(progn + (trace sb!c::is-ok-template-use) + (trace sb!c::operand-restriction-ok) + (trace sb!c::template-args-ok)) + +;;; Run the cross-compiler to produce cold fasl files. +(load "src/cold/compile-cold-sbcl.lisp") + +;;; Let's check that the type system was reasonably sane. (It's easy +;;; to spend a long time wandering around confused trying to debug +;;; cold init if it wasn't.) +;; (current test doesn't setup the type system.) +;(when (position :sb-test *shebang-features*) +; (load "tests/type.after-xc.lisp")) + +;;; If you're experimenting with the system under a cross-compilation +;;; host which supports CMU-CL-style SAVE-LISP, this can be a good +;;; time to run it. The resulting core isn't used in the normal build, +;;; but can be handy for experimenting with the system. (See slam.sh +;;; for an example.) +(when (position :sb-after-xc-core *shebang-features*) + #+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil) + #+sbcl (sb-ext:save-lisp-and-die "output/after-xc.core") + #+openmcl (ccl::save-application "output/after-xc.core") + #+clisp (ext:saveinitmem "output/after-xc.core")) + +;;; propagate structure offset and other information to the C runtime +;;; support code. +(host-cload-stem "src/compiler/generic/genesis") +;(sb!vm:genesis :c-header-dir-name "src/runtime/genesis") +(sb!vm:genesis :object-file-names *target-object-file-names* + :c-header-dir-name "output/genesis-2" + ; :symbol-table-file-name "src/runtime/sbcl.nm" + :core-file-name "output/cold-sbcl.core" + ;; The map file is not needed by the system, but can be + ;; very handy when debugging cold init problems. + :map-file-name "output/cold-sbcl.map" + :preload-file "obj/from-xc/src/os/tramps.lisp-obj") +#+cmu (ext:quit) +#+clisp (ext:quit) +#+abcl (ext:quit) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/package-data-list.lisp-expr sbcl-0.9.14/package-data-list.lisp-expr --- ../sbcl-sources/sbcl-0.9.14/package-data-list.lisp-expr 2006-06-26 11:48:45.000000000 -0400 +++ sbcl-0.9.14/package-data-list.lisp-expr 2006-07-02 04:27:04.000000000 -0400 @@ -2347,6 +2347,12 @@ ;;"NESTED-WALK-FORM" "MACROEXPAND-ALL" )) + #s(sb-cold:package-data + :name "SB!OS-KERNEL" + :doc "internal: our OS kernel" + :use ("CL" "SB!SYS" "SB!INT") + :export ("BOOT-KERNEL")) + #!+win32 #s(sb-cold:package-data :name "SB!WIN32" diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/code/cross-char.lisp sbcl-0.9.14/src/code/cross-char.lisp --- ../sbcl-sources/sbcl-0.9.14/src/code/cross-char.lisp 2005-07-14 12:30:14.000000000 -0400 +++ sbcl-0.9.14/src/code/cross-char.lisp 2006-07-02 04:27:04.000000000 -0400 @@ -14,12 +14,16 @@ (let ((ascii-standard-chars " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~")) (defun sb!xc:code-char (x) - (declare (type (or (integer 10 10) (integer 32 126)) x)) - (if (= x 10) - #\Newline - (char ascii-standard-chars (- x 32)))) + (declare (type (or (integer 8 8) (integer 10 10) (integer 32 126)) x)) + (cond + ((= x 8) #\Backspace) + ((= x 10) #\Newline) + (t (char ascii-standard-chars (- x 32))))) (defun sb!xc:char-code (character) (declare (type standard-char character)) - (if (char= character #\Newline) - 10 - (+ (position character ascii-standard-chars) 32)))) + (cond + ((char= character #\Backspace) + 8) + ((char= character #\Newline) + 10) + (t (+ (position character ascii-standard-chars) 32))))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/code/stream.lisp sbcl-0.9.14/src/code/stream.lisp --- ../sbcl-sources/sbcl-0.9.14/src/code/stream.lisp 2005-11-20 14:40:03.000000000 -0500 +++ sbcl-0.9.14/src/code/stream.lisp 2006-07-02 04:27:04.000000000 -0400 @@ -148,7 +148,7 @@ #!-sb-fluid (declaim (inline ansi-stream-file-position)) (defun ansi-stream-file-position (stream position) (declare (type stream stream)) - (declare (type (or index (alien sb!unix:off-t) (member nil :start :end)) + (declare (type (or index #|(alien sb!unix:off-t)|# (member nil :start :end)) position)) (cond (position diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/cold/compile-cold-sbcl.lisp sbcl-0.9.14/src/cold/compile-cold-sbcl.lisp --- ../sbcl-sources/sbcl-0.9.14/src/cold/compile-cold-sbcl.lisp 2005-07-14 12:30:41.000000000 -0400 +++ sbcl-0.9.14/src/cold/compile-cold-sbcl.lisp 2006-07-02 04:27:04.000000000 -0400 @@ -18,13 +18,15 @@ (let ((reversed-target-object-file-names nil)) (do-stems-and-flags (stem flags) - (unless (position :not-target flags) - (push (target-compile-stem stem - :trace-file (find :trace-file flags) - :assem-p (find :assem flags) - :ignore-failure-p (find :ignore-failure-p - flags)) - reversed-target-object-file-names) + ;(unless (position :not-target flags) + (when (position :target-os flags) + (let ((filename (target-compile-stem stem + :trace-file (find :trace-file flags) + :assem-p (find :assem flags) + :ignore-failure-p (find :ignore-failure-p + flags)))) + (unless (position :not-genesis flags) + (push filename reversed-target-object-file-names))) #!+sb-show (warn-when-cl-snapshot-diff *cl-snapshot*))) (setf *target-object-file-names* (nreverse reversed-target-object-file-names))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/cold/shared.lisp sbcl-0.9.14/src/cold/shared.lisp --- ../sbcl-sources/sbcl-0.9.14/src/cold/shared.lisp 2005-07-14 12:30:41.000000000 -0400 +++ sbcl-0.9.14/src/cold/shared.lisp 2006-07-02 04:27:04.000000000 -0400 @@ -323,7 +323,13 @@ ;; never figured out but which were apparently acceptable in CMU ;; CL. Eventually, it would be great to just get rid of all ;; warnings and remove support for this flag. -- WHN 19990323) - :ignore-failure-p)) + :ignore-failure-p + ;; meaning: For testing hacking the build process to produce an + ;; os kernel. + :target-os + ;; meaning: Build this file, but don't put it on the list for + ;; genesis to put in the cold core. + :not-genesis)) (defparameter *stems-and-flags* (read-from-file "build-order.lisp-expr")) @@ -351,12 +357,15 @@ ;;; cross-compiler's source code in the cross-compilation host. (defun in-host-compilation-mode (fn) (declare (type function fn)) - (let ((*features* (cons :sb-xc-host *features*)) - ;; the CROSS-FLOAT-INFINITY-KLUDGE, as documented in - ;; base-target-features.lisp-expr: - (*shebang-features* (set-difference *shebang-features* - '(:sb-propagate-float-type - :sb-propagate-fun-type)))) + (let* ((*features* (cons :sb-xc-host *features*)) + ;(*features* (cons :sb-cross-float-infinity-kludge *features*)) + ;; the CROSS-FLOAT-INFINITY-KLUDGE, as documented in + ;; base-target-features.lisp-expr: + ;(*shebang-features* (set-difference *shebang-features* + ; '(:sb-propagate-float-type + ; :sb-propagate-fun-type))) + ;; (Couldn't find those features anywhere in the source. AB 20060530) + ) (with-additional-nickname ("SB-XC" "SB!XC") (funcall fn)))) (compile 'in-host-compilation-mode) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/alpha/alloc.lisp sbcl-0.9.14/src/compiler/assembly/alpha/alloc.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/alpha/alloc.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/alpha/alloc.lisp 2001-05-08 20:02:00.000000000 -0400 @@ -0,0 +1,17 @@ +;;;; stuff to handle allocation of stuff we don't want to do inline + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;; (Given that the pseudo-atomic sequence is so short, there is +;;; nothing that qualifies. But we want to keep the file around +;;; in case we decide to add something later.) + diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/alpha/arith.lisp sbcl-0.9.14/src/compiler/assembly/alpha/arith.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/alpha/arith.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/alpha/arith.lisp 2005-07-14 12:30:10.000000000 -0400 @@ -0,0 +1,418 @@ +;;;; stuff to handle simple cases for generic arithmetic + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +(define-assembly-routine (generic-+ + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp temp3 non-descriptor-reg nl2-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst and x 3 temp) + (inst bne temp DO-STATIC-FUN) + (inst and y 3 temp) + (inst bne temp DO-STATIC-FUN) + (inst addq x y res) + + ; Check whether we need a bignum. + (inst sra res 31 temp) + (inst beq temp DONE) + (inst not temp temp) + (inst beq temp DONE) + (inst sra res 2 temp3) + + ; from move-from-signed + (inst li 2 temp2) + (inst sra temp3 31 temp) + (inst cmoveq temp 1 temp2) + (inst not temp temp) + (inst cmoveq temp 1 temp2) + (inst sll temp2 n-widetag-bits temp2) + (inst bis temp2 bignum-widetag temp2) + + (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) + (inst bis alloc-tn other-pointer-lowtag res) + (storew temp2 res 0 other-pointer-lowtag) + (storew temp3 res bignum-digits-offset other-pointer-lowtag) + (inst srl temp3 32 temp) + (storew temp res (1+ bignum-digits-offset) other-pointer-lowtag)) + DONE + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst ldl lip (static-fun-offset 'two-arg-+) null-tn) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip)) + + +(define-assembly-routine (generic-- + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp temp3 non-descriptor-reg nl2-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst and x 3 temp) + (inst bne temp DO-STATIC-FUN) + (inst and y 3 temp) + (inst bne temp DO-STATIC-FUN) + (inst subq x y res) + + ; Check whether we need a bignum. + (inst sra res 31 temp) + (inst beq temp DONE) + (inst not temp temp) + (inst beq temp DONE) + (inst sra res 2 temp3) + + ; from move-from-signed + (inst li 2 temp2) + (inst sra temp3 31 temp) + (inst cmoveq temp 1 temp2) + (inst not temp temp) + (inst cmoveq temp 1 temp2) + (inst sll temp2 n-widetag-bits temp2) + (inst bis temp2 bignum-widetag temp2) + + (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) + (inst bis alloc-tn other-pointer-lowtag res) + (storew temp2 res 0 other-pointer-lowtag) + (storew temp3 res bignum-digits-offset other-pointer-lowtag) + (inst srl temp3 32 temp) + (storew temp res (1+ bignum-digits-offset) other-pointer-lowtag)) + DONE + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst ldl lip (static-fun-offset 'two-arg--) null-tn) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip)) + + +(define-assembly-routine (generic-* + (:cost 25) + (:return-style :full-call) + (:translate *) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lo non-descriptor-reg nl1-offset) + (:temp hi non-descriptor-reg nl2-offset) + (:temp temp2 non-descriptor-reg nl3-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + ;; If either arg is not a fixnum, call the static function. + (inst and x 3 temp) + (inst bne temp DO-STATIC-FUN) + (inst and y 3 temp) + (inst bne temp DO-STATIC-FUN) + + ;; Remove the tag from one arg so that the result will have the + ;; correct fixnum tag. + (inst sra x 2 temp) + (inst mulq temp y lo) + (inst sra lo 32 hi) + (inst sll lo 32 res) + (inst sra res 32 res) + ;; Check to see if the result will fit in a fixnum. (I.e. the high + ;; word is just 32 copies of the sign bit of the low word). + (inst sra res 31 temp) + (inst xor hi temp temp) + (inst beq temp DONE) + ;; Shift the double word hi:res down two bits into hi:low to get rid + ;; of the fixnum tag. + (inst sra lo 2 lo) + (inst sra lo 32 hi) + + ;; Do we need one word or two? Assume two. + (inst li (logior (ash 2 n-widetag-bits) bignum-widetag) temp2) + (inst sra lo 31 temp) + (inst xor temp hi temp) + (inst bne temp two-words) + + ;; Only need one word, fix the header. + (inst li (logior (ash 1 n-widetag-bits) bignum-widetag) temp2) + ;; Allocate one word. + (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset))) + (inst bis alloc-tn other-pointer-lowtag res) + (storew temp2 res 0 other-pointer-lowtag)) + ;; Store one word + (storew lo res bignum-digits-offset other-pointer-lowtag) + ;; Out of here + (lisp-return lra lip :offset 2) + + TWO-WORDS + ;; Allocate two words. + (pseudo-atomic (:extra (pad-data-block (+ 2 bignum-digits-offset))) + (inst bis alloc-tn other-pointer-lowtag res) + (storew temp2 res 0 other-pointer-lowtag)) + ;; Store two words. + (storew lo res bignum-digits-offset other-pointer-lowtag) + (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag) + ;; out of here + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst ldl lip (static-fun-offset 'two-arg-*) null-tn) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip) + + DONE) + + +;;;; division + +(define-assembly-routine (signed-truncate + (:note "(signed-byte 64) truncate") + (:cost 60) + (:policy :fast-safe) + (:translate truncate) + (:arg-types signed-num signed-num) + (:result-types signed-num signed-num)) + + ((:arg dividend signed-reg nl0-offset) + (:arg divisor signed-reg nl1-offset) + + (:res quo signed-reg nl2-offset) + (:res rem signed-reg nl3-offset) + + (:temp quo-sign signed-reg nl5-offset) + (:temp rem-sign signed-reg nargs-offset) + (:temp temp1 non-descriptor-reg nl4-offset)) + + (let ((error (generate-error-code nil division-by-zero-error + dividend divisor))) + (inst beq divisor error)) + + (inst xor dividend divisor quo-sign) + (inst move dividend rem-sign) + (let ((label (gen-label))) + (inst bge dividend label) + (inst subq zero-tn dividend dividend) + (emit-label label)) + (let ((label (gen-label))) + (inst bge divisor label) + (inst subq zero-tn divisor divisor) + (emit-label label)) + (inst move zero-tn rem) + (inst move zero-tn quo) + + (dotimes (i 64) + (inst srl dividend 63 temp1) + (inst sll rem 1 rem) + (inst bis temp1 rem rem) + (inst cmple divisor rem temp1) + (inst sll quo 1 quo) + (inst bis temp1 quo quo) + (inst sll dividend 1 dividend) + (inst subq temp1 1 temp1) + (inst zap divisor temp1 temp1) + (inst subq rem temp1 rem)) + + (let ((label (gen-label))) + ;; If the quo-sign is negative, we need to negate quo. + (inst bge quo-sign label) + (inst subq zero-tn quo quo) + (emit-label label)) + (let ((label (gen-label))) + ;; If the rem-sign is negative, we need to negate rem. + (inst bge rem-sign label) + (inst subq zero-tn rem rem) + (emit-label label))) + + +;;;; comparison routines + +(macrolet + ((define-cond-assem-rtn (name translate static-fn cmp not-p) + `(define-assembly-routine (,name + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst and x 3 temp) + (inst bne temp DO-STATIC-FN) + (inst and y 3 temp) + (inst beq temp DO-COMPARE) + + DO-STATIC-FN + (inst ldl lip (static-fun-offset ',static-fn) null-tn) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip) + + DO-COMPARE + ,cmp + (inst move null-tn res) + (inst ,(if not-p 'bne 'beq) temp done) + (load-symbol res t) + DONE))) + + (define-cond-assem-rtn generic-< < two-arg-< (inst cmplt x y temp) nil) + (define-cond-assem-rtn generic-> > two-arg-> (inst cmplt y x temp) nil)) + + +(define-assembly-routine (generic-eql + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst cmpeq x y temp) + (inst bne temp RETURN-T) + (inst and x 3 temp) + (inst beq temp RETURN-NIL) + (inst and y 3 temp) + (inst bne temp DO-STATIC-FN) + + RETURN-NIL + (inst move null-tn res) + (lisp-return lra lip :offset 2) + + DO-STATIC-FN + (inst ldl lip (static-fun-offset 'eql) null-tn) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip) + + RETURN-T + (load-symbol res t)) + +(define-assembly-routine (generic-= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst and x 3 temp) + (inst bne temp DO-STATIC-FN) + (inst and y 3 temp) + (inst bne temp DO-STATIC-FN) + (inst cmpeq x y temp) + (inst bne temp RETURN-T) + + (inst move null-tn res) + (lisp-return lra lip :offset 2) + + DO-STATIC-FN + (inst ldl lip (static-fun-offset 'two-arg-=) null-tn) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip) + + RETURN-T + (load-symbol res t)) + +(define-assembly-routine (generic-/= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate /=) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst and x 3 temp) + (inst bne temp DO-STATIC-FN) + (inst and y 3 temp) + (inst bne temp DO-STATIC-FN) + (inst cmpeq x y temp) + (inst bne temp RETURN-NIL) + + (load-symbol res t) + (lisp-return lra lip :offset 2) + + DO-STATIC-FN + (inst ldl lip (static-fun-offset 'two-arg-/=) null-tn) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip) + + RETURN-NIL + (inst move null-tn res)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/alpha/array.lisp sbcl-0.9.14/src/compiler/assembly/alpha/array.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/alpha/array.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/alpha/array.lisp 2005-07-14 12:30:11.000000000 -0400 @@ -0,0 +1,178 @@ +;;;; support routines for arrays and vectors + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + + +(define-assembly-routine (allocate-vector + (:policy :fast-safe) + (:translate allocate-vector) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum)) + ((:arg type any-reg a0-offset) + (:arg length any-reg a1-offset) + (:arg words any-reg a2-offset) + (:res result descriptor-reg a0-offset) + + (:temp ndescr non-descriptor-reg nl0-offset)) + ;; This is kinda sleezy, changing words like this. But we can because + ;; the vop thinks it is temporary. + (inst addq words (+ (1- (ash 1 n-lowtag-bits)) + (* vector-data-offset n-word-bytes)) + words) + (inst li (lognot lowtag-mask) ndescr) + (inst and words ndescr words) + (inst srl type word-shift ndescr) + + (pseudo-atomic () + (inst bis alloc-tn other-pointer-lowtag result) + (inst addq alloc-tn words alloc-tn) + (storew ndescr result 0 other-pointer-lowtag) + (storew length result vector-length-slot other-pointer-lowtag))) + +;;;; hash primitives +#| +(define-assembly-routine (sxhash-simple-string + (:translate %sxhash-simple-string) + (:policy :fast-safe) + (:result-types positive-fixnum)) + ((:arg string descriptor-reg a0-offset) + (:res result any-reg a0-offset) + + (:temp length any-reg a1-offset) + + (:temp lip interior-reg lip-offset) + (:temp accum non-descriptor-reg nl0-offset) + (:temp data non-descriptor-reg nl1-offset) + (:temp byte non-descriptor-reg nl2-offset) + (:temp retaddr non-descriptor-reg nl3-offset) + (:temp temp1 non-descriptor-reg nl4-offset)) + + ;; These are needed after we jump into sxhash-simple-substring. + (progn result lip accum data byte retaddr) + + (inst li (make-fixup 'sxhash-simple-substring :assembly-routine) temp1) + (loadw length string vector-length-slot other-pointer-lowtag) + (inst jmp zero-tn temp1 + (make-fixup 'sxhash-simple-substring :assembly-routine))) + +(define-assembly-routine (sxhash-simple-substring + (:translate %sxhash-simple-substring) + (:policy :fast-safe) + (:arg-types * positive-fixnum) + (:result-types positive-fixnum)) + ((:arg string descriptor-reg a0-offset) + (:arg length any-reg a1-offset) + (:res result any-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp accum non-descriptor-reg nl0-offset) + (:temp data non-descriptor-reg nl1-offset) + (:temp byte non-descriptor-reg nl2-offset) + (:temp retaddr non-descriptor-reg nl3-offset)) + + ;; Save the return address + (inst subq lip code-tn retaddr) + + ;; Get a pointer to the data. + (inst addq string + (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + lip) + (move zero-tn accum) + (inst br zero-tn test) + + loop + + (inst and data #xff byte) + (inst xor accum byte accum) + (inst sll accum 5 byte) + (inst srl accum 27 accum) + (inst mskll accum 4 accum) + (inst bis accum byte accum) + + (inst srl data 8 byte) + (inst and byte #xff byte) + (inst xor accum byte accum) + (inst sll accum 5 byte) + (inst srl accum 27 accum) + (inst mskll accum 4 accum) + (inst bis accum byte accum) + + (inst srl data 16 byte) + (inst and byte #xff byte) + (inst xor accum byte accum) + (inst sll accum 5 byte) + (inst srl accum 27 accum) + (inst mskll accum 4 accum) + (inst bis accum byte accum) + + (inst srl data 24 byte) + (inst xor accum byte accum) + (inst sll accum 5 byte) + (inst srl accum 27 accum) + (inst mskll accum 4 accum) + (inst bis accum byte accum) + + (inst addq lip 4 lip) + + test + + (inst subq length (fixnum 4) length) + (inst ldl data 0 lip) + (inst bge length loop) + + (inst addq length (fixnum 3) length) + (inst beq length one-more) + (inst subq length (fixnum 1) length) + (inst beq length two-more) + (inst bne length done) + + (inst srl data 16 byte) + (inst and byte #xff byte) + (inst xor accum byte accum) + (inst sll accum 5 byte) + (inst srl accum 27 accum) + (inst mskll accum 4 accum) + (inst bis accum byte accum) + (inst addq length (fixnum 1) length) + + two-more + + (inst subq length (fixnum 1) length) + (inst srl data 8 byte) + (inst and byte #xff byte) + (inst xor accum byte accum) + (inst sll accum 5 byte) + (inst srl accum 27 accum) + (inst mskll accum 4 accum) + (inst bis accum byte accum) + (inst addq length (fixnum 1) length) + + one-more + + (inst subq length (fixnum 1) length) + (inst and data #xff byte) + (inst xor accum byte accum) + (inst sll accum 5 byte) + (inst srl accum 27 accum) + (inst mskll accum 4 accum) + (inst bis accum byte accum) + + done + + (inst sll accum 5 result) + (inst mskll result 4 result) + (inst srl result 3 result) + + ;; Restore the return address. + (inst addq code-tn retaddr lip)) +|# \ No newline at end of file diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/alpha/assem-rtns.lisp sbcl-0.9.14/src/compiler/assembly/alpha/assem-rtns.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/alpha/assem-rtns.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/alpha/assem-rtns.lisp 2005-07-14 12:30:11.000000000 -0400 @@ -0,0 +1,229 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; Return-multiple with other than one value + +#+sb-assembling ;; We don't want a vop for this one. +(define-assembly-routine + (return-multiple + (:return-style :none)) + + ;; These four are really arguments. + ((:temp nvals any-reg nargs-offset) + (:temp vals any-reg nl0-offset) + (:temp ocfp any-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + + ;; These are just needed to facilitate the transfer + (:temp lip interior-reg lip-offset) + (:temp count any-reg nl2-offset) + (:temp dst any-reg nl4-offset) + (:temp temp descriptor-reg l0-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset) + (:temp a4 descriptor-reg a4-offset) + (:temp a5 descriptor-reg a5-offset)) + + ;; Note, because of the way the RETURN-MULTIPLE VOP is written, we + ;; can assume that we are never called with NVALS == 1 and that A0 + ;; has already been loaded. + (inst ble nvals default-a0-and-on) + (inst ldl a1 (* 1 n-word-bytes) vals) + (inst subq nvals (fixnumize 2) count) + (inst ble count default-a2-and-on) + (inst ldl a2 (* 2 n-word-bytes) vals) + (inst subq nvals (fixnumize 3) count) + (inst ble count default-a3-and-on) + (inst ldl a3 (* 3 n-word-bytes) vals) + (inst subq nvals (fixnumize 4) count) + (inst ble count default-a4-and-on) + (inst ldl a4 (* 4 n-word-bytes) vals) + (inst subq nvals (fixnumize 5) count) + (inst ble count default-a5-and-on) + (inst ldl a5 (* 5 n-word-bytes) vals) + (inst subq nvals (fixnumize 6) count) + (inst ble count done) + + ;; Copy the remaining args to the top of the stack. + (inst addq vals (* 6 n-word-bytes) vals) + (inst addq cfp-tn (* 6 n-word-bytes) dst) + + LOOP + (inst ldl temp 0 vals) + (inst addq vals n-word-bytes vals) + (inst stl temp 0 dst) + (inst subq count (fixnumize 1) count) + (inst addq dst n-word-bytes dst) + (inst bne count loop) + + (inst br zero-tn done) + + DEFAULT-A0-AND-ON + (inst move null-tn a0) + (inst move null-tn a1) + DEFAULT-A2-AND-ON + (inst move null-tn a2) + DEFAULT-A3-AND-ON + (inst move null-tn a3) + DEFAULT-A4-AND-ON + (inst move null-tn a4) + DEFAULT-A5-AND-ON + (inst move null-tn a5) + DONE + + ;; Clear the stack. + (move cfp-tn ocfp-tn) + (move ocfp cfp-tn) + (inst addq ocfp-tn nvals csp-tn) + + ;; Return. + (lisp-return lra lip)) + +;;;; tail-call-variable + +#+sb-assembling ;; no vop for this one either +(define-assembly-routine + (tail-call-variable + (:return-style :none)) + + ;; These are really args. + ((:temp args any-reg nl0-offset) + (:temp lexenv descriptor-reg lexenv-offset) + + ;; We need to compute this + (:temp nargs any-reg nargs-offset) + + ;; These are needed by the blitting code. + (:temp src any-reg nl1-offset) + (:temp dst any-reg nl2-offset) + (:temp count any-reg cfunc-offset) + (:temp temp descriptor-reg l0-offset) + + ;; Needed for the jump + (:temp lip interior-reg lip-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset) + (:temp a4 descriptor-reg a4-offset) + (:temp a5 descriptor-reg a5-offset)) + + + ;; Calculate NARGS (as a fixnum) + (inst subq csp-tn args nargs) + + ;; Load the argument regs (must do this now, 'cause the blt might + ;; trash these locations) + (inst ldl a0 (* 0 n-word-bytes) args) + (inst ldl a1 (* 1 n-word-bytes) args) + (inst ldl a2 (* 2 n-word-bytes) args) + (inst ldl a3 (* 3 n-word-bytes) args) + (inst ldl a4 (* 4 n-word-bytes) args) + (inst ldl a5 (* 5 n-word-bytes) args) + + ;; Calc SRC, DST, and COUNT + (inst subq nargs (fixnumize register-arg-count) count) + (inst addq args (* n-word-bytes register-arg-count) src) + (inst ble count done) + (inst addq cfp-tn (* n-word-bytes register-arg-count) dst) + + LOOP + ;; Copy one arg. + (inst ldl temp 0 src) + (inst addq src n-word-bytes src) + (inst stl temp 0 dst) + (inst subq count (fixnumize 1) count) + (inst addq dst n-word-bytes dst) + (inst bgt count loop) + + DONE + ;; We are done. Do the jump. + (progn + (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) + (lisp-jump temp lip))) + + +;;;; non-local exit noise + +(define-assembly-routine + (unwind + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) a0-offset) + (:arg start (any-reg descriptor-reg) ocfp-offset) + (:arg count (any-reg descriptor-reg) nargs-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp cur-uwp any-reg nl0-offset) + (:temp next-uwp any-reg nl1-offset) + (:temp target-uwp any-reg nl2-offset) + (:temp temp1 non-descriptor-reg nl3-offset)) + (declare (ignore start count)) + + (load-symbol-value cur-uwp *current-unwind-protect-block*) + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst beq block error)) + + (loadw target-uwp block unwind-block-current-uwp-slot) + (inst cmpeq cur-uwp target-uwp temp1) + (inst beq temp1 do-uwp) + + (move block cur-uwp) + + do-exit + + (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) + (loadw code-tn cur-uwp unwind-block-current-code-slot) + (progn + (loadw lra cur-uwp unwind-block-entry-pc-slot) + (lisp-return lra lip :frob-code nil)) + + do-uwp + + (loadw next-uwp cur-uwp unwind-block-current-uwp-slot) + (store-symbol-value next-uwp *current-unwind-protect-block*) + (inst br zero-tn do-exit)) + +(define-assembly-routine + throw + ((:arg target descriptor-reg a0-offset) + (:arg start any-reg ocfp-offset) + (:arg count any-reg nargs-offset) + (:temp catch any-reg a1-offset) + (:temp tag descriptor-reg a2-offset) + (:temp temp1 non-descriptor-reg nl0-offset)) + + (progn start count) ; We just need them in the registers. + + (load-symbol-value catch *current-catch-block*) + + loop + + (let ((error (generate-error-code nil unseen-throw-tag-error target))) + (inst beq catch error)) + + (loadw tag catch catch-block-tag-slot) + (inst cmpeq tag target temp1) + (inst bne temp1 exit) + (loadw catch catch catch-block-previous-catch-slot) + (inst br zero-tn loop) + + exit + + (move catch target) + (inst li (make-fixup 'unwind :assembly-routine) temp1) + (inst jmp zero-tn temp1 (make-fixup 'unwind :assembly-routine))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/alpha/support.lisp sbcl-0.9.14/src/compiler/assembly/alpha/support.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/alpha/support.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/alpha/support.lisp 2005-07-14 12:30:11.000000000 -0400 @@ -0,0 +1,68 @@ +;;;; the machine-specific support routines needed by the file assembler + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +(!def-vm-support-routine generate-call-sequence (name style vop) + (ecase style + ((:raw :none) + (values + `((inst li (make-fixup ',name :assembly-routine) temp) + (inst jsr lip-tn temp)) + '((:temporary (:sc non-descriptor-reg) temp)) + nil)) + (:full-call + (let ((temp (make-symbol "TEMP")) + (nfp-save (make-symbol "NFP-SAVE")) + (lra (make-symbol "LRA"))) + (values + `((let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn ,vop))) + (when cur-nfp + (store-stack-tn ,nfp-save cur-nfp)) + (inst compute-lra-from-code ,lra code-tn lra-label ,temp) + (note-next-instruction ,vop :call-site) + ; here + (inst li (make-fixup ',name :assembly-routine) temp1) + (inst jsr lip-tn temp1 (make-fixup ',name :assembly-routine)) + (emit-return-pc lra-label) + (note-this-location ,vop :single-value-return) + (without-scheduling () + (move ocfp-tn csp-tn) + (inst nop)) + (inst compute-code-from-lra code-tn code-tn + lra-label ,temp) + (when cur-nfp + (maybe-load-stack-nfp-tn cur-nfp ,nfp-save temp1)))) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:sc descriptor-reg :offset lra-offset + :from (:eval 0) :to (:eval 1)) + ,lra) + (:temporary (:scs (control-stack) :offset nfp-save-offset) + ,nfp-save) + (:temporary (:scs (non-descriptor-reg)) temp1) + (:save-p t))))))) + +(!def-vm-support-routine generate-return-sequence (style) + (ecase style + (:raw + `((inst ret zero-tn lip-tn))) + (:full-call + `((lisp-return (make-random-tn :kind :normal + :sc (sc-or-lose + 'descriptor-reg) + :offset lra-offset) + lip-tn :offset 2))) + (:none))) + +(defun return-machine-address (scp) + (context-register scp lip-offset)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/assemfile.lisp sbcl-0.9.14/src/compiler/assembly/assemfile.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/assemfile.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/assemfile.lisp 2005-07-14 12:30:10.000000000 -0400 @@ -0,0 +1,196 @@ +;;;; the extra code necessary to feed an entire file of assembly code +;;;; to the assembler + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!C") + +;;; If non-NIL, emit assembly code. If NIL, emit VOP templates. +(defvar *emit-assembly-code-not-vops-p* nil) + +;;; a list of (NAME . LABEL) for every entry point +(defvar *entry-points* nil) + +;;; Set this to NIL to inhibit assembly-level optimization. (For +;;; compiler debugging, rather than policy control.) +(defvar *assembly-optimize* t) + +;;; Note: You might think from the name that this would act like +;;; COMPILE-FILE, but in fact it's arguably more like LOAD, even down +;;; to the return convention. It LOADs a file, then writes out any +;;; assembly code created by the process. +(defun assemble-file (name + &key + (output-file (make-pathname :defaults name + :type "assem"))) + ;; FIXME: Consider nuking the filename defaulting logic here. + (let* ((*emit-assembly-code-not-vops-p* t) + (name (pathname name)) + ;; the fasl file currently being output to + (lap-fasl-output (open-fasl-output (pathname output-file) name)) + (*entry-points* nil) + (won nil) + (*code-segment* nil) + (*elsewhere* nil) + (*assembly-optimize* nil) + (*fixup-notes* nil)) + (unwind-protect + (let ((*features* (cons :sb-assembling *features*))) + (init-assembler) + (load (merge-pathnames name (make-pathname :type "lisp"))) + (fasl-dump-cold-load-form `(in-package ,(package-name + (sane-package))) + lap-fasl-output) + (sb!assem:append-segment *code-segment* *elsewhere*) + (setf *elsewhere* nil) + (let ((length (sb!assem:finalize-segment *code-segment*))) + (dump-assembler-routines *code-segment* + length + *fixup-notes* + *entry-points* + lap-fasl-output)) + (setq won t)) + (close-fasl-output lap-fasl-output (not won))) + won)) + +(defstruct (reg-spec (:copier nil)) + (kind :temp :type (member :arg :temp :res)) + (name nil :type symbol) + (temp nil :type symbol) + (scs nil :type (or list symbol)) + (offset nil)) +(def!method print-object ((spec reg-spec) stream) + (print-unreadable-object (spec stream :type t) + (format stream + ":KIND ~S :NAME ~S :SCS ~S :OFFSET ~S" + (reg-spec-kind spec) + (reg-spec-name spec) + (reg-spec-scs spec) + (reg-spec-offset spec)))) + +(defun reg-spec-sc (spec) + (if (atom (reg-spec-scs spec)) + (reg-spec-scs spec) + (car (reg-spec-scs spec)))) + +(defun parse-reg-spec (kind name sc offset) + (let ((reg (make-reg-spec :kind kind :name name :scs sc :offset offset))) + (ecase kind + (:temp) + ((:arg :res) + (setf (reg-spec-temp reg) (make-symbol (symbol-name name))))) + reg)) + +(defun emit-assemble (name options regs code) + (collect ((decls)) + (loop + (if (and (consp code) (consp (car code)) (eq (caar code) 'declare)) + (decls (pop code)) + (return))) + `(let ,(mapcar (lambda (reg) + `(,(reg-spec-name reg) + (make-random-tn + :kind :normal + :sc (sc-or-lose ',(reg-spec-sc reg)) + :offset ,(reg-spec-offset reg)))) + regs) + ,@(decls) + (sb!assem:assemble (*code-segment* ',name) + ,name + (push (cons ',name ,name) *entry-points*) + ,@code + ,@(generate-return-sequence + (or (cadr (assoc :return-style options)) :raw))) + (when sb!xc:*compile-print* + (format *error-output* "~S assembled~%" ',name))))) + +(defun arg-or-res-spec (reg) + `(,(reg-spec-name reg) + :scs ,(if (atom (reg-spec-scs reg)) + (list (reg-spec-scs reg)) + (reg-spec-scs reg)) + ,@(unless (eq (reg-spec-kind reg) :res) + `(:target ,(reg-spec-temp reg))))) + +(defun emit-vop (name options vars) + (let* ((args (remove :arg vars :key #'reg-spec-kind :test #'neq)) + (temps (remove :temp vars :key #'reg-spec-kind :test #'neq)) + (results (remove :res vars :key #'reg-spec-kind :test #'neq)) + (return-style (or (cadr (assoc :return-style options)) :raw)) + (cost (or (cadr (assoc :cost options)) 247)) + (vop (make-symbol "VOP"))) + (unless (member return-style '(:raw :full-call :none)) + (error "unknown return-style for ~S: ~S" name return-style)) + (multiple-value-bind + (call-sequence call-temps) + (generate-call-sequence name return-style vop) + `(define-vop ,(if (atom name) (list name) name) + (:args ,@(mapcar #'arg-or-res-spec args)) + ,@(let ((index -1)) + (mapcar (lambda (arg) + `(:temporary (:sc ,(reg-spec-sc arg) + :offset ,(reg-spec-offset arg) + :from (:argument ,(incf index)) + :to (:eval 2)) + ,(reg-spec-temp arg))) + args)) + ,@(mapcar (lambda (temp) + `(:temporary (:sc ,(reg-spec-sc temp) + :offset ,(reg-spec-offset temp) + :from (:eval 1) + :to (:eval 3)) + ,(reg-spec-name temp))) + temps) + ,@call-temps + (:vop-var ,vop) + ,@(let ((index -1)) + (mapcar (lambda (res) + `(:temporary (:sc ,(reg-spec-sc res) + :offset ,(reg-spec-offset res) + :from (:eval 2) + :to (:result ,(incf index)) + :target ,(reg-spec-name res)) + ,(reg-spec-temp res))) + results)) + (:results ,@(mapcar #'arg-or-res-spec results)) + (:ignore ,@(mapcar #'reg-spec-name temps) + ,@(apply #'append + (mapcar #'cdr + (remove :ignore call-temps + :test #'neq :key #'car)))) + ,@(remove-if (lambda (x) + (member x '(:return-style :cost))) + options + :key #'car) + (:generator ,cost + ,@(mapcar (lambda (arg) + #!+(or hppa alpha) `(move ,(reg-spec-name arg) + ,(reg-spec-temp arg)) + #!-(or hppa alpha) `(move ,(reg-spec-temp arg) + ,(reg-spec-name arg))) + args) + ,@call-sequence + ,@(mapcar (lambda (res) + #!+(or hppa alpha) `(move ,(reg-spec-temp res) + ,(reg-spec-name res)) + #!-(or hppa alpha) `(move ,(reg-spec-name res) + ,(reg-spec-temp res))) + results)))))) + +(def!macro define-assembly-routine (name&options vars &body code) + (multiple-value-bind (name options) + (if (atom name&options) + (values name&options nil) + (values (car name&options) + (cdr name&options))) + (let ((regs (mapcar (lambda (var) (apply #'parse-reg-spec var)) vars))) + (if *emit-assembly-code-not-vops-p* + (emit-assemble name options regs code) + (emit-vop name options regs))))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/hppa/alloc.lisp sbcl-0.9.14/src/compiler/assembly/hppa/alloc.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/hppa/alloc.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/hppa/alloc.lisp 2002-08-19 08:14:00.000000000 -0400 @@ -0,0 +1,6 @@ +(in-package "SB!VM") + +;;; Given that the pseudo-atomic sequence is so short, there is +;;; nothing that qualifies. But we want to keep the file around +;;; in case we decide to add something later. + diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/hppa/arith.lisp sbcl-0.9.14/src/compiler/assembly/hppa/arith.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/hppa/arith.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/hppa/arith.lisp 2005-07-14 12:30:11.000000000 -0400 @@ -0,0 +1,265 @@ +(in-package "SB!VM") + + +;;;; Multiplication and Division helping routines. + +;;; ?? FIXME: Where are generic-* and generic-/? +#+sb-assembling +(define-assembly-routine + multiply + ((:arg x (signed-reg) nl0-offset) + (:arg y (signed-reg) nl1-offset) + + (:res res (signed-reg) nl2-offset) + + (:temp tmp (unsigned-reg) nl3-offset) + (:temp sign (unsigned-reg) nl4-offset)) + + ;; Determine the sign of the result. + (inst extrs x 0 1 sign :=) + (inst sub zero-tn x x) + (inst extrs y 0 1 tmp :=) + (inst sub zero-tn y y) + (inst xor sign tmp sign) + + ;; Make sure X is less then Y. + (inst comclr x y tmp :<<) + (inst xor x y tmp) + (inst xor x tmp x) + (inst xor y tmp y) + ;; Blow out of here if the result is zero. + (inst comb := x zero-tn done) + (inst li 0 res) + + LOOP + (inst extru x 31 1 zero-tn :ev) + (inst add y res res) + (inst extru x 30 1 zero-tn :ev) + (inst sh1add y res res) + (inst extru x 29 1 zero-tn :ev) + (inst sh2add y res res) + (inst extru x 28 1 zero-tn :ev) + (inst sh3add y res res) + + (inst srl x 4 x) + (inst comb :<> x zero-tn loop) + (inst sll y 4 y) + + DONE + (inst xor res sign res) + (inst add res sign res)) + + +#+sb-assembling +(define-assembly-routine + (truncate) + ((:arg dividend signed-reg nl0-offset) + (:arg divisor signed-reg nl1-offset) + + (:res quo signed-reg nl2-offset) + (:res rem signed-reg nl3-offset)) + + ;; Move abs(divident) into quo. + (inst move dividend quo :>=) + (inst sub zero-tn quo quo) + ;; Do one divive-step with -divisor to prime V (use rem as a temp) + (inst sub zero-tn divisor rem) + (inst ds zero-tn rem zero-tn) + ;; Shift the divident/quotient one bit, setting the carry flag. + (inst add quo quo quo) + ;; The first real divive-step. + (inst ds zero-tn divisor rem) + (inst addc quo quo quo) + ;; And 31 more of them. + (dotimes (i 31) + (inst ds rem divisor rem) + (inst addc quo quo quo)) + ;; If the remainder is negative, we need to add the absolute value of the + ;; divisor. + (inst comb :>= rem zero-tn remainder-positive) + (inst comclr divisor zero-tn zero-tn :<) + (inst add rem divisor rem :tr) + (inst sub rem divisor rem) + REMAINDER-POSITIVE + ;; Now we have to fix the signs of quo and rem. + (inst xor divisor dividend zero-tn :>=) + (inst sub zero-tn quo quo) + (inst move dividend zero-tn :>=) + (inst sub zero-tn rem rem)) + + + +;;;; Generic arithmetic. + +(define-assembly-routine (generic-+ + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst extru x 31 2 zero-tn :=) + (inst b do-static-fun :nullify t) + (inst extru y 31 2 zero-tn :=) + (inst b do-static-fun :nullify t) + (inst addo x y res) + (lisp-return lra :offset 1) + + DO-STATIC-FUN + (inst ldw (static-fun-offset 'two-arg-+) null-tn lip) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst bv lip) + (inst move csp-tn cfp-tn)) + +(define-assembly-routine (generic-- + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst extru x 31 2 zero-tn :=) + (inst b do-static-fun :nullify t) + (inst extru y 31 2 zero-tn :=) + (inst b do-static-fun :nullify t) + (inst subo x y res) + (lisp-return lra :offset 1) + + DO-STATIC-FUN + (inst ldw (static-fun-offset 'two-arg--) null-tn lip) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst bv lip) + (inst move csp-tn cfp-tn)) + + + +;;;; Comparison routines. + +(macrolet + ((define-cond-assem-rtn (name translate static-fn cond) + `(define-assembly-routine (,name + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst extru x 31 2 zero-tn :=) + (inst b do-static-fn :nullify t) + (inst extru y 31 2 zero-tn :=) + (inst b do-static-fn :nullify t) + + (inst comclr x y zero-tn ,cond) + (inst move null-tn res :tr) + (load-symbol res t) + (lisp-return lra :offset 1) + + DO-STATIC-FN + (inst ldw (static-fun-offset ',static-fn) null-tn lip) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst bv lip) + (inst move csp-tn cfp-tn)))) + + (define-cond-assem-rtn generic-< < two-arg-< :<) + (define-cond-assem-rtn generic-> > two-arg-> :>)) + + +(define-assembly-routine + (generic-eql + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + + (inst comb := x y return-t :nullify t) + (inst extru x 31 2 zero-tn :<>) + (inst b return-nil :nullify t) + (inst extru y 31 2 zero-tn :=) + (inst b do-static-fn :nullify t) + + RETURN-NIL + (inst move null-tn res) + (lisp-return lra :offset 1) + + DO-STATIC-FN + (inst ldw (static-fun-offset 'eql) null-tn lip) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst bv lip) + (inst move csp-tn cfp-tn) + + RETURN-T + (load-symbol res t)) + +(define-assembly-routine + (generic-= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + + (inst comb := x y return-t :nullify t) + (inst extru x 31 2 zero-tn :=) + (inst b do-static-fn :nullify t) + (inst extru y 31 2 zero-tn :=) + (inst b do-static-fn :nullify t) + + (inst move null-tn res) + (lisp-return lra :offset 1) + + DO-STATIC-FN + (inst ldw (static-fun-offset 'two-arg-=) null-tn lip) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst bv lip) + (inst move csp-tn cfp-tn) + + RETURN-T + (load-symbol res t)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/hppa/array.lisp sbcl-0.9.14/src/compiler/assembly/hppa/array.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/hppa/array.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/hppa/array.lisp 2005-07-14 12:30:11.000000000 -0400 @@ -0,0 +1,96 @@ +(in-package "SB!VM") + +(define-assembly-routine + (allocate-vector + (:policy :fast-safe) + (:translate allocate-vector) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum)) + ((:arg type any-reg a0-offset) + (:arg length any-reg a1-offset) + (:arg words any-reg a2-offset) + (:res result descriptor-reg a0-offset) + + (:temp ndescr non-descriptor-reg nl0-offset) + (:temp vector descriptor-reg a3-offset)) + (pseudo-atomic () + (move alloc-tn vector) + (inst dep other-pointer-lowtag 31 3 vector) + (inst addi (* (1+ vector-data-offset) n-word-bytes) words ndescr) + (inst dep 0 31 3 ndescr) + (inst add ndescr alloc-tn alloc-tn) + (inst srl type word-shift ndescr) + (storew ndescr vector 0 other-pointer-lowtag) + (storew length vector vector-length-slot other-pointer-lowtag)) + (move vector result)) + + + +;;;; Hash primitives + +;;; FIXME: This looks kludgy bad and wrong. +#+sb-assembling +(defparameter *sxhash-simple-substring-entry* (gen-label)) + +(define-assembly-routine + (sxhash-simple-string + (:translate %sxhash-simple-string) + (:policy :fast-safe) + (:result-types positive-fixnum)) + ((:arg string descriptor-reg a0-offset) + (:res result any-reg a0-offset) + + (:temp length any-reg a1-offset) + (:temp accum non-descriptor-reg nl0-offset) + (:temp data non-descriptor-reg nl1-offset) + (:temp offset non-descriptor-reg nl2-offset)) + + (declare (ignore result accum data offset)) + + ;; Save the return address. + (inst b *sxhash-simple-substring-entry*) + (loadw length string vector-length-slot other-pointer-lowtag)) + +(define-assembly-routine + (sxhash-simple-substring + (:translate %sxhash-simple-substring) + (:policy :fast-safe) + (:arg-types * positive-fixnum) + (:result-types positive-fixnum)) + + ((:arg string descriptor-reg a0-offset) + (:arg length any-reg a1-offset) + (:res result any-reg a0-offset) + + (:temp accum non-descriptor-reg nl0-offset) + (:temp data non-descriptor-reg nl1-offset) + (:temp offset non-descriptor-reg nl2-offset)) + + (emit-label *sxhash-simple-substring-entry*) + + (inst li (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) offset) + (inst b test) + (move zero-tn accum) + + LOOP + (inst xor accum data accum) + (inst shd accum accum 5 accum) + + TEST + (inst ldwx offset string data) + (inst addib :>= (fixnumize -4) length loop) + (inst addi (fixnumize 1) offset offset) + + (inst addi (fixnumize 4) length length) + (inst comb := zero-tn length done :nullify t) + (inst sub zero-tn length length) + (inst sll length 1 length) + (inst mtctl length :sar) + (inst shd zero-tn data :variable data) + (inst xor accum data accum) + + DONE + + (inst sll accum 5 result) + (inst srl result 3 result)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/hppa/assem-rtns.lisp sbcl-0.9.14/src/compiler/assembly/hppa/assem-rtns.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/hppa/assem-rtns.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/hppa/assem-rtns.lisp 2005-07-14 12:30:11.000000000 -0400 @@ -0,0 +1,203 @@ +(in-package "SB!VM") + + +;;;; Return-multiple with other than one value + +#+sb-assembling ;; we don't want a vop for this one. +(define-assembly-routine + (return-multiple + (:return-style :none)) + + ;; These four are really arguments. + ((:temp nvals any-reg nargs-offset) + (:temp vals any-reg nl0-offset) + (:temp old-fp any-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + + ;; These are just needed to facilitate the transfer + (:temp count any-reg nl2-offset) + (:temp src any-reg nl3-offset) + (:temp dst any-reg nl4-offset) + (:temp temp descriptor-reg l0-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset) + (:temp a4 descriptor-reg a4-offset) + (:temp a5 descriptor-reg a5-offset)) + + (inst movb := nvals count default-a0-and-on :nullify t) + (loadw a0 vals 0) + (inst addib := (fixnumize -1) count default-a1-and-on :nullify t) + (loadw a1 vals 1) + (inst addib := (fixnumize -1) count default-a2-and-on :nullify t) + (loadw a2 vals 2) + (inst addib := (fixnumize -1) count default-a3-and-on :nullify t) + (loadw a3 vals 3) + (inst addib := (fixnumize -1) count default-a4-and-on :nullify t) + (loadw a4 vals 4) + (inst addib := (fixnumize -1) count default-a5-and-on :nullify t) + (loadw a5 vals 5) + (inst addib := (fixnumize -1) count done :nullify t) + + ;; Copy the remaining args to the top of the stack. + (inst addi (* 6 n-word-bytes) vals src) + (inst addi (* 6 n-word-bytes) cfp-tn dst) + + LOOP + (inst ldwm 4 src temp) + (inst addib :> (fixnumize -1) count loop) + (inst stwm temp 4 dst) + + (inst b done :nullify t) + + DEFAULT-A0-AND-ON + (inst move null-tn a0) + DEFAULT-A1-AND-ON + (inst move null-tn a1) + DEFAULT-A2-AND-ON + (inst move null-tn a2) + DEFAULT-A3-AND-ON + (inst move null-tn a3) + DEFAULT-A4-AND-ON + (inst move null-tn a4) + DEFAULT-A5-AND-ON + (inst move null-tn a5) + + DONE + ;; Clear the stack. + (move cfp-tn ocfp-tn) + (move old-fp cfp-tn) + (inst add ocfp-tn nvals csp-tn) + + ;; Return. + (lisp-return lra)) + + + +;;;; tail-call-variable. + +#+sb-assembling ;; no vop for this one either. +(define-assembly-routine + (tail-call-variable + (:return-style :none)) + + ;; These are really args. + ((:temp args any-reg nl0-offset) + (:temp lexenv descriptor-reg lexenv-offset) + + ;; We need to compute this + (:temp nargs any-reg nargs-offset) + + ;; These are needed by the blitting code. + (:temp src any-reg nl1-offset) + (:temp dst any-reg nl2-offset) + (:temp count any-reg nl3-offset) + (:temp temp descriptor-reg l0-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset) + (:temp a4 descriptor-reg a4-offset) + (:temp a5 descriptor-reg a5-offset)) + + + ;; Calculate NARGS (as a fixnum) + (inst sub csp-tn args nargs) + + ;; Load the argument regs (must do this now, 'cause the blt might + ;; trash these locations) + (loadw a0 args 0) + (loadw a1 args 1) + (loadw a2 args 2) + (loadw a3 args 3) + (loadw a4 args 4) + (loadw a5 args 5) + + ;; Calc SRC, DST, and COUNT + (inst addi (fixnumize (- register-arg-count)) nargs count) + (inst comb :<= count zero-tn done :nullify t) + (inst addi (* n-word-bytes register-arg-count) args src) + (inst addi (* n-word-bytes register-arg-count) cfp-tn dst) + + LOOP + ;; Copy one arg. + (inst ldwm 4 src temp) + (inst addib :> (fixnumize -1) count loop) + (inst stwm temp 4 dst) + + DONE + ;; We are done. Do the jump. + (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) + (lisp-jump temp)) + + + +;;;; Non-local exit noise. + +;;; FIXME: Really? +#+sb-assembling +(defparameter *unwind-entry-point* (gen-label)) + +(define-assembly-routine + (unwind + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) a0-offset) + (:arg start (any-reg descriptor-reg) ocfp-offset) + (:arg count (any-reg descriptor-reg) nargs-offset) + (:temp lra descriptor-reg lra-offset) + (:temp cur-uwp any-reg nl0-offset) + (:temp next-uwp any-reg nl1-offset) + (:temp target-uwp any-reg nl2-offset)) + (declare (ignore start count)) + + (emit-label *unwind-entry-point*) + + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst bc := nil block zero-tn error)) + + (load-symbol-value cur-uwp *current-unwind-protect-block*) + (loadw target-uwp block unwind-block-current-uwp-slot) + (inst bc :<> nil cur-uwp target-uwp do-uwp) + + (move block cur-uwp) + + DO-EXIT + + (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) + (loadw code-tn cur-uwp unwind-block-current-code-slot) + (loadw lra cur-uwp unwind-block-entry-pc-slot) + (lisp-return lra :frob-code nil) + + DO-UWP + + (loadw next-uwp cur-uwp unwind-block-current-uwp-slot) + (inst b do-exit) + (store-symbol-value next-uwp *current-unwind-protect-block*)) + + +(define-assembly-routine + throw + ((:arg target descriptor-reg a0-offset) + (:arg start any-reg ocfp-offset) + (:arg count any-reg nargs-offset) + (:temp catch any-reg a1-offset) + (:temp tag descriptor-reg a2-offset)) + (declare (ignore start count)) ; We just need them in the registers. + + (load-symbol-value catch *current-catch-block*) + + LOOP + (let ((error (generate-error-code nil unseen-throw-tag-error target))) + (inst bc := nil catch zero-tn error)) + (loadw tag catch catch-block-tag-slot) + (inst comb :<> tag target loop :nullify t) + (loadw catch catch catch-block-previous-catch-slot) + + (inst b *unwind-entry-point*) + (inst move catch target)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/hppa/support.lisp sbcl-0.9.14/src/compiler/assembly/hppa/support.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/hppa/support.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/hppa/support.lisp 2005-07-14 12:30:11.000000000 -0400 @@ -0,0 +1,74 @@ +;;;; the machine-specific support routines needed by the file assembler + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +(!def-vm-support-routine generate-call-sequence (name style vop) + (ecase style + (:raw + (with-unique-names (fixup) + (values + `((let ((fixup (make-fixup ',name :assembly-routine))) + (inst ldil fixup ,fixup) + (inst ble fixup lisp-heap-space ,fixup :nullify t)) + (inst nop)) + `((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1)) + ,fixup))))) + (:full-call + (let ((temp (make-symbol "TEMP")) + (nfp-save (make-symbol "NFP-SAVE")) + (lra (make-symbol "LRA"))) + (values + `((let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn ,vop))) + (when cur-nfp + (store-stack-tn ,nfp-save cur-nfp)) + (inst compute-lra-from-code code-tn lra-label ,temp ,lra) + (note-this-location ,vop :call-site) + (let ((fixup (make-fixup ',name :assembly-routine))) + (inst ldil fixup ,temp) + (inst be fixup lisp-heap-space ,temp :nullify t)) + (emit-return-pc lra-label) + (note-this-location ,vop :single-value-return) + (move ocfp-tn csp-tn) + (inst compute-code-from-lra code-tn lra-label ,temp code-tn) + (when cur-nfp + (load-stack-tn cur-nfp ,nfp-save)))) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:sc descriptor-reg :offset lra-offset + :from (:eval 0) :to (:eval 1)) + ,lra) + (:temporary (:scs (control-stack) :offset nfp-save-offset) + ,nfp-save) + (:save-p :compute-only))))) + (:none + (with-unique-names (fixup) + (values + `((let ((fixup (make-fixup ',name :assembly-routine))) + (inst ldil fixup ,fixup) + (inst be fixup lisp-heap-space ,fixup :nullify t))) + `((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1)) + ,fixup))))))) + +(!def-vm-support-routine generate-return-sequence (style) + (ecase style + (:raw + `((inst bv lip-tn :nullify t))) + (:full-call + `((lisp-return (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg) + :offset lra-offset) + :offset 1))) + (:none))) + +(defun return-machine-address (scp) + (context-register scp lip-offset)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/mips/alloc.lisp sbcl-0.9.14/src/compiler/assembly/mips/alloc.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/mips/alloc.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/mips/alloc.lisp 2002-09-01 18:34:18.000000000 -0400 @@ -0,0 +1,3 @@ +(in-package "SB!VM") + + diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/mips/arith.lisp sbcl-0.9.14/src/compiler/assembly/mips/arith.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/mips/arith.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/mips/arith.lisp 2006-05-13 15:34:27.000000000 -0400 @@ -0,0 +1,447 @@ +;;;; stuff to handle simple cases for generic arithmetic + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + + + +;;;; Addition and subtraction. + +;;; static-fun-offset returns the address of the raw_addr slot of +;;; a static function's fdefn. + +;;; Note that there is only one use of static-fun-offset outside this +;;; file (in genesis.lisp) + +(define-assembly-routine (generic-+ + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp1 non-descriptor-reg nl1-offset) + (:temp temp2 non-descriptor-reg nl2-offset) + (:temp pa-flag non-descriptor-reg nl4-offset) + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst or temp x y) + (inst and temp fixnum-tag-mask) + (inst bne temp DO-STATIC-FUN) + (inst addu temp x y) + ;; check for overflow + (inst xor temp1 temp x) + (inst xor temp2 temp y) + (inst and temp1 temp2) + (inst bltz temp1 DO-OVERFLOW) + (inst sra temp1 x n-fixnum-tag-bits) + (inst move res temp) + (lisp-return lra lip :offset 2) + + DO-OVERFLOW + ;; We did overflow, so do the bignum version + (inst sra temp2 y n-fixnum-tag-bits) + (inst addu temp temp1 temp2) + (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset)) + (storew temp res bignum-digits-offset other-pointer-lowtag)) + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst lw lip null-tn (static-fun-offset 'two-arg-+)) + (inst li nargs (fixnumize 2)) + (move ocfp cfp-tn) + (inst j lip) + (move cfp-tn csp-tn t)) + + +(define-assembly-routine (generic-- + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp1 non-descriptor-reg nl1-offset) + (:temp temp2 non-descriptor-reg nl2-offset) + (:temp pa-flag non-descriptor-reg nl4-offset) + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst or temp x y) + (inst and temp fixnum-tag-mask) + (inst bne temp DO-STATIC-FUN) + (inst subu temp x y) + ;; check for overflow + (inst xor temp1 x y) + (inst xor temp2 x temp) + (inst and temp1 temp2) + (inst bltz temp1 DO-OVERFLOW) + (inst sra temp1 x n-fixnum-tag-bits) + (inst move res temp) + (lisp-return lra lip :offset 2) + + DO-OVERFLOW + ;; We did overflow, so do the bignum version + (inst sra temp2 y n-fixnum-tag-bits) + (inst subu temp temp1 temp2) + (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset)) + (storew temp res bignum-digits-offset other-pointer-lowtag)) + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst lw lip null-tn (static-fun-offset 'two-arg--)) + (inst li nargs (fixnumize 2)) + (move ocfp cfp-tn) + (inst j lip) + (move cfp-tn csp-tn t)) + + + +;;;; Multiplication + + +(define-assembly-routine (generic-* + (:cost 25) + (:return-style :full-call) + (:translate *) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lo non-descriptor-reg nl1-offset) + (:temp hi non-descriptor-reg nl2-offset) + (:temp pa-flag non-descriptor-reg nl4-offset) + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + ;; If either arg is not a fixnum, call the static function. + (inst or temp x y) + (inst and temp fixnum-tag-mask) + (inst bne temp DO-STATIC-FUN) + ;; Remove the tag from one arg so that the result will have the correct + ;; fixnum tag. + (inst sra temp x n-fixnum-tag-bits) + (inst mult temp y) + (inst mflo res) + (inst mfhi hi) + ;; Check to see if the result will fit in a fixnum. (I.e. the high word + ;; is just 32 copies of the sign bit of the low word). + (inst sra temp res 31) + (inst bne temp hi DO-BIGNUM) + (inst srl lo res n-fixnum-tag-bits) + (lisp-return lra lip :offset 2) + + DO-BIGNUM + ;; Shift the double word hi:res down two bits into hi:low to get rid of the + ;; fixnum tag. + (inst sll temp hi (- n-word-bits n-fixnum-tag-bits)) + (inst or lo temp) + (inst sra hi n-fixnum-tag-bits) + + ;; Do we need one word or two? Assume two. + (inst sra temp lo 31) + (inst bne temp hi TWO-WORDS) + ;; Assume a two word header. + (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag)) + + ;; Only need one word, fix the header. + (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag)) + + (pseudo-atomic (pa-flag :extra (pad-data-block (+ 1 bignum-digits-offset))) + (inst or res alloc-tn other-pointer-lowtag) + (storew temp res 0 other-pointer-lowtag)) + (storew lo res bignum-digits-offset other-pointer-lowtag) + (lisp-return lra lip :offset 2) + + TWO-WORDS + (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset))) + (inst or res alloc-tn other-pointer-lowtag) + (storew temp res 0 other-pointer-lowtag)) + + (storew lo res bignum-digits-offset other-pointer-lowtag) + (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag) + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst lw lip null-tn (static-fun-offset 'two-arg-*)) + (inst li nargs (fixnumize 2)) + (move ocfp cfp-tn) + (inst j lip) + (move cfp-tn csp-tn t)) + + +(macrolet + ((frob (name note cost type sc signed-p) + `(define-assembly-routine (,name + (:note ,note) + (:cost ,cost) + (:translate *) + (:policy :fast-safe) + (:arg-types ,type ,type) + (:result-types ,type)) + ((:arg x ,sc nl0-offset) + (:arg y ,sc nl1-offset) + (:res res ,sc nl0-offset)) + ,@(when (eq type 'tagged-num) + `((inst sra x 2))) + (inst ,(if signed-p 'mult 'multu) x y) + (inst mflo res)))) + (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg nil) + (frob signed-* "signed *" 41 signed-num signed-reg t) + (frob fixnum-* "fixnum *" 30 tagged-num any-reg t)) + + + +;;;; Division. + + +(define-assembly-routine (positive-fixnum-truncate + (:note "unsigned fixnum truncate") + (:cost 45) + (:translate truncate) + (:policy :fast-safe) + (:arg-types positive-fixnum positive-fixnum) + (:result-types positive-fixnum positive-fixnum)) + ((:arg dividend any-reg nl0-offset) + (:arg divisor any-reg nl1-offset) + + (:res quo any-reg nl2-offset) + (:res rem any-reg nl3-offset)) + (let ((error (generate-error-code nil division-by-zero-error + dividend divisor))) + (inst beq divisor error) + (inst nop)) + + (inst divu dividend divisor) + (inst mflo quo) + (inst mfhi rem) + (inst sll quo 2)) + + +(define-assembly-routine (fixnum-truncate + (:note "fixnum truncate") + (:cost 50) + (:policy :fast-safe) + (:translate truncate) + (:arg-types tagged-num tagged-num) + (:result-types tagged-num tagged-num)) + ((:arg dividend any-reg nl0-offset) + (:arg divisor any-reg nl1-offset) + + (:res quo any-reg nl2-offset) + (:res rem any-reg nl3-offset)) + (let ((error (generate-error-code nil division-by-zero-error + dividend divisor))) + (inst beq divisor error) + (inst nop)) + + (inst div dividend divisor) + (inst mflo quo) + (inst mfhi rem) + (inst sll quo 2)) + + +(define-assembly-routine (signed-truncate + (:note "(signed-byte 32) truncate") + (:cost 60) + (:policy :fast-safe) + (:translate truncate) + (:arg-types signed-num signed-num) + (:result-types signed-num signed-num)) + + ((:arg dividend signed-reg nl0-offset) + (:arg divisor signed-reg nl1-offset) + + (:res quo signed-reg nl2-offset) + (:res rem signed-reg nl3-offset)) + (let ((error (generate-error-code nil division-by-zero-error + dividend divisor))) + (inst beq divisor error) + (inst nop)) + + (inst div dividend divisor) + (inst mflo quo) + (inst mfhi rem)) + + + +;;;; Comparison routines. + +(macrolet + ((define-cond-assem-rtn (name translate static-fn cmp not-p) + `(define-assembly-routine (,name + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst or temp x y) + (inst and temp fixnum-tag-mask) + (inst bne temp DO-STATIC-FUN) + ,cmp + + (inst ,(if not-p 'beq 'bne) temp DONE) + (move res null-tn t) + (load-symbol res t) + + DONE + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst lw lip null-tn (static-fun-offset ',static-fn)) + (inst li nargs (fixnumize 2)) + (move ocfp cfp-tn) + (inst j lip) + (move cfp-tn csp-tn t)))) + + (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) t) + (define-cond-assem-rtn generic-<= <= two-arg-<= (inst slt temp x y) nil) + (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x) t) + (define-cond-assem-rtn generic->= >= two-arg->= (inst slt temp y x) nil)) + + +(define-assembly-routine (generic-eql + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst beq x y RETURN-T) + (inst or temp x y) + (inst and temp fixnum-tag-mask) + (inst bne temp DO-STATIC-FUN) + (inst nop) + + (inst bne x y DONE) + (move res null-tn t) + + RETURN-T + (load-symbol res t) + + DONE + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst lw lip null-tn (static-fun-offset 'eql)) + (inst li nargs (fixnumize 2)) + (move ocfp cfp-tn) + (inst j lip) + (move cfp-tn csp-tn t)) + + +(define-assembly-routine (generic-= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst or temp x y) + (inst and temp fixnum-tag-mask) + (inst bne temp DO-STATIC-FUN) + (inst nop) + + (inst bne x y DONE) + (move res null-tn t) + (load-symbol res t) + + DONE + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst lw lip null-tn (static-fun-offset 'two-arg-=)) + (inst li nargs (fixnumize 2)) + (move ocfp cfp-tn) + (inst j lip) + (move cfp-tn csp-tn t)) + + +(define-assembly-routine (generic-/= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate /=) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst or temp x y) + (inst and temp fixnum-tag-mask) + (inst bne temp DO-STATIC-FUN) + (inst nop) + + (inst beq x y DONE) + (move res null-tn t) + (load-symbol res t) + + DONE + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst lw lip null-tn (static-fun-offset 'two-arg-/=)) + (inst li nargs (fixnumize 2)) + (move ocfp cfp-tn) + (inst j lip) + (move cfp-tn csp-tn t)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/mips/array.lisp sbcl-0.9.14/src/compiler/assembly/mips/array.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/mips/array.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/mips/array.lisp 2005-08-19 18:21:02.000000000 -0400 @@ -0,0 +1,40 @@ +;;;; various array operations that are too expensive (in space) to do +;;;; inline + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +(define-assembly-routine (allocate-vector + (:policy :fast-safe) + (:translate allocate-vector) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum)) + ((:arg type any-reg a0-offset) + (:arg length any-reg a1-offset) + (:arg words any-reg a2-offset) + (:res result descriptor-reg a0-offset) + + (:temp ndescr non-descriptor-reg nl0-offset) + (:temp pa-flag non-descriptor-reg nl4-offset)) + ;; This is kinda sleezy, changing words like this. But we can because + ;; the vop thinks it is temporary. + (inst addu words (+ lowtag-mask + (* vector-data-offset n-word-bytes))) + (inst srl ndescr type word-shift) + (inst srl words n-lowtag-bits) + (inst sll words n-lowtag-bits) + + (pseudo-atomic (pa-flag) + (inst or result alloc-tn other-pointer-lowtag) + (inst addu alloc-tn words) + (storew ndescr result 0 other-pointer-lowtag) + (storew length result vector-length-slot other-pointer-lowtag))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/mips/assem-rtns.lisp sbcl-0.9.14/src/compiler/assembly/mips/assem-rtns.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/mips/assem-rtns.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/mips/assem-rtns.lisp 2006-05-13 12:18:40.000000000 -0400 @@ -0,0 +1,218 @@ +(in-package "SB!VM") + + +;;;; Return-multiple with other than one value + +#+sb-assembling ;; we don't want a vop for this one. +(define-assembly-routine + (return-multiple + (:return-style :none)) + + ;; These four are really arguments. + ((:temp nvals any-reg nargs-offset) + (:temp vals any-reg nl0-offset) + (:temp ocfp any-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + + ;; These are just needed to facilitate the transfer + (:temp lip interior-reg lip-offset) + (:temp count any-reg nl2-offset) + (:temp dst any-reg nl3-offset) + (:temp temp descriptor-reg l0-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset) + (:temp a4 descriptor-reg a4-offset) + (:temp a5 descriptor-reg a5-offset)) + + ;; Note, because of the way the return-multiple vop is written, we can + ;; assume that we are never called with nvals == 1 and that a0 has already + ;; been loaded. + (inst blez nvals DEFAULT-A0-AND-ON) + (inst subu count nvals (fixnumize 2)) + (inst blez count DEFAULT-A2-AND-ON) + (inst lw a1 vals (* 1 n-word-bytes)) + (inst subu count (fixnumize 1)) + (inst blez count DEFAULT-A3-AND-ON) + (inst lw a2 vals (* 2 n-word-bytes)) + (inst subu count (fixnumize 1)) + (inst blez count DEFAULT-A4-AND-ON) + (inst lw a3 vals (* 3 n-word-bytes)) + (inst subu count (fixnumize 1)) + (inst blez count DEFAULT-A5-AND-ON) + (inst lw a4 vals (* 4 n-word-bytes)) + (inst subu count (fixnumize 1)) + (inst blez count done) + (inst lw a5 vals (* 5 n-word-bytes)) + + ;; Copy the remaining args to the top of the stack. + (inst addu vals (fixnumize register-arg-count)) + (inst addu dst cfp-tn (fixnumize register-arg-count)) + + LOOP + (inst lw temp vals) + (inst addu vals n-word-bytes) + (inst subu count (fixnumize 1)) + (inst sw temp dst) + (inst bne count LOOP) + (inst addu dst n-word-bytes) + + (inst b DONE) + (inst nop) + + DEFAULT-A0-AND-ON + (move a0 null-tn) + (move a1 null-tn) + DEFAULT-A2-AND-ON + (move a2 null-tn) + DEFAULT-A3-AND-ON + (move a3 null-tn) + DEFAULT-A4-AND-ON + (move a4 null-tn) + DEFAULT-A5-AND-ON + (move a5 null-tn) + DONE + + ;; Clear the stack. + (move ocfp-tn cfp-tn) + (move cfp-tn ocfp) + (inst addu csp-tn ocfp-tn nvals) + + ;; Return. + (lisp-return lra lip)) + + +;;;; tail-call-variable. + +#+sb-assembling ;; no vop for this one either. +(define-assembly-routine + (tail-call-variable + (:return-style :none)) + + ;; These are really args. + ((:temp args any-reg nl0-offset) + (:temp lexenv descriptor-reg lexenv-offset) + + ;; We need to compute this + (:temp nargs any-reg nargs-offset) + + ;; These are needed by the blitting code. + (:temp src any-reg nl1-offset) + (:temp dst any-reg nl2-offset) + (:temp count any-reg nl3-offset) + (:temp temp descriptor-reg l0-offset) + + ;; Needed for the jump + (:temp lip interior-reg lip-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset) + (:temp a4 descriptor-reg a4-offset) + (:temp a5 descriptor-reg a5-offset)) + + + ;; Calculate NARGS (as a fixnum) + (inst subu nargs csp-tn args) + + ;; Load the argument regs (must do this now, 'cause the blt might + ;; trash these locations) + (inst lw a0 args (* 0 n-word-bytes)) + (inst lw a1 args (* 1 n-word-bytes)) + (inst lw a2 args (* 2 n-word-bytes)) + (inst lw a3 args (* 3 n-word-bytes)) + (inst lw a4 args (* 4 n-word-bytes)) + (inst lw a5 args (* 5 n-word-bytes)) + + ;; Calc SRC, DST, and COUNT + (inst subu count nargs (fixnumize register-arg-count)) + (inst blez count done) + (inst addu src args (fixnumize register-arg-count)) + (inst addu dst cfp-tn (fixnumize register-arg-count)) + + LOOP + ;; Copy one arg. + (inst lw temp src) + (inst addu src n-word-bytes) + (inst subu count (fixnumize 1)) + (inst sw temp dst) + (inst bgtz count LOOP) + (inst addu dst n-word-bytes) + + DONE + ;; We are done. Do the jump. + (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) + (lisp-jump temp lip)) + + +;;;; Non-local exit noise. + +(define-assembly-routine + (unwind + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) a0-offset) + (:arg start (any-reg descriptor-reg) ocfp-offset) + (:arg count (any-reg descriptor-reg) nargs-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp cur-uwp any-reg nl0-offset) + (:temp next-uwp any-reg nl1-offset) + (:temp target-uwp any-reg nl2-offset)) + (declare (ignore start count)) + + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst beq block error) + (inst nop)) + + (load-symbol-value cur-uwp *current-unwind-protect-block*) + (loadw target-uwp block unwind-block-current-uwp-slot) + (inst bne cur-uwp target-uwp DO-UWP) + (inst nop) + + (move cur-uwp block) + + DO-EXIT + (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) + (loadw code-tn cur-uwp unwind-block-current-code-slot) + (loadw lra cur-uwp unwind-block-entry-pc-slot) + (lisp-return lra lip :frob-code nil) + + DO-UWP + (loadw next-uwp cur-uwp unwind-block-current-uwp-slot) + (inst b DO-EXIT) + (store-symbol-value next-uwp *current-unwind-protect-block*)) + +(define-assembly-routine + (throw + (:return-style :none)) + ((:arg target descriptor-reg a0-offset) + (:arg start any-reg ocfp-offset) + (:arg count any-reg nargs-offset) + (:temp catch any-reg a1-offset) + (:temp tag descriptor-reg a2-offset)) + + (declare (ignore start count)) ; We only need them in the registers. + + (load-symbol-value catch *current-catch-block*) + + LOOP + (let ((error (generate-error-code nil unseen-throw-tag-error target))) + (inst beq catch error) + (inst nop)) + + (loadw tag catch catch-block-tag-slot) + (inst beq tag target EXIT) + (inst nop) + (inst b LOOP) + (loadw catch catch catch-block-previous-catch-slot) + + EXIT + (inst j (make-fixup 'unwind :assembly-routine)) + (move target catch t)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/mips/support.lisp sbcl-0.9.14/src/compiler/assembly/mips/support.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/mips/support.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/mips/support.lisp 2005-07-14 12:30:11.000000000 -0400 @@ -0,0 +1,66 @@ +;;;; the machine-specific support routines needed by the file assembler + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +(!def-vm-support-routine generate-call-sequence (name style vop) + (ecase style + ((:raw :none) + (values + `((inst jal (make-fixup ',name :assembly-routine)) + (inst nop)) + `())) + (:full-call + (let ((temp (make-symbol "TEMP")) + (nfp-save (make-symbol "NFP-SAVE")) + (lra (make-symbol "LRA"))) + (values + `((let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn ,vop))) + (when cur-nfp + (store-stack-tn ,nfp-save cur-nfp)) + (inst compute-lra-from-code ,lra code-tn lra-label ,temp) + (note-next-instruction ,vop :call-site) + (inst j (make-fixup ',name :assembly-routine)) + (inst nop) + (without-scheduling () + (emit-return-pc lra-label) + (note-this-location ,vop :single-value-return) + (inst move csp-tn ocfp-tn) + (inst nop)) + (inst compute-code-from-lra code-tn code-tn + lra-label ,temp) + (when cur-nfp + (load-stack-tn cur-nfp ,nfp-save)))) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:sc descriptor-reg :offset lra-offset + :from (:eval 0) :to (:eval 1)) + ,lra) + (:temporary (:scs (control-stack) :offset nfp-save-offset) + ,nfp-save) + (:save-p t))))))) + +(!def-vm-support-routine generate-return-sequence (style) + (ecase style + (:raw + `((inst j lip-tn) + (inst nop))) + (:full-call + `((lisp-return (make-random-tn :kind :normal + :sc (sc-or-lose + 'descriptor-reg) + :offset lra-offset) + lip-tn :offset 2))) + (:none))) + +(defun return-machine-address (scp) + (context-register scp lip-offset)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/ppc/alloc.lisp sbcl-0.9.14/src/compiler/assembly/ppc/alloc.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/ppc/alloc.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/ppc/alloc.lisp 2002-03-18 12:56:12.000000000 -0500 @@ -0,0 +1,3 @@ +(in-package "SB!VM") + +;;; But we do everything inline now that we have a better pseudo-atomic. diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/ppc/arith.lisp sbcl-0.9.14/src/compiler/assembly/ppc/arith.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/ppc/arith.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/ppc/arith.lisp 2006-02-21 17:59:31.000000000 -0500 @@ -0,0 +1,429 @@ +(in-package "SB!VM") + + + +;;;; Addition and subtraction. + +;;; static-fun-offset returns the address of the raw_addr slot of +;;; a static function's fdefn. + +;;; Note that there is only one use of static-fun-offset outside this +;;; file (in genesis.lisp) + +(define-assembly-routine + (generic-+ + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp flag non-descriptor-reg nl3-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp lip interior-reg lip-offset) + (:temp ocfp any-reg ocfp-offset)) + + ; Clear the damned "sticky overflow" bit in :cr0 and :xer + (inst mtxer zero-tn) + (inst or temp x y) + (inst andi. temp temp 3) + (inst bne DO-STATIC-FUN) + (inst addo. temp x y) + (inst bns done) + + (inst srawi temp x 2) + (inst srawi temp2 y 2) + (inst add temp2 temp2 temp) + (with-fixed-allocation (res flag temp bignum-widetag (1+ bignum-digits-offset)) + (storew temp2 res bignum-digits-offset other-pointer-lowtag)) + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst lwz lip null-tn (static-fun-offset 'two-arg-+) ) + (inst li nargs (fixnumize 2)) + (inst mr ocfp cfp-tn) + (inst mr cfp-tn csp-tn) + (inst j lip 0) + + DONE + (move res temp)) + + +(define-assembly-routine + (generic-- + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp flag non-descriptor-reg nl3-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + + ; Clear the damned "sticky overflow" bit in :cr0 + (inst mtxer zero-tn) + + (inst or temp x y) + (inst andi. temp temp 3) + (inst bne DO-STATIC-FUN) + + (inst subo. temp x y) + (inst bns done) + + (inst srawi temp x 2) + (inst srawi temp2 y 2) + (inst sub temp2 temp temp2) + (with-fixed-allocation (res flag temp bignum-widetag (1+ bignum-digits-offset)) + (storew temp2 res bignum-digits-offset other-pointer-lowtag)) + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst lwz lip null-tn (static-fun-offset 'two-arg--)) + (inst li nargs (fixnumize 2)) + (inst mr ocfp cfp-tn) + (inst mr cfp-tn csp-tn) + (inst j lip 0) + + DONE + (move res temp)) + + + +;;;; Multiplication + + +(define-assembly-routine + (generic-* + (:cost 50) + (:return-style :full-call) + (:translate *) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lo non-descriptor-reg nl1-offset) + (:temp hi non-descriptor-reg nl2-offset) + (:temp pa-flag non-descriptor-reg nl3-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + + ;; If either arg is not a fixnum, call the static function. But first ... + (inst mtxer zero-tn) + + (inst or temp x y) + (inst andi. temp temp 3) + ;; Remove the tag from both args, so I don't get so confused. + (inst srawi temp x 2) + (inst srawi nargs y 2) + (inst bne DO-STATIC-FUN) + + + (inst mullwo. lo nargs temp) + (inst srawi hi lo 31) ; hi = 32 copies of lo's sign bit + (inst bns ONE-WORD-ANSWER) + (inst mulhw hi nargs temp) + (inst b CONS-BIGNUM) + + ONE-WORD-ANSWER ; We know that all of the overflow bits are clear. + (inst addo temp lo lo) + (inst addo. res temp temp) + (inst bns GO-HOME) + + CONS-BIGNUM + ;; Allocate a BIGNUM for the result. + (with-fixed-allocation (res pa-flag temp bignum-widetag + (+ bignum-digits-offset 2)) + (let ((one-word (gen-label))) + ;; We start out assuming that we need one word. Is that correct? + (inst srawi temp lo 31) + (inst xor. temp temp hi) + (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag)) + (inst beq one-word) + (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag)) + (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag) + (emit-label one-word) + (storew temp res 0 other-pointer-lowtag) + (storew lo res bignum-digits-offset other-pointer-lowtag))) + ;; Out of here + GO-HOME + (lisp-return lra lip :offset 2) + + DO-STATIC-FUN + (inst lwz lip null-tn (static-fun-offset 'two-arg-*)) + (inst li nargs (fixnumize 2)) + (inst mr ocfp cfp-tn) + (inst mr cfp-tn csp-tn) + (inst j lip 0) + + LOW-FITS-IN-FIXNUM + (move res lo)) + +(macrolet + ((frob (name note cost type sc) + `(define-assembly-routine (,name + (:note ,note) + (:cost ,cost) + (:translate *) + (:policy :fast-safe) + (:arg-types ,type ,type) + (:result-types ,type)) + ((:arg x ,sc nl0-offset) + (:arg y ,sc nl1-offset) + (:res res ,sc nl0-offset)) + ,@(when (eq type 'tagged-num) + `((inst srawi x x 2))) + (inst mullw res x y)))) + (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg) + (frob signed-* "signed *" 41 signed-num signed-reg) + (frob fixnum-* "fixnum *" 30 tagged-num any-reg)) + + + +;;;; Division. + + +(define-assembly-routine (positive-fixnum-truncate + (:note "unsigned fixnum truncate") + (:cost 45) + (:translate truncate) + (:policy :fast-safe) + (:arg-types positive-fixnum positive-fixnum) + (:result-types positive-fixnum positive-fixnum)) + ((:arg dividend any-reg nl0-offset) + (:arg divisor any-reg nl1-offset) + + (:res quo any-reg nl2-offset) + (:res rem any-reg nl0-offset)) + (aver (location= rem dividend)) + (let ((error (generate-error-code nil division-by-zero-error + dividend divisor))) + (inst cmpwi divisor 0) + (inst beq error)) + (inst divwu quo dividend divisor) + (inst mullw divisor quo divisor) + (inst sub rem dividend divisor) + (inst slwi quo quo 2)) + + + +(define-assembly-routine (fixnum-truncate + (:note "fixnum truncate") + (:cost 50) + (:policy :fast-safe) + (:translate truncate) + (:arg-types tagged-num tagged-num) + (:result-types tagged-num tagged-num)) + ((:arg dividend any-reg nl0-offset) + (:arg divisor any-reg nl1-offset) + + (:res quo any-reg nl2-offset) + (:res rem any-reg nl0-offset)) + + (aver (location= rem dividend)) + (let ((error (generate-error-code nil division-by-zero-error + dividend divisor))) + (inst cmpwi divisor 0) + (inst beq error)) + + (inst divw quo dividend divisor) + (inst mullw divisor quo divisor) + (inst subf rem divisor dividend) + (inst slwi quo quo 2)) + + +(define-assembly-routine (signed-truncate + (:note "(signed-byte 32) truncate") + (:cost 60) + (:policy :fast-safe) + (:translate truncate) + (:arg-types signed-num signed-num) + (:result-types signed-num signed-num)) + + ((:arg dividend signed-reg nl0-offset) + (:arg divisor signed-reg nl1-offset) + + (:res quo signed-reg nl2-offset) + (:res rem signed-reg nl0-offset)) + + (let ((error (generate-error-code nil division-by-zero-error + dividend divisor))) + (inst cmpwi divisor 0) + (inst beq error)) + + (inst divw quo dividend divisor) + (inst mullw divisor quo divisor) + (inst subf rem divisor dividend)) + + +;;;; Comparison + +(macrolet + ((define-cond-assem-rtn (name translate static-fn cmp) + `(define-assembly-routine + (,name + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + + (inst or nargs x y) + (inst andi. nargs nargs 3) + (inst cmpw :cr1 x y) + (inst beq DO-COMPARE) + + DO-STATIC-FN + (inst lwz lip null-tn (static-fun-offset ',static-fn)) + (inst li nargs (fixnumize 2)) + (inst mr ocfp cfp-tn) + (inst mr cfp-tn csp-tn) + (inst j lip 0) + + DO-COMPARE + (load-symbol res t) + (inst b? :cr1 ,cmp done) + (inst mr res null-tn) + DONE))) + + (define-cond-assem-rtn generic-< < two-arg-< :lt) + (define-cond-assem-rtn generic-<= <= two-arg-<= :le) + (define-cond-assem-rtn generic-> > two-arg-> :gt) + (define-cond-assem-rtn generic->= >= two-arg->= :ge)) + + +(define-assembly-routine (generic-eql + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst cmpw :cr1 x y) + (inst andi. nargs x 3) + (inst beq :cr1 RETURN-T) + (inst beq RETURN-NIL) ; x was fixnum, not eq y + (inst andi. nargs y 3) + (inst bne DO-STATIC-FN) + + RETURN-NIL + (inst mr res null-tn) + (lisp-return lra lip :offset 2) + + DO-STATIC-FN + (inst lwz lip null-tn (static-fun-offset 'eql)) + (inst li nargs (fixnumize 2)) + (inst mr ocfp cfp-tn) + (inst mr cfp-tn csp-tn) + (inst j lip 0) + + RETURN-T + (load-symbol res t)) + +(define-assembly-routine + (generic-= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + + (inst or nargs x y) + (inst andi. nargs nargs 3) + (inst cmpw :cr1 x y) + (inst bne DO-STATIC-FN) + (inst beq :cr1 RETURN-T) + + (inst mr res null-tn) + (lisp-return lra lip :offset 2) + + DO-STATIC-FN + (inst lwz lip null-tn (static-fun-offset 'two-arg-=)) + (inst li nargs (fixnumize 2)) + (inst mr ocfp cfp-tn) + (inst mr cfp-tn csp-tn) + (inst j lip 0) + + RETURN-T + (load-symbol res t)) + +(define-assembly-routine (generic-/= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate /=) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst or nargs x y) + (inst andi. nargs nargs 3) + (inst cmpw :cr1 x y) + (inst bne DO-STATIC-FN) + (inst beq :cr1 RETURN-NIL) + + (load-symbol res t) + (lisp-return lra lip :offset 2) + + DO-STATIC-FN + (inst lwz lip null-tn (static-fun-offset 'two-arg-/=)) + (inst li nargs (fixnumize 2)) + (inst mr ocfp cfp-tn) + (inst j lip 0) + (inst mr cfp-tn csp-tn) + + RETURN-NIL + (inst mr res null-tn)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/ppc/array.lisp sbcl-0.9.14/src/compiler/assembly/ppc/array.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/ppc/array.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/ppc/array.lisp 2006-02-21 17:59:31.000000000 -0500 @@ -0,0 +1,51 @@ +;;;; various array operations that are too expensive (in space) to do +;;;; inline + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +(define-assembly-routine (allocate-vector + (:policy :fast-safe) + (:translate allocate-vector) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum)) + ((:arg type any-reg a0-offset) + (:arg length any-reg a1-offset) + (:arg words any-reg a2-offset) + (:res result descriptor-reg a0-offset) + + (:temp ndescr non-descriptor-reg nl0-offset) + (:temp pa-flag non-descriptor-reg nl3-offset) + (:temp vector descriptor-reg a3-offset) + (:temp temp non-descriptor-reg nl2-offset)) + (pseudo-atomic (pa-flag) + ;; boxed words == unboxed bytes + (inst addi ndescr words (* (1+ vector-data-offset) n-word-bytes)) + (inst clrrwi ndescr ndescr n-lowtag-bits) + (allocation vector ndescr other-pointer-lowtag + :temp-tn temp + :flag-tn pa-flag) + (inst srwi ndescr type word-shift) + (storew ndescr vector 0 other-pointer-lowtag) + (storew length vector vector-length-slot other-pointer-lowtag)) + ;; This makes sure the zero byte at the end of a string is paged in so + ;; the kernel doesn't bitch if we pass it the string. + ;; + ;; rtoy says to turn this off as it causes problems with CMUCL. + ;; + ;; I don't think we need to do this anymore. It looks like this + ;; inherited from the SPARC port and does not seem to be + ;; necessary. Turning this on worked at some point, but I have not + ;; tested with the final GENGC-related changes. CLH 20060221 + ;; + ;; (storew zero-tn alloc-tn 0) + (move result vector)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/ppc/assem-rtns.lisp sbcl-0.9.14/src/compiler/assembly/ppc/assem-rtns.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/ppc/assem-rtns.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/ppc/assem-rtns.lisp 2005-07-14 12:30:12.000000000 -0400 @@ -0,0 +1,210 @@ +(in-package "SB!VM") + + +;;;; Return-multiple with other than one value + +#+sb-assembling ;; we don't want a vop for this one. +(define-assembly-routine + (return-multiple + (:return-style :none)) + + ;; These four are really arguments. + ((:temp nvals any-reg nargs-offset) + (:temp vals any-reg nl0-offset) + (:temp ocfp any-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + + ;; These are just needed to facilitate the transfer + (:temp lip interior-reg lip-offset) + (:temp count any-reg nl2-offset) + (:temp src any-reg nl3-offset) + (:temp dst any-reg cfunc-offset) + (:temp temp descriptor-reg l0-offset) + + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset)) + + ;; Note, because of the way the return-multiple vop is written, we can + ;; assume that we are never called with nvals == 1 and that a0 has already + ;; been loaded. + (inst cmpwi nvals 0) + (inst ble default-a0-and-on) + (inst cmpwi nvals (fixnumize 2)) + (inst lwz a1 vals (* 1 n-word-bytes)) + (inst ble default-a2-and-on) + (inst cmpwi nvals (fixnumize 3)) + (inst lwz a2 vals (* 2 n-word-bytes)) + (inst ble default-a3-and-on) + (inst cmpwi nvals (fixnumize 4)) + (inst lwz a3 vals (* 3 n-word-bytes)) + (inst ble done) + + ;; Copy the remaining args to the top of the stack. + (inst addi src vals (* 4 n-word-bytes)) + (inst addi dst cfp-tn (* 4 n-word-bytes)) + (inst addic. count nvals (- (fixnumize 4))) + + LOOP + (inst subic. count count (fixnumize 1)) + (inst lwz temp src 0) + (inst addi src src n-word-bytes) + (inst stw temp dst 0) + (inst addi dst dst n-word-bytes) + (inst bge loop) + + (inst b done) + + DEFAULT-A0-AND-ON + (inst mr a0 null-tn) + (inst mr a1 null-tn) + DEFAULT-A2-AND-ON + (inst mr a2 null-tn) + DEFAULT-A3-AND-ON + (inst mr a3 null-tn) + DONE + + ;; Clear the stack. + (move ocfp-tn cfp-tn) + (move cfp-tn ocfp) + (inst add csp-tn ocfp-tn nvals) + + ;; Return. + (lisp-return lra lip)) + + + +;;;; tail-call-variable. + +#+sb-assembling ;; no vop for this one either. +(define-assembly-routine + (tail-call-variable + (:return-style :none)) + + ;; These are really args. + ((:temp args any-reg nl0-offset) + (:temp lexenv descriptor-reg lexenv-offset) + + ;; We need to compute this + (:temp nargs any-reg nargs-offset) + + ;; These are needed by the blitting code. + (:temp src any-reg nl1-offset) + (:temp dst any-reg nl2-offset) + (:temp count any-reg nl3-offset) + (:temp temp descriptor-reg l0-offset) + (:temp lip interior-reg lip-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset)) + + + ;; Calculate NARGS (as a fixnum) + (inst sub nargs csp-tn args) + + ;; Load the argument regs (must do this now, 'cause the blt might + ;; trash these locations) + (inst lwz a0 args (* 0 n-word-bytes)) + (inst lwz a1 args (* 1 n-word-bytes)) + (inst lwz a2 args (* 2 n-word-bytes)) + (inst lwz a3 args (* 3 n-word-bytes)) + + ;; Calc SRC, DST, and COUNT + (inst addic. count nargs (fixnumize (- register-arg-count))) + (inst addi src args (* n-word-bytes register-arg-count)) + (inst ble done) + (inst addi dst cfp-tn (* n-word-bytes register-arg-count)) + + LOOP + ;; Copy one arg. + (inst lwz temp src 0) + (inst addi src src n-word-bytes) + (inst stw temp dst 0) + (inst addic. count count (fixnumize -1)) + (inst addi dst dst n-word-bytes) + (inst bgt loop) + + DONE + ;; We are done. Do the jump. + (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) + (lisp-jump temp lip)) + + + +;;;; Non-local exit noise. + +(define-assembly-routine (unwind + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) a0-offset) + (:arg start (any-reg descriptor-reg) ocfp-offset) + (:arg count (any-reg descriptor-reg) nargs-offset) + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + (:temp cur-uwp any-reg nl0-offset) + (:temp next-uwp any-reg nl1-offset) + (:temp target-uwp any-reg nl2-offset)) + (declare (ignore start count)) + + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst cmpwi block 0) + (inst beq error)) + + (load-symbol-value cur-uwp *current-unwind-protect-block*) + (loadw target-uwp block unwind-block-current-uwp-slot) + (inst cmpw cur-uwp target-uwp) + (inst bne do-uwp) + + (move cur-uwp block) + + DO-EXIT + + (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) + (loadw code-tn cur-uwp unwind-block-current-code-slot) + (loadw lra cur-uwp unwind-block-entry-pc-slot) + (lisp-return lra lip :frob-code nil) + + DO-UWP + + (loadw next-uwp cur-uwp unwind-block-current-uwp-slot) + (store-symbol-value next-uwp *current-unwind-protect-block*) + (inst b do-exit)) + +(define-assembly-routine (throw + (:return-style :none)) + ((:arg target descriptor-reg a0-offset) + (:arg start any-reg ocfp-offset) + (:arg count any-reg nargs-offset) + (:temp catch any-reg a1-offset) + (:temp tag descriptor-reg a2-offset)) + + (declare (ignore start count)) + + (load-symbol-value catch *current-catch-block*) + + loop + + (let ((error (generate-error-code nil unseen-throw-tag-error target))) + (inst cmpwi catch 0) + (inst beq error)) + + (loadw tag catch catch-block-tag-slot) + (inst cmpw tag target) + (inst beq exit) + (loadw catch catch catch-block-previous-catch-slot) + (inst b loop) + + exit + + (move target catch) + (inst ba (make-fixup 'unwind :assembly-routine))) + + + diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/ppc/support.lisp sbcl-0.9.14/src/compiler/assembly/ppc/support.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/ppc/support.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/ppc/support.lisp 2005-07-14 12:30:12.000000000 -0400 @@ -0,0 +1,65 @@ +;;;; the machine-specific support routines needed by the file assembler + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +(!def-vm-support-routine generate-call-sequence (name style vop) + (ecase style + ((:raw :none) + (values + `((inst bla (make-fixup ',name :assembly-routine))) + `())) + (:full-call + (let ((temp (make-symbol "TEMP")) + (nfp-save (make-symbol "NFP-SAVE")) + (lra (make-symbol "LRA"))) + (values + `((let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn ,vop))) + (when cur-nfp + (store-stack-tn ,nfp-save cur-nfp)) + (inst compute-lra-from-code ,lra code-tn lra-label ,temp) + (note-next-instruction ,vop :call-site) + (inst ba (make-fixup ',name :assembly-routine)) + (emit-return-pc lra-label) + (note-this-location ,vop :single-value-return) + (without-scheduling () + (move csp-tn ocfp-tn) + (inst nop)) + (inst compute-code-from-lra code-tn code-tn + lra-label ,temp) + (when cur-nfp + (load-stack-tn cur-nfp ,nfp-save)))) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:sc descriptor-reg :offset lra-offset + :from (:eval 0) :to (:eval 1)) + ,lra) + (:temporary (:scs (control-stack) :offset nfp-save-offset) + ,nfp-save) + (:save-p :compute-only))))))) + +(!def-vm-support-routine generate-return-sequence (style) + (ecase style + (:raw + `((inst blr))) + (:full-call + `((lisp-return (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg ) + :offset lra-offset) + (make-random-tn :kind :normal + :sc (sc-or-lose 'interior-reg ) + :offset lip-offset) + :offset 2))) + (:none))) + +(defun return-machine-address (scp) + (sap-int (context-lr scp))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/sparc/alloc.lisp sbcl-0.9.14/src/compiler/assembly/sparc/alloc.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/sparc/alloc.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/sparc/alloc.lisp 2002-02-15 12:10:02.000000000 -0500 @@ -0,0 +1,16 @@ +;;;; stuff to handle allocation of stuff we don't want to do inline + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;; (Given that the pseudo-atomic sequence is so short, there is +;;; nothing that qualifies. But we want to keep the file around +;;; in case we decide to add something later.) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/sparc/arith.lisp sbcl-0.9.14/src/compiler/assembly/sparc/arith.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/sparc/arith.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/sparc/arith.lisp 2005-08-16 11:16:00.000000000 -0400 @@ -0,0 +1,563 @@ +;;;; Stuff to handle simple cases for generic arithmetic. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; Addition and subtraction. + +(define-assembly-routine (generic-+ + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst andcc zero-tn x fixnum-tag-mask) + (inst b :ne DO-STATIC-FUN) + (inst andcc zero-tn y fixnum-tag-mask) + (inst b :ne DO-STATIC-FUN) + (inst nop) + (inst addcc temp x y) + (inst b :vc done) + (inst nop) + + (inst sra temp x n-fixnum-tag-bits) + (inst sra temp2 y n-fixnum-tag-bits) + (inst add temp2 temp) + (with-fixed-allocation (res temp bignum-widetag (1+ bignum-digits-offset)) + (storew temp2 res bignum-digits-offset other-pointer-lowtag)) + (lisp-return lra :offset 2) + + DO-STATIC-FUN + (inst ld code-tn null-tn (static-fun-offset 'two-arg-+)) + (inst li nargs (fixnumize 2)) + (inst move ocfp cfp-tn) + (inst j code-tn + (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) + (inst move cfp-tn csp-tn) + + DONE + (move res temp)) + + +(define-assembly-routine (generic-- + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst andcc zero-tn x fixnum-tag-mask) + (inst b :ne DO-STATIC-FUN) + (inst andcc zero-tn y fixnum-tag-mask) + (inst b :ne DO-STATIC-FUN) + (inst nop) + (inst subcc temp x y) + (inst b :vc done) + (inst nop) + + (inst sra temp x n-fixnum-tag-bits) + (inst sra temp2 y n-fixnum-tag-bits) + (inst sub temp2 temp temp2) + (with-fixed-allocation (res temp bignum-widetag (1+ bignum-digits-offset)) + (storew temp2 res bignum-digits-offset other-pointer-lowtag)) + (lisp-return lra :offset 2) + + DO-STATIC-FUN + (inst ld code-tn null-tn (static-fun-offset 'two-arg--)) + (inst li nargs (fixnumize 2)) + (inst move ocfp cfp-tn) + (inst j code-tn + (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) + (inst move cfp-tn csp-tn) + + DONE + (move res temp)) + + + +;;;; Multiplication + + +(define-assembly-routine (generic-* + (:cost 50) + (:return-style :full-call) + (:translate *) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lo non-descriptor-reg nl1-offset) + (:temp hi non-descriptor-reg nl2-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + ;; If either arg is not a fixnum, call the static function. + (inst andcc zero-tn x fixnum-tag-mask) + (inst b :ne DO-STATIC-FUN) + (inst andcc zero-tn y fixnum-tag-mask) + (inst b :ne DO-STATIC-FUN) + (inst nop) + + ;; Remove the tag from one arg so that the result will have the correct + ;; fixnum tag. + (inst sra temp x n-fixnum-tag-bits) + ;; Compute the produce temp * y and return the double-word product + ;; in hi:lo. + (cond + ((member :sparc-64 *backend-subfeatures*) + ;; Sign extend y to a full 64-bits. temp was already + ;; sign-extended by the sra instruction above. + (inst sra y 0) + (inst mulx hi temp y) + (inst move lo hi) + (inst srax hi 32)) + ((or (member :sparc-v8 *backend-subfeatures*) + (member :sparc-v9 *backend-subfeatures*)) + (inst smul lo temp y) + (inst rdy hi)) + (t + (let ((MULTIPLIER-POSITIVE (gen-label))) + (inst wry temp) + (inst andcc hi zero-tn) + (inst nop) + (inst nop) + (dotimes (i 32) + (inst mulscc hi y)) + (inst mulscc hi zero-tn) + (inst cmp x) + (inst b :ge MULTIPLIER-POSITIVE) + (inst nop) + (inst sub hi y) + (emit-label MULTIPLIER-POSITIVE) + (inst rdy lo)))) + ;; Check to see if the result will fit in a fixnum. (I.e. the high word + ;; is just 32 copies of the sign bit of the low word). + (inst sra temp lo 31) + (inst xorcc temp hi) + (inst b :eq LOW-FITS-IN-FIXNUM) + ;; Shift the double word hi:lo down two bits to get rid of the fixnum tag. + (inst sll temp hi 30) + (inst srl lo n-fixnum-tag-bits) + (inst or lo temp) + (inst sra hi n-fixnum-tag-bits) + ;; Allocate a BIGNUM for the result. + #+nil + (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset))) + (let ((one-word (gen-label))) + (inst or res alloc-tn other-pointer-lowtag) + ;; We start out assuming that we need one word. Is that correct? + (inst sra temp lo 31) + (inst xorcc temp hi) + (inst b :eq one-word) + (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag)) + ;; Nope, we need two, so allocate the addition space. + (inst add alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset)) + (pad-data-block (1+ bignum-digits-offset)))) + (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag)) + (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag) + (emit-label one-word) + (storew temp res 0 other-pointer-lowtag) + (storew lo res bignum-digits-offset other-pointer-lowtag))) + ;; Always allocate 2 words for the bignum result, even if we only + ;; need one. The copying GC will take care of the extra word if it + ;; isn't needed. + (with-fixed-allocation + (res temp bignum-widetag (+ 2 bignum-digits-offset)) + (let ((one-word (gen-label))) + (inst or res alloc-tn other-pointer-lowtag) + ;; We start out assuming that we need one word. Is that correct? + (inst sra temp lo 31) + (inst xorcc temp hi) + (inst b :eq one-word) + (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag)) + ;; Need 2 words. Set the header appropriately, and save the + ;; high and low parts. + (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag)) + (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag) + (emit-label one-word) + (storew temp res 0 other-pointer-lowtag) + (storew lo res bignum-digits-offset other-pointer-lowtag))) + ;; Out of here + (lisp-return lra :offset 2) + + DO-STATIC-FUN + (inst ld code-tn null-tn (static-fun-offset 'two-arg-*)) + (inst li nargs (fixnumize 2)) + (inst move ocfp cfp-tn) + (inst j code-tn + (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) + (inst move cfp-tn csp-tn) + + LOW-FITS-IN-FIXNUM + (move res lo)) + +(macrolet + ((frob (name note cost type sc) + `(define-assembly-routine (,name + (:note ,note) + (:cost ,cost) + (:translate *) + (:policy :fast-safe) + (:arg-types ,type ,type) + (:result-types ,type)) + ((:arg x ,sc nl0-offset) + (:arg y ,sc nl1-offset) + (:res res ,sc nl0-offset) + (:temp temp ,sc nl2-offset)) + ,@(when (eq type 'tagged-num) + `((inst sra x 2))) + (cond + ((member :sparc-64 *backend-subfeatures*) + ;; Sign extend, then multiply + (inst sra x 0) + (inst sra y 0) + (inst mulx res x y)) + ((or (member :sparc-v8 *backend-subfeatures*) + (member :sparc-v9 *backend-subfeatures*)) + (inst smul res x y)) + (t + (inst wry x) + (inst andcc temp zero-tn) + (inst nop) + (inst nop) + (dotimes (i 32) + (inst mulscc temp y)) + (inst mulscc temp zero-tn) + (inst rdy res)))))) + (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg) + (frob signed-* "signed *" 41 signed-num signed-reg) + (frob fixnum-* "fixnum *" 30 tagged-num any-reg)) + + + +;;;; Division. + +#+sb-assembling +(defun emit-divide-loop (divisor rem quo tagged) + (inst li quo 0) + (labels + ((do-loop (depth) + (cond + ((zerop depth) + (inst unimp 0)) + (t + (let ((label-1 (gen-label)) + (label-2 (gen-label))) + (inst cmp divisor rem) + (inst b :geu label-1) + (inst nop) + (inst sll divisor 1) + (do-loop (1- depth)) + (inst srl divisor 1) + (inst cmp divisor rem) + (emit-label label-1) + (inst b :gtu label-2) + (inst sll quo 1) + (inst add quo (if tagged (fixnumize 1) 1)) + (inst sub rem divisor) + (emit-label label-2)))))) + (do-loop (if tagged 30 32)))) + +(define-assembly-routine (positive-fixnum-truncate + (:note "unsigned fixnum truncate") + (:cost 45) + (:translate truncate) + (:policy :fast-safe) + (:arg-types positive-fixnum positive-fixnum) + (:result-types positive-fixnum positive-fixnum)) + ((:arg dividend any-reg nl0-offset) + (:arg divisor any-reg nl1-offset) + + (:res quo any-reg nl2-offset) + (:res rem any-reg nl0-offset)) + + (let ((error (generate-error-code nil division-by-zero-error + dividend divisor))) + (inst cmp divisor) + (inst b :eq error)) + + (move rem dividend) + (emit-divide-loop divisor rem quo t)) + + +(define-assembly-routine (fixnum-truncate + (:note "fixnum truncate") + (:cost 50) + (:policy :fast-safe) + (:translate truncate) + (:arg-types tagged-num tagged-num) + (:result-types tagged-num tagged-num)) + ((:arg dividend any-reg nl0-offset) + (:arg divisor any-reg nl1-offset) + + (:res quo any-reg nl2-offset) + (:res rem any-reg nl0-offset) + + (:temp quo-sign any-reg nl5-offset) + (:temp rem-sign any-reg nargs-offset)) + + (let ((error (generate-error-code nil division-by-zero-error + dividend divisor))) + (inst cmp divisor) + (inst b :eq error)) + + (inst xor quo-sign dividend divisor) + (inst move rem-sign dividend) + (let ((label (gen-label))) + (inst cmp dividend) + (inst ba :lt label) + (inst neg dividend) + (emit-label label)) + (let ((label (gen-label))) + (inst cmp divisor) + (inst ba :lt label) + (inst neg divisor) + (emit-label label)) + (move rem dividend) + (emit-divide-loop divisor rem quo t) + (let ((label (gen-label))) + ;; If the quo-sign is negative, we need to negate quo. + (inst cmp quo-sign) + (inst ba :lt label) + (inst neg quo) + (emit-label label)) + (let ((label (gen-label))) + ;; If the rem-sign is negative, we need to negate rem. + (inst cmp rem-sign) + (inst ba :lt label) + (inst neg rem) + (emit-label label))) + + +(define-assembly-routine (signed-truncate + (:note "(signed-byte 32) truncate") + (:cost 60) + (:policy :fast-safe) + (:translate truncate) + (:arg-types signed-num signed-num) + (:result-types signed-num signed-num)) + + ((:arg dividend signed-reg nl0-offset) + (:arg divisor signed-reg nl1-offset) + + (:res quo signed-reg nl2-offset) + (:res rem signed-reg nl0-offset) + + (:temp quo-sign signed-reg nl5-offset) + (:temp rem-sign signed-reg nargs-offset)) + + (let ((error (generate-error-code nil division-by-zero-error + dividend divisor))) + (inst cmp divisor) + (inst b :eq error)) + + (inst xor quo-sign dividend divisor) + (inst move rem-sign dividend) + (let ((label (gen-label))) + (inst cmp dividend) + (inst ba :lt label) + (inst neg dividend) + (emit-label label)) + (let ((label (gen-label))) + (inst cmp divisor) + (inst ba :lt label) + (inst neg divisor) + (emit-label label)) + (move rem dividend) + (emit-divide-loop divisor rem quo nil) + (let ((label (gen-label))) + ;; If the quo-sign is negative, we need to negate quo. + (inst cmp quo-sign) + (inst ba :lt label) + (inst neg quo) + (emit-label label)) + (let ((label (gen-label))) + ;; If the rem-sign is negative, we need to negate rem. + (inst cmp rem-sign) + (inst ba :lt label) + (inst neg rem) + (emit-label label))) + + +;;;; Comparison + +(macrolet + ((define-cond-assem-rtn (name translate static-fn cmp) + `(define-assembly-routine (,name + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst andcc zero-tn x fixnum-tag-mask) + (inst b :ne DO-STATIC-FN) + (inst andcc zero-tn y fixnum-tag-mask) + (inst b :eq DO-COMPARE) + (inst cmp x y) + + DO-STATIC-FN + (inst ld code-tn null-tn (static-fun-offset ',static-fn)) + (inst li nargs (fixnumize 2)) + (inst move ocfp cfp-tn) + (inst j code-tn + (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) + (inst move cfp-tn csp-tn) + + DO-COMPARE + (inst b ,cmp done) + (load-symbol res t) + (inst move res null-tn) + DONE))) + + (define-cond-assem-rtn generic-< < two-arg-< :lt) + (define-cond-assem-rtn generic-<= <= two-arg-<= :le) + (define-cond-assem-rtn generic-> > two-arg-> :gt) + (define-cond-assem-rtn generic->= >= two-arg->= :ge)) + + +(define-assembly-routine (generic-eql + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst cmp x y) + (inst b :eq RETURN-T) + (inst andcc zero-tn x fixnum-tag-mask) + (inst b :eq RETURN-NIL) + (inst andcc zero-tn y fixnum-tag-mask) + (inst b :ne DO-STATIC-FN) + (inst nop) + + RETURN-NIL + (inst move res null-tn) + (lisp-return lra :offset 2) + + DO-STATIC-FN + (inst ld code-tn null-tn (static-fun-offset 'eql)) + (inst li nargs (fixnumize 2)) + (inst move ocfp cfp-tn) + (inst j code-tn + (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) + (inst move cfp-tn csp-tn) + + RETURN-T + (load-symbol res t)) + +(define-assembly-routine (generic-= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst andcc zero-tn x fixnum-tag-mask) + (inst b :ne DO-STATIC-FN) + (inst andcc zero-tn y fixnum-tag-mask) + (inst b :ne DO-STATIC-FN) + (inst cmp x y) + (inst b :eq RETURN-T) + (inst nop) + + (inst move res null-tn) + (lisp-return lra :offset 2) + + DO-STATIC-FN + (inst ld code-tn null-tn (static-fun-offset 'two-arg-=)) + (inst li nargs (fixnumize 2)) + (inst move ocfp cfp-tn) + (inst j code-tn + (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) + (inst move cfp-tn csp-tn) + + RETURN-T + (load-symbol res t)) + +(define-assembly-routine (generic-/= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate /=) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst cmp x y) + (inst b :eq RETURN-NIL) + (inst andcc zero-tn x fixnum-tag-mask) + (inst b :ne DO-STATIC-FN) + (inst andcc zero-tn y fixnum-tag-mask) + (inst b :ne DO-STATIC-FN) + (inst nop) + + (load-symbol res t) + (lisp-return lra :offset 2) + + DO-STATIC-FN + (inst ld code-tn null-tn (static-fun-offset 'two-arg-/=)) + (inst li nargs (fixnumize 2)) + (inst move ocfp cfp-tn) + (inst j code-tn + (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) + (inst move cfp-tn csp-tn) + + RETURN-NIL + (inst move res null-tn)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/sparc/array.lisp sbcl-0.9.14/src/compiler/assembly/sparc/array.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/sparc/array.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/sparc/array.lisp 2005-07-14 12:30:12.000000000 -0400 @@ -0,0 +1,39 @@ +;;;; support routines for arrays and vectors + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +(define-assembly-routine (allocate-vector + (:policy :fast-safe) + (:translate allocate-vector) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum)) + ((:arg type any-reg a0-offset) + (:arg length any-reg a1-offset) + (:arg words any-reg a2-offset) + (:res result descriptor-reg a0-offset) + + (:temp ndescr non-descriptor-reg nl0-offset) + (:temp vector descriptor-reg a3-offset)) + (pseudo-atomic () + (inst or vector alloc-tn other-pointer-lowtag) + ;; boxed words == unboxed bytes + (inst add ndescr words (* (1+ vector-data-offset) n-word-bytes)) + (inst andn ndescr 7) + (inst add alloc-tn ndescr) + (inst srl ndescr type word-shift) + (storew ndescr vector 0 other-pointer-lowtag) + (storew length vector vector-length-slot other-pointer-lowtag)) + ;; This makes sure the zero byte at the end of a string is paged in so + ;; the kernel doesn't bitch if we pass it the string. + (storew zero-tn alloc-tn 0) + (move result vector)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/sparc/assem-rtns.lisp sbcl-0.9.14/src/compiler/assembly/sparc/assem-rtns.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/sparc/assem-rtns.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/sparc/assem-rtns.lisp 2005-07-14 12:30:12.000000000 -0400 @@ -0,0 +1,238 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; Return-multiple with other than one value + +#+sb-assembling ;; we don't want a vop for this one. +(define-assembly-routine + (return-multiple + (:return-style :none)) + + ;; These four are really arguments. + ((:temp nvals any-reg nargs-offset) + (:temp vals any-reg nl0-offset) + (:temp ocfp any-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + + ;; These are just needed to facilitate the transfer + (:temp count any-reg nl2-offset) + (:temp src any-reg nl3-offset) + (:temp dst any-reg nl4-offset) + (:temp temp descriptor-reg l0-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset) + (:temp a4 descriptor-reg a4-offset) + (:temp a5 descriptor-reg a5-offset)) + + ;; Note, because of the way the return-multiple vop is written, we can + ;; assume that we are never called with nvals == 1 and that a0 has already + ;; been loaded. + (inst cmp nvals) + (inst b :le default-a0-and-on) + (inst cmp nvals (fixnumize 2)) + (inst b :le default-a2-and-on) + (inst ld a1 vals (* 1 n-word-bytes)) + (inst cmp nvals (fixnumize 3)) + (inst b :le default-a3-and-on) + (inst ld a2 vals (* 2 n-word-bytes)) + (inst cmp nvals (fixnumize 4)) + (inst b :le default-a4-and-on) + (inst ld a3 vals (* 3 n-word-bytes)) + (inst cmp nvals (fixnumize 5)) + (inst b :le default-a5-and-on) + (inst ld a4 vals (* 4 n-word-bytes)) + (inst cmp nvals (fixnumize 6)) + (inst b :le done) + (inst ld a5 vals (* 5 n-word-bytes)) + + ;; Copy the remaining args to the top of the stack. + (inst add src vals (* 6 n-word-bytes)) + (inst add dst cfp-tn (* 6 n-word-bytes)) + (inst subcc count nvals (fixnumize 6)) + + LOOP + (inst ld temp src) + (inst add src n-word-bytes) + (inst st temp dst) + (inst add dst n-word-bytes) + (inst b :gt loop) + (inst subcc count (fixnumize 1)) + + (inst b done) + (inst nop) + + DEFAULT-A0-AND-ON + (inst move a0 null-tn) + (inst move a1 null-tn) + DEFAULT-A2-AND-ON + (inst move a2 null-tn) + DEFAULT-A3-AND-ON + (inst move a3 null-tn) + DEFAULT-A4-AND-ON + (inst move a4 null-tn) + DEFAULT-A5-AND-ON + (inst move a5 null-tn) + DONE + + ;; Clear the stack. + (move ocfp-tn cfp-tn) + (move cfp-tn ocfp) + (inst add csp-tn ocfp-tn nvals) + + ;; Return. + (lisp-return lra)) + + + +;;;; tail-call-variable. + +#+sb-assembling ;; no vop for this one either. +(define-assembly-routine + (tail-call-variable + (:return-style :none)) + + ;; These are really args. + ((:temp args any-reg nl0-offset) + (:temp lexenv descriptor-reg lexenv-offset) + + ;; We need to compute this + (:temp nargs any-reg nargs-offset) + + ;; These are needed by the blitting code. + (:temp src any-reg nl1-offset) + (:temp dst any-reg nl2-offset) + (:temp count any-reg nl3-offset) + (:temp temp descriptor-reg l0-offset) + + ;; These are needed so we can get at the register args. + (:temp a0 descriptor-reg a0-offset) + (:temp a1 descriptor-reg a1-offset) + (:temp a2 descriptor-reg a2-offset) + (:temp a3 descriptor-reg a3-offset) + (:temp a4 descriptor-reg a4-offset) + (:temp a5 descriptor-reg a5-offset)) + + + ;; Calculate NARGS (as a fixnum) + (inst sub nargs csp-tn args) + + ;; Load the argument regs (must do this now, 'cause the blt might + ;; trash these locations) + (inst ld a0 args (* 0 n-word-bytes)) + (inst ld a1 args (* 1 n-word-bytes)) + (inst ld a2 args (* 2 n-word-bytes)) + (inst ld a3 args (* 3 n-word-bytes)) + (inst ld a4 args (* 4 n-word-bytes)) + (inst ld a5 args (* 5 n-word-bytes)) + + ;; Calc SRC, DST, and COUNT + (inst addcc count nargs (fixnumize (- register-arg-count))) + (inst b :le done) + (inst add src args (* n-word-bytes register-arg-count)) + (inst add dst cfp-tn (* n-word-bytes register-arg-count)) + + LOOP + ;; Copy one arg. + (inst ld temp src) + (inst add src src n-word-bytes) + (inst st temp dst) + (inst addcc count (fixnumize -1)) + (inst b :gt loop) + (inst add dst dst n-word-bytes) + + DONE + ;; We are done. Do the jump. + (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) + (lisp-jump temp)) + + + +;;;; Non-local exit noise. + +(define-assembly-routine (unwind + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) a0-offset) + (:arg start (any-reg descriptor-reg) ocfp-offset) + (:arg count (any-reg descriptor-reg) nargs-offset) + (:temp lra descriptor-reg lra-offset) + (:temp cur-uwp any-reg nl0-offset) + (:temp next-uwp any-reg nl1-offset) + (:temp target-uwp any-reg nl2-offset)) + (declare (ignore start count)) + + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst cmp block) + (inst b :eq error)) + + (load-symbol-value cur-uwp *current-unwind-protect-block*) + (loadw target-uwp block unwind-block-current-uwp-slot) + (inst cmp cur-uwp target-uwp) + (inst b :ne do-uwp) + (inst nop) + + (move cur-uwp block) + + DO-EXIT + + (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) + (loadw code-tn cur-uwp unwind-block-current-code-slot) + (loadw lra cur-uwp unwind-block-entry-pc-slot) + (lisp-return lra :frob-code nil) + + DO-UWP + + (loadw next-uwp cur-uwp unwind-block-current-uwp-slot) + (inst b do-exit) + (store-symbol-value next-uwp *current-unwind-protect-block*)) + + +(define-assembly-routine (throw + (:return-style :none)) + ((:arg target descriptor-reg a0-offset) + (:arg start any-reg ocfp-offset) + (:arg count any-reg nargs-offset) + (:temp catch any-reg a1-offset) + (:temp tag descriptor-reg a2-offset) + (:temp temp non-descriptor-reg nl0-offset)) + + (declare (ignore start count)) + + (load-symbol-value catch *current-catch-block*) + + loop + + (let ((error (generate-error-code nil unseen-throw-tag-error target))) + (inst cmp catch) + (inst b :eq error) + (inst nop)) + + (loadw tag catch catch-block-tag-slot) + (inst cmp tag target) + (inst b :eq exit) + (inst nop) + (loadw catch catch catch-block-previous-catch-slot) + (inst b loop) + (inst nop) + + exit + + (move target catch) + (inst li temp (make-fixup 'unwind :assembly-routine)) + (inst j temp) + (inst nop)) + + diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/sparc/support.lisp sbcl-0.9.14/src/compiler/assembly/sparc/support.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/sparc/support.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/sparc/support.lisp 2005-07-14 12:30:12.000000000 -0400 @@ -0,0 +1,74 @@ +;;;; the machine-specific support routines needed by the file assembler + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +(!def-vm-support-routine generate-call-sequence (name style vop) + (ecase style + ((:raw :none) + (let ((temp (make-symbol "TEMP")) + (lip (make-symbol "LIP"))) + (values + `((inst jali ,lip ,temp (make-fixup ',name :assembly-routine)) + (inst nop)) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:scs (interior-reg) :from (:eval 0) :to (:eval 1)) + ,lip))))) + (:full-call + (let ((temp (make-symbol "TEMP")) + (nfp-save (make-symbol "NFP-SAVE")) + (lra (make-symbol "LRA"))) + (values + `((let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn ,vop))) + (when cur-nfp + (store-stack-tn ,nfp-save cur-nfp)) + (inst compute-lra-from-code ,lra code-tn lra-label ,temp) + (note-next-instruction ,vop :call-site) + (inst ji ,temp (make-fixup ',name :assembly-routine)) + (inst nop) + (emit-return-pc lra-label) + (note-this-location ,vop :single-value-return) + (without-scheduling () + (move csp-tn ocfp-tn) + (inst nop)) + (inst compute-code-from-lra code-tn code-tn + lra-label ,temp) + (when cur-nfp + (load-stack-tn cur-nfp ,nfp-save)))) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:sc descriptor-reg :offset lra-offset + :from (:eval 0) :to (:eval 1)) + ,lra) + (:temporary (:scs (control-stack) :offset nfp-save-offset) + ,nfp-save) + (:save-p :compute-only))))))) + +(!def-vm-support-routine generate-return-sequence (style) + (ecase style + (:raw + `((inst j + (make-random-tn :kind :normal + :sc (sc-or-lose 'interior-reg) + :offset lip-offset) + 8) + (inst nop))) + (:full-call + `((lisp-return (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg) + :offset lra-offset) + :offset 2))) + (:none))) + +(defun return-machine-address (scp) + (+ (context-register scp lip-offset) 8)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86/alloc.lisp sbcl-0.9.14/src/compiler/assembly/x86/alloc.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86/alloc.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/x86/alloc.lisp 2001-10-10 18:44:30.000000000 -0400 @@ -0,0 +1,67 @@ +;;;; allocating simple objects + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; from signed/unsigned + +;;; KLUDGE: Why don't we want vops for this one and the next +;;; one? -- WHN 19990916 +#+sb-assembling ; We don't want a vop for this one. +(define-assembly-routine + (move-from-signed) + ((:temp eax unsigned-reg eax-offset) + (:temp ebx unsigned-reg ebx-offset)) + (inst mov ebx eax) + (inst shl ebx 1) + (inst jmp :o bignum) + (inst shl ebx 1) + (inst jmp :o bignum) + (inst ret) + BIGNUM + + (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 1)) + (storew eax ebx bignum-digits-offset other-pointer-lowtag)) + + (inst ret)) + +#+sb-assembling ; We don't want a vop for this one either. +(define-assembly-routine + (move-from-unsigned) + ((:temp eax unsigned-reg eax-offset) + (:temp ebx unsigned-reg ebx-offset)) + + (inst test eax #xe0000000) + (inst jmp :nz bignum) + ;; Fixnum + (inst mov ebx eax) + (inst shl ebx 2) + (inst ret) + + BIGNUM + ;;; Note: On the mips port space for a two word bignum is always + ;;; allocated and the header size is set to either one or two words + ;;; as appropriate. On the mips port this is faster, and smaller + ;;; inline, but produces more garbage. The inline x86 version uses + ;;; the same approach, but here we save garbage and allocate the + ;;; smallest possible bignum. + (inst jmp :ns one-word-bignum) + (inst mov ebx eax) + + ;; Two word bignum + (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 2)) + (storew eax ebx bignum-digits-offset other-pointer-lowtag)) + (inst ret) + + ONE-WORD-BIGNUM + (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 1)) + (storew eax ebx bignum-digits-offset other-pointer-lowtag)) + (inst ret)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86/arith.lisp sbcl-0.9.14/src/compiler/assembly/x86/arith.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86/arith.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/x86/arith.lisp 2006-03-04 14:58:28.000000000 -0500 @@ -0,0 +1,407 @@ +;;;; simple cases for generic arithmetic + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; addition, subtraction, and multiplication + +(macrolet ((define-generic-arith-routine ((fun cost) &body body) + `(define-assembly-routine (,(symbolicate "GENERIC-" fun) + (:cost ,cost) + (:return-style :full-call) + (:translate ,fun) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) + ;; this seems wrong esi-offset -- FIXME: What's it mean? + edi-offset) + + (:res res (descriptor-reg any-reg) edx-offset) + + (:temp eax unsigned-reg eax-offset) + (:temp ebx unsigned-reg ebx-offset) + (:temp ecx unsigned-reg ecx-offset)) + + (declare (ignorable ebx)) + + (inst test x 3) ; fixnum? + (inst jmp :nz DO-STATIC-FUN) ; no - do generic + (inst test y 3) ; fixnum? + (inst jmp :z DO-BODY) ; yes - doit here + + DO-STATIC-FUN + (inst pop eax) + (inst push ebp-tn) + (inst lea + ebp-tn + (make-ea :dword :base esp-tn :disp n-word-bytes)) + (inst sub esp-tn (fixnumize 2)) + (inst push eax) ; callers return addr + (inst mov ecx (fixnumize 2)) ; arg count + (inst jmp + (make-ea :dword + :disp (+ nil-value + (static-fun-offset + ',(symbolicate "TWO-ARG-" fun))))) + + DO-BODY + ,@body))) + + (define-generic-arith-routine (+ 10) + (move res x) + (inst add res y) + (inst jmp :no OKAY) + (inst rcr res 1) ; carry has correct sign + (inst sar res 1) ; remove type bits + + (move ecx res) + + (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) + (storew ecx res bignum-digits-offset other-pointer-lowtag)) + + OKAY) + + (define-generic-arith-routine (- 10) + (move res x) + (inst sub res y) + (inst jmp :no OKAY) + (inst cmc) ; carry has correct sign now + (inst rcr res 1) + (inst sar res 1) ; remove type bits + + (move ecx res) + + (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) + (storew ecx res bignum-digits-offset other-pointer-lowtag)) + OKAY) + + (define-generic-arith-routine (* 30) + (move eax x) ; must use eax for 64-bit result + (inst sar eax 2) ; remove *4 fixnum bias + (inst imul y) ; result in edx:eax + (inst jmp :no okay) ; still fixnum + + ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above + ;; pfw says that loses big -- edx is target for arg x and result res + ;; note that 'edx' is not defined -- using x + (inst shrd eax x 2) ; high bits from edx + (inst sar x 2) ; now shift edx too + + (move ecx x) ; save high bits from cdq + (inst cdq) ; edx:eax <- sign-extend of eax + (inst cmp x ecx) + (inst jmp :e SINGLE-WORD-BIGNUM) + + (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2)) + (storew eax res bignum-digits-offset other-pointer-lowtag) + (storew ecx res (1+ bignum-digits-offset) other-pointer-lowtag)) + (inst jmp DONE) + + SINGLE-WORD-BIGNUM + + (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) + (storew eax res bignum-digits-offset other-pointer-lowtag)) + (inst jmp DONE) + + OKAY + (move res eax) + DONE)) + +;;;; negation + +(define-assembly-routine (generic-negate + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate %negate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:res res (descriptor-reg any-reg) edx-offset) + + (:temp eax unsigned-reg eax-offset) + (:temp ecx unsigned-reg ecx-offset)) + (inst test x 3) + (inst jmp :z FIXNUM) + + (inst pop eax) + (inst push ebp-tn) + (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes)) + (inst sub esp-tn (fixnumize 2)) + (inst push eax) + (inst mov ecx (fixnumize 1)) ; arg count + (inst jmp (make-ea :dword + :disp (+ nil-value (static-fun-offset '%negate)))) + + FIXNUM + (move res x) + (inst neg res) ; (- most-negative-fixnum) is BIGNUM + (inst jmp :no OKAY) + (inst shr res 2) ; sign bit is data - remove type bits + (move ecx res) + + (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) + (storew ecx res bignum-digits-offset other-pointer-lowtag)) + + OKAY) + +;;;; comparison + +(macrolet ((define-cond-assem-rtn (name translate static-fn test) + `(define-assembly-routine (,name + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) edi-offset) + + (:res res descriptor-reg edx-offset) + + (:temp eax unsigned-reg eax-offset) + (:temp ecx unsigned-reg ecx-offset)) + + ;; KLUDGE: The "3" here is a mask for the bits which will be + ;; zero in a fixnum. It should have a symbolic name. (Actually, + ;; it might already have a symbolic name which the coder + ;; couldn't be bothered to use..) -- WHN 19990917 + (inst test x 3) + (inst jmp :nz TAIL-CALL-TO-STATIC-FN) + (inst test y 3) + (inst jmp :z INLINE-FIXNUM-COMPARE) + + TAIL-CALL-TO-STATIC-FN + (inst pop eax) + (inst push ebp-tn) + (inst lea ebp-tn (make-ea :dword + :base esp-tn + :disp n-word-bytes)) + (inst sub esp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack, + ; weirdly? + (inst push eax) + (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and + ; SINGLE-FLOAT-BITS are parallel, + ; should be named parallelly. + (inst jmp (make-ea :dword + :disp (+ nil-value + (static-fun-offset ',static-fn)))) + + INLINE-FIXNUM-COMPARE + (inst cmp x y) + (inst mov res nil-value) + (inst jmp ,test RETURN-FALSE) + + (load-symbol res t) + + RETURN-FALSE + DONE))) + + (define-cond-assem-rtn generic-< < two-arg-< :ge) + (define-cond-assem-rtn generic-> > two-arg-> :le)) + +(define-assembly-routine (generic-eql + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) edi-offset) + + (:res res descriptor-reg edx-offset) + + (:temp eax unsigned-reg eax-offset) + (:temp ecx unsigned-reg ecx-offset)) + (inst cmp x y) + (inst jmp :e RETURN-T) + (inst test x 3) + (inst jmp :z RETURN-NIL) + (inst test y 3) + (inst jmp :nz DO-STATIC-FN) + + RETURN-NIL + (inst mov res nil-value) + (inst jmp DONE) + + DO-STATIC-FN + (inst pop eax) + (inst push ebp-tn) + (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes)) + (inst sub esp-tn (fixnumize 2)) + (inst push eax) + (inst mov ecx (fixnumize 2)) + (inst jmp (make-ea :dword + :disp (+ nil-value (static-fun-offset 'eql)))) + + RETURN-T + (load-symbol res t) + + DONE) + +(define-assembly-routine (generic-= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) edi-offset) + + (:res res descriptor-reg edx-offset) + + (:temp eax unsigned-reg eax-offset) + (:temp ecx unsigned-reg ecx-offset) + ) + (inst test x 3) ; descriptor? + (inst jmp :nz DO-STATIC-FN) ; yes, do it here + (inst test y 3) ; descriptor? + (inst jmp :nz DO-STATIC-FN) + (inst cmp x y) + (inst jmp :e RETURN-T) ; ok + + (inst mov res nil-value) + (inst jmp DONE) + + DO-STATIC-FN + (inst pop eax) + (inst push ebp-tn) + (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes)) + (inst sub esp-tn (fixnumize 2)) + (inst push eax) + (inst mov ecx (fixnumize 2)) + (inst jmp (make-ea :dword + :disp (+ nil-value (static-fun-offset 'two-arg-=)))) + + RETURN-T + (load-symbol res t) + + DONE) + + +;;; Support for the Mersenne Twister, MT19937, random number generator +;;; due to Matsumoto and Nishimura. +;;; +;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A +;;; 623-dimensionally equidistributed uniform pseudorandom number +;;; generator.", ACM Transactions on Modeling and Computer Simulation, +;;; 1997, to appear. +;;; +;;; State: +;;; 0-1: Constant matrix A. [0, #x9908b0df] (not used here) +;;; 2: Index; init. to 1. +;;; 3-626: State. + +;;; This assembly routine is called from the inline VOP and updates +;;; the state vector with new random numbers. The state vector is +;;; passed in the EAX register. +#+sb-assembling ; We don't want a vop for this one. +(define-assembly-routine + (random-mt19937-update) + ((:temp state unsigned-reg eax-offset) + (:temp k unsigned-reg ebx-offset) + (:temp y unsigned-reg ecx-offset) + (:temp tmp unsigned-reg edx-offset)) + + ;; Save the temporary registers. + (inst push k) + (inst push y) + (inst push tmp) + + ;; Generate a new set of results. + (inst xor k k) + LOOP1 + (inst mov y (make-ea :dword :base state :index k :scale 4 + :disp (- (* (+ 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) + (inst mov tmp (make-ea :dword :base state :index k :scale 4 + :disp (- (* (+ 1 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) + (inst and y #x80000000) + (inst and tmp #x7fffffff) + (inst or y tmp) + (inst shr y 1) + (inst jmp :nc skip1) + (inst xor y #x9908b0df) + SKIP1 + (inst xor y (make-ea :dword :base state :index k :scale 4 + :disp (- (* (+ 397 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) + (inst mov (make-ea :dword :base state :index k :scale 4 + :disp (- (* (+ 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag)) + y) + (inst inc k) + (inst cmp k (- 624 397)) + (inst jmp :b loop1) + LOOP2 + (inst mov y (make-ea :dword :base state :index k :scale 4 + :disp (- (* (+ 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) + (inst mov tmp (make-ea :dword :base state :index k :scale 4 + :disp (- (* (+ 1 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) + (inst and y #x80000000) + (inst and tmp #x7fffffff) + (inst or y tmp) + (inst shr y 1) + (inst jmp :nc skip2) + (inst xor y #x9908b0df) + SKIP2 + (inst xor y (make-ea :dword :base state :index k :scale 4 + :disp (- (* (+ (- 397 624) 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) + (inst mov (make-ea :dword :base state :index k :scale 4 + :disp (- (* (+ 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag)) + y) + (inst inc k) + (inst cmp k (- 624 1)) + (inst jmp :b loop2) + + (inst mov y (make-ea :dword :base state + :disp (- (* (+ (- 624 1) 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) + (inst mov tmp (make-ea :dword :base state + :disp (- (* (+ 0 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) + (inst and y #x80000000) + (inst and tmp #x7fffffff) + (inst or y tmp) + (inst shr y 1) + (inst jmp :nc skip3) + (inst xor y #x9908b0df) + SKIP3 + (inst xor y (make-ea :dword :base state + :disp (- (* (+ (- 397 1) 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) + (inst mov (make-ea :dword :base state + :disp (- (* (+ (- 624 1) 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag)) + y) + + ;; Restore the temporary registers and return. + (inst pop tmp) + (inst pop y) + (inst pop k) + (inst ret)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86/array.lisp sbcl-0.9.14/src/compiler/assembly/x86/array.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86/array.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/x86/array.lisp 2005-04-16 02:18:31.000000000 -0400 @@ -0,0 +1,19 @@ +;;;; various array operations that are too expensive (in space) to do +;;;; inline + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; Note: On other platforms ALLOCATE-VECTOR is an assembly routine, +;;;; but on X86 it is a VOP. + +;;;; Note: CMU CL had assembly language primitives for hashing strings, +;;;; but SBCL doesn't. diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86/assem-rtns.lisp sbcl-0.9.14/src/compiler/assembly/x86/assem-rtns.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86/assem-rtns.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/x86/assem-rtns.lisp 2006-03-04 14:58:28.000000000 -0500 @@ -0,0 +1,273 @@ +;;;; the machine specific support routines needed by the file assembler + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; RETURN-MULTIPLE + +;;; For RETURN-MULTIPLE, we have to move the results from the end of +;;; the frame for the function that is returning to the end of the +;;; frame for the function being returned to. + +#+sb-assembling ;; We don't want a vop for this one. +(define-assembly-routine + (return-multiple (:return-style :none)) + (;; These four are really arguments. + (:temp eax unsigned-reg eax-offset) + (:temp ebx unsigned-reg ebx-offset) + (:temp ecx unsigned-reg ecx-offset) + (:temp esi unsigned-reg esi-offset) + + ;; These we need as temporaries. + (:temp edx unsigned-reg edx-offset) + (:temp edi unsigned-reg edi-offset)) + + ;; Pick off the cases where everything fits in register args. + (inst jecxz zero-values) + (inst cmp ecx (fixnumize 1)) + (inst jmp :e one-value) + (inst cmp ecx (fixnumize 2)) + (inst jmp :e two-values) + (inst cmp ecx (fixnumize 3)) + (inst jmp :e three-values) + + ;; Save the count, because the loop is going to destroy it. + (inst mov edx ecx) + + ;; Blit the values down the stack. Note: there might be overlap, so + ;; we have to be careful not to clobber values before we've read + ;; them. Because the stack builds down, we are coping to a larger + ;; address. Therefore, we need to iterate from larger addresses to + ;; smaller addresses. pfw-this says copy ecx words from esi to edi + ;; counting down. + (inst shr ecx 2) ; fixnum to raw word count + (inst std) ; count down + (inst sub esi 4) ; ? + (inst lea edi (make-ea :dword :base ebx :disp (- n-word-bytes))) + (inst rep) + (inst movs :dword) + + ;; solaris requires DF being zero. + #!+sunos (inst cld) + + ;; Restore the count. + (inst mov ecx edx) + + ;; Set the stack top to the last result. + (inst lea esp-tn (make-ea :dword :base edi :disp n-word-bytes)) + + ;; Load the register args. + (loadw edx ebx -1) + (loadw edi ebx -2) + (loadw esi ebx -3) + + ;; And back we go. + (inst stc) + (inst jmp eax) + + ;; Handle the register arg cases. + ZERO-VALUES + (move esp-tn ebx) + (inst mov edx nil-value) + (inst mov edi edx) + (inst mov esi edx) + (inst stc) + (inst jmp eax) + + ONE-VALUE ; Note: we can get this, because the return-multiple vop + ; doesn't check for this case when size > speed. + (loadw edx esi -1) + (inst mov esp-tn ebx) + (inst clc) + (inst jmp eax) + + TWO-VALUES + (loadw edx esi -1) + (loadw edi esi -2) + (inst mov esi nil-value) + (inst lea esp-tn (make-ea :dword :base ebx :disp (* -2 n-word-bytes))) + (inst stc) + (inst jmp eax) + + THREE-VALUES + (loadw edx esi -1) + (loadw edi esi -2) + (loadw esi esi -3) + (inst lea esp-tn (make-ea :dword :base ebx :disp (* -3 n-word-bytes))) + (inst stc) + (inst jmp eax)) + +;;;; TAIL-CALL-VARIABLE + +;;; For tail-call-variable, we have to copy the arguments from the end +;;; of our stack frame (were args are produced) to the start of our +;;; stack frame (were args are expected). +;;; +;;; We take the function to call in EAX and a pointer to the arguments in +;;; ESI. EBP says the same over the jump, and the old frame pointer is +;;; still saved in the first stack slot. The return-pc is saved in +;;; the second stack slot, so we have to push it to make it look like +;;; we actually called. We also have to compute ECX from the difference +;;; between ESI and the stack top. +#+sb-assembling ;; No vop for this one either. +(define-assembly-routine + (tail-call-variable + (:return-style :none)) + + ((:temp eax unsigned-reg eax-offset) + (:temp ebx unsigned-reg ebx-offset) + (:temp ecx unsigned-reg ecx-offset) + (:temp edx unsigned-reg edx-offset) + (:temp edi unsigned-reg edi-offset) + (:temp esi unsigned-reg esi-offset)) + + ;; Calculate NARGS (as a fixnum) + (move ecx esi) + (inst sub ecx esp-tn) + + ;; Check for all the args fitting the registers. + (inst cmp ecx (fixnumize 3)) + (inst jmp :le REGISTER-ARGS) + + ;; Save the OLD-FP and RETURN-PC because the blit it going to trash + ;; those stack locations. Save the ECX, because the loop is going + ;; to trash it. + (pushw ebp-tn -1) + (loadw ebx ebp-tn -2) + (inst push ecx) + + ;; Do the blit. Because we are coping from smaller addresses to + ;; larger addresses, we have to start at the largest pair and work + ;; our way down. + (inst shr ecx 2) ; fixnum to raw words + (inst std) ; count down + (inst lea edi (make-ea :dword :base ebp-tn :disp (- n-word-bytes))) + (inst sub esi (fixnumize 1)) + (inst rep) + (inst movs :dword) + + ;; solaris requires DF being zero. + #!+sunos (inst cld) + + ;; Load the register arguments carefully. + (loadw edx ebp-tn -1) + + ;; Restore OLD-FP and ECX. + (inst pop ecx) + (popw ebp-tn -1) ; overwrites a0 + + ;; Blow off the stack above the arguments. + (inst lea esp-tn (make-ea :dword :base edi :disp n-word-bytes)) + + ;; remaining register args + (loadw edi ebp-tn -2) + (loadw esi ebp-tn -3) + + ;; Push the (saved) return-pc so it looks like we just called. + (inst push ebx) + + ;; And jump into the function. + (inst jmp + (make-ea :byte :base eax + :disp (- (* closure-fun-slot n-word-bytes) + fun-pointer-lowtag))) + + ;; All the arguments fit in registers, so load them. + REGISTER-ARGS + (loadw edx esi -1) + (loadw edi esi -2) + (loadw esi esi -3) + + ;; Clear most of the stack. + (inst lea esp-tn + (make-ea :dword :base ebp-tn :disp (* -3 n-word-bytes))) + + ;; Push the return-pc so it looks like we just called. + (pushw ebp-tn -2) + + ;; And away we go. + (inst jmp (make-ea :byte :base eax + :disp (- (* closure-fun-slot n-word-bytes) + fun-pointer-lowtag)))) + +(define-assembly-routine (throw + (:return-style :none)) + ((:arg target (descriptor-reg any-reg) edx-offset) + (:arg start any-reg ebx-offset) + (:arg count any-reg ecx-offset) + (:temp catch any-reg eax-offset)) + + (declare (ignore start count)) + + (load-tl-symbol-value catch *current-catch-block*) + + LOOP + + (let ((error (generate-error-code nil unseen-throw-tag-error target))) + (inst or catch catch) ; check for NULL pointer + (inst jmp :z error)) + + (inst cmp target (make-ea-for-object-slot catch catch-block-tag-slot 0)) + (inst jmp :e exit) + + (loadw catch catch catch-block-previous-catch-slot) + (inst jmp loop) + + EXIT + + ;; Here EAX points to catch block containing symbol pointed to by EDX. + (inst jmp (make-fixup 'unwind :assembly-routine))) + +;;;; non-local exit noise + +(define-assembly-routine (unwind + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) eax-offset) + (:arg start (any-reg descriptor-reg) ebx-offset) + (:arg count (any-reg descriptor-reg) ecx-offset) + (:temp uwp unsigned-reg esi-offset)) + (declare (ignore start count)) + + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst or block block) ; check for NULL pointer + (inst jmp :z error)) + + (load-tl-symbol-value uwp *current-unwind-protect-block*) + + ;; Does *CURRENT-UNWIND-PROTECT-BLOCK* match the value stored in + ;; argument's CURRENT-UWP-SLOT? + (inst cmp uwp + (make-ea-for-object-slot block unwind-block-current-uwp-slot 0)) + ;; If a match, return to context in arg block. + (inst jmp :e do-exit) + + ;; Not a match - return to *CURRENT-UNWIND-PROTECT-BLOCK* context. + ;; Important! Must save (and return) the arg 'block' for later use!! + (move edx-tn block) + (move block uwp) + ;; Set next unwind protect context. + (loadw uwp uwp unwind-block-current-uwp-slot) + ;; we're about to reload ebp anyway, so let's borrow it here as a + ;; temporary. Hope this works + (store-tl-symbol-value uwp *current-unwind-protect-block* ebp-tn) + + DO-EXIT + + (loadw ebp-tn block unwind-block-current-cont-slot) + + ;; Uwp-entry expects some things in known locations so that they can + ;; be saved on the stack: the block in edx-tn, start in ebx-tn, and + ;; count in ecx-tn. + + (inst jmp (make-ea :byte :base block + :disp (* unwind-block-entry-pc-slot n-word-bytes)))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86/bit-bash.lisp sbcl-0.9.14/src/compiler/assembly/x86/bit-bash.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86/bit-bash.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/x86/bit-bash.lisp 2000-10-20 19:30:33.000000000 -0400 @@ -0,0 +1,12 @@ +;;;; just a dummy file to maintain parallelism with other VMs + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86/support.lisp sbcl-0.9.14/src/compiler/assembly/x86/support.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86/support.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/x86/support.lisp 2006-03-07 13:47:38.000000000 -0500 @@ -0,0 +1,54 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;; The :full-call assembly-routines must use the same full-call +;;; unknown-values return convention as a normal call, as some +;;; of the routines will tail-chain to a static-function. The +;;; routines themselves, however, take all of their arguments +;;; in registers (this will typically be one or two arguments, +;;; and is one of the lower bounds on the number of argument- +;;; passing registers), and thus don't need a call frame, which +;;; simplifies things for the normal call/return case. When it +;;; is neccessary for one of the assembly-functions to call a +;;; static-function it will construct the required call frame. +;;; Also, none of the assembly-routines return other than one +;;; value, which again simplifies the return path. +;;; -- AB, 2006/Feb/05. + +(!def-vm-support-routine generate-call-sequence (name style vop) + (ecase style + ((:raw :none) + (values + `((inst call (make-fixup ',name :assembly-routine))) + nil)) + (:full-call + (values + `((note-this-location ,vop :call-site) + (inst call (make-fixup ',name :assembly-routine)) + (note-this-location ,vop :single-value-return) + (cond + ((member :cmov *backend-subfeatures*) + (inst cmov :c esp-tn ebx-tn)) + (t + (let ((single-value (gen-label))) + (inst jmp :nc single-value) + (move esp-tn ebx-tn) + (emit-label single-value))))) + '((:save-p :compute-only)))))) + +(!def-vm-support-routine generate-return-sequence (style) + (ecase style + (:raw + `(inst ret)) + (:full-call + `((inst clc) + (inst ret))) + (:none))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86-64/alloc.lisp sbcl-0.9.14/src/compiler/assembly/x86-64/alloc.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86-64/alloc.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/x86-64/alloc.lisp 2005-04-29 10:37:36.000000000 -0400 @@ -0,0 +1,59 @@ +;;;; allocating simple objects + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; from signed/unsigned + +;;; KLUDGE: Why don't we want vops for this one and the next +;;; one? -- WHN 19990916 +#+sb-assembling ; We don't want a vop for this one. +(define-assembly-routine + (move-from-signed) + ((:temp eax unsigned-reg eax-offset) + (:temp ebx unsigned-reg ebx-offset)) + (inst mov ebx eax) + (inst shl ebx 1) + (inst jmp :o BIGNUM) + (inst shl ebx 1) + (inst jmp :o BIGNUM) + (inst shl ebx 1) + (inst jmp :o BIGNUM) + (inst ret) + BIGNUM + + (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 1)) + (storew eax ebx bignum-digits-offset other-pointer-lowtag)) + + (inst ret)) + +#+sb-assembling ; We don't want a vop for this one either. +(define-assembly-routine + (move-from-unsigned) + ((:temp eax unsigned-reg eax-offset) + (:temp ebx unsigned-reg ebx-offset)) + + (inst bsr ebx eax) + (inst cmp ebx 61) + (inst jmp :z DONE) + (inst jmp :ge BIGNUM) + ;; Fixnum + (inst mov ebx eax) + (inst shl ebx 3) + DONE + (inst ret) + + BIGNUM + (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 2)) + (storew eax ebx bignum-digits-offset other-pointer-lowtag)) + (inst ret)) + + diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86-64/arith.lisp sbcl-0.9.14/src/compiler/assembly/x86-64/arith.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86-64/arith.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/x86-64/arith.lisp 2006-03-04 14:58:29.000000000 -0500 @@ -0,0 +1,286 @@ +;;;; simple cases for generic arithmetic + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; addition, subtraction, and multiplication + +(macrolet ((define-generic-arith-routine ((fun cost) &body body) + `(define-assembly-routine (,(symbolicate "GENERIC-" fun) + (:cost ,cost) + (:return-style :full-call) + (:translate ,fun) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:arg y (descriptor-reg any-reg) + ;; this seems wrong esi-offset -- FIXME: What's it mean? + rdi-offset) + + (:res res (descriptor-reg any-reg) rdx-offset) + + (:temp rax unsigned-reg rax-offset) + (:temp rbx unsigned-reg rbx-offset) + (:temp rcx unsigned-reg rcx-offset)) + + (declare (ignorable rbx)) + + (inst test x 7) ; fixnum? + (inst jmp :nz DO-STATIC-FUN) ; no - do generic + (inst test y 7) ; fixnum? + (inst jmp :z DO-BODY) ; yes - doit here + + DO-STATIC-FUN + (inst pop rax) + (inst push rbp-tn) + (inst lea + rbp-tn + (make-ea :qword :base rsp-tn :disp n-word-bytes)) + (inst sub rsp-tn (fixnumize 2)) + (inst push rax) ; callers return addr + (inst mov rcx (fixnumize 2)) ; arg count + (inst jmp + (make-ea :qword + :disp (+ nil-value + (static-fun-offset + ',(symbolicate "TWO-ARG-" fun))))) + + DO-BODY + ,@body))) + + (define-generic-arith-routine (+ 10) + (move res x) + (inst add res y) + (inst jmp :no OKAY) + (inst rcr res 1) ; carry has correct sign + (inst sar res 2) ; remove type bits + + (move rcx res) + + (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) + (storew rcx res bignum-digits-offset other-pointer-lowtag)) + + OKAY) + + (define-generic-arith-routine (- 10) + (move res x) + (inst sub res y) + (inst jmp :no OKAY) + (inst cmc) ; carry has correct sign now + (inst rcr res 1) + (inst sar res 2) ; remove type bits + + (move rcx res) + + (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) + (storew rcx res bignum-digits-offset other-pointer-lowtag)) + OKAY) + + (define-generic-arith-routine (* 30) + (move rax x) ; must use eax for 64-bit result + (inst sar rax 3) ; remove *4 fixnum bias + (inst imul y) ; result in edx:eax + (inst jmp :no OKAY) ; still fixnum + + ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above + ;; pfw says that loses big -- edx is target for arg x and result res + ;; note that 'edx' is not defined -- using x + (inst shrd rax x 3) ; high bits from edx + (inst sar x 3) ; now shift edx too + + (move rcx x) ; save high bits from cqo + (inst cqo) ; edx:eax <- sign-extend of eax + (inst cmp x rcx) + (inst jmp :e SINGLE-WORD-BIGNUM) + + (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2)) + (storew rax res bignum-digits-offset other-pointer-lowtag) + (storew rcx res (1+ bignum-digits-offset) other-pointer-lowtag)) + (inst jmp DONE) + + SINGLE-WORD-BIGNUM + + (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) + (storew rax res bignum-digits-offset other-pointer-lowtag)) + (inst jmp DONE) + + OKAY + (move res rax) + DONE)) + +;;;; negation + +(define-assembly-routine (generic-negate + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate %negate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:res res (descriptor-reg any-reg) rdx-offset) + + (:temp rax unsigned-reg rax-offset) + (:temp rcx unsigned-reg rcx-offset)) + (inst test x 7) + (inst jmp :z FIXNUM) + + (inst pop rax) + (inst push rbp-tn) + (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes)) + (inst sub rsp-tn (fixnumize 2)) + (inst push rax) + (inst mov rcx (fixnumize 1)) ; arg count + (inst jmp (make-ea :qword + :disp (+ nil-value (static-fun-offset '%negate)))) + + FIXNUM + (move res x) + (inst neg res) ; (- most-negative-fixnum) is BIGNUM + (inst jmp :no OKAY) + (inst shr res 3) ; sign bit is data - remove type bits + (move rcx res) + + (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) + (storew rcx res bignum-digits-offset other-pointer-lowtag)) + + OKAY) + +;;;; comparison + +(macrolet ((define-cond-assem-rtn (name translate static-fn test) + `(define-assembly-routine (,name + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:arg y (descriptor-reg any-reg) rdi-offset) + + (:res res descriptor-reg rdx-offset) + + (:temp eax unsigned-reg rax-offset) + (:temp ecx unsigned-reg rcx-offset)) + + ;; KLUDGE: The "3" here is a mask for the bits which will be + ;; zero in a fixnum. It should have a symbolic name. (Actually, + ;; it might already have a symbolic name which the coder + ;; couldn't be bothered to use..) -- WHN 19990917 + (inst test x 7) + (inst jmp :nz TAIL-CALL-TO-STATIC-FN) + (inst test y 7) + (inst jmp :z INLINE-FIXNUM-COMPARE) + + TAIL-CALL-TO-STATIC-FN + (inst pop eax) + (inst push rbp-tn) + (inst lea rbp-tn (make-ea :qword + :base rsp-tn + :disp n-word-bytes)) + (inst sub rsp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack, + ; weirdly? + (inst push eax) + (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and + ; SINGLE-FLOAT-BITS are parallel, + ; should be named parallelly. + (inst jmp (make-ea :qword + :disp (+ nil-value + (static-fun-offset ',static-fn)))) + + INLINE-FIXNUM-COMPARE + (inst cmp x y) + (inst mov res nil-value) + (inst jmp ,test RETURN-FALSE) + RETURN-TRUE + (load-symbol res t) + RETURN-FALSE + DONE))) + + (define-cond-assem-rtn generic-< < two-arg-< :ge) + (define-cond-assem-rtn generic-> > two-arg-> :le)) + +(define-assembly-routine (generic-eql + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:arg y (descriptor-reg any-reg) rdi-offset) + + (:res res descriptor-reg rdx-offset) + + (:temp eax unsigned-reg rax-offset) + (:temp ecx unsigned-reg rcx-offset)) + (inst cmp x y) + (inst jmp :e RETURN-T) + (inst test x 7) + (inst jmp :z RETURN-NIL) + (inst test y 7) + (inst jmp :nz DO-STATIC-FN) + + RETURN-NIL + (inst mov res nil-value) + (inst jmp DONE) + + DO-STATIC-FN + (inst pop eax) + (inst push rbp-tn) + (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes)) + (inst sub rsp-tn (fixnumize 2)) + (inst push eax) + (inst mov ecx (fixnumize 2)) + (inst jmp (make-ea :qword + :disp (+ nil-value (static-fun-offset 'eql)))) + + RETURN-T + (load-symbol res t) + DONE) + +(define-assembly-routine (generic-= + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:arg y (descriptor-reg any-reg) rdi-offset) + + (:res res descriptor-reg rdx-offset) + + (:temp eax unsigned-reg rax-offset) + (:temp ecx unsigned-reg rcx-offset) + ) + (inst test x 7) ; descriptor? + (inst jmp :nz DO-STATIC-FN) ; yes, do it here + (inst test y 7) ; descriptor? + (inst jmp :nz DO-STATIC-FN) + (inst cmp x y) + (inst jmp :e RETURN-T) ; ok + + (inst mov res nil-value) + (inst jmp DONE) + + DO-STATIC-FN + (inst pop eax) + (inst push rbp-tn) + (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes)) + (inst sub rsp-tn (fixnumize 2)) + (inst push eax) + (inst mov ecx (fixnumize 2)) + (inst jmp (make-ea :qword + :disp (+ nil-value (static-fun-offset 'two-arg-=)))) + + RETURN-T + (load-symbol res t) + DONE) + + diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86-64/array.lisp sbcl-0.9.14/src/compiler/assembly/x86-64/array.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86-64/array.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/x86-64/array.lisp 2006-03-09 07:58:44.000000000 -0500 @@ -0,0 +1,19 @@ +;;;; various array operations that are too expensive (in space) to do +;;;; inline + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; Note: On other platforms ALLOCATE-VECTOR is an assembly routine, +;;;; but on X86-64 it is a VOP. + +;;;; Note: CMU CL had assembly language primitives for hashing strings, +;;;; but SBCL doesn't. diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86-64/assem-rtns.lisp sbcl-0.9.14/src/compiler/assembly/x86-64/assem-rtns.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86-64/assem-rtns.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/x86-64/assem-rtns.lisp 2006-03-04 14:58:30.000000000 -0500 @@ -0,0 +1,267 @@ +;;;; the machine specific support routines needed by the file assembler + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +;;;; RETURN-MULTIPLE + +;;; For RETURN-MULTIPLE, we have to move the results from the end of +;;; the frame for the function that is returning to the end of the +;;; frame for the function being returned to. + +#+sb-assembling ;; We don't want a vop for this one. +(define-assembly-routine + (return-multiple (:return-style :none)) + (;; These four are really arguments. + (:temp eax unsigned-reg rax-offset) + (:temp ebx unsigned-reg rbx-offset) + (:temp ecx unsigned-reg rcx-offset) + (:temp esi unsigned-reg rsi-offset) + + ;; These we need as temporaries. + (:temp edx unsigned-reg rdx-offset) + (:temp edi unsigned-reg rdi-offset)) + + ;; Pick off the cases where everything fits in register args. + (inst jecxz ZERO-VALUES) + (inst cmp ecx (fixnumize 1)) + (inst jmp :e ONE-VALUE) + (inst cmp ecx (fixnumize 2)) + (inst jmp :e TWO-VALUES) + (inst cmp ecx (fixnumize 3)) + (inst jmp :e THREE-VALUES) + + ;; Save the count, because the loop is going to destroy it. + (inst mov edx ecx) + + ;; Blit the values down the stack. Note: there might be overlap, so + ;; we have to be careful not to clobber values before we've read + ;; them. Because the stack builds down, we are coping to a larger + ;; address. Therefore, we need to iterate from larger addresses to + ;; smaller addresses. pfw-this says copy ecx words from esi to edi + ;; counting down. + (inst shr ecx 3) ; fixnum to raw word count + (inst std) ; count down + (inst sub esi 8) ; ? + (inst lea edi (make-ea :qword :base ebx :disp (- n-word-bytes))) + (inst rep) + (inst movs :qword) + + ;; Restore the count. + (inst mov ecx edx) + + ;; Set the stack top to the last result. + (inst lea rsp-tn (make-ea :qword :base edi :disp n-word-bytes)) + + ;; Load the register args. + (loadw edx ebx -1) + (loadw edi ebx -2) + (loadw esi ebx -3) + + ;; And back we go. + (inst stc) + (inst jmp eax) + + ;; Handle the register arg cases. + ZERO-VALUES + (move rsp-tn ebx) + (inst mov edx nil-value) + (inst mov edi edx) + (inst mov esi edx) + (inst stc) + (inst jmp eax) + + ONE-VALUE ; Note: we can get this, because the return-multiple vop + ; doesn't check for this case when size > speed. + (loadw edx esi -1) + (inst mov rsp-tn ebx) + (inst clc) + (inst jmp eax) + + TWO-VALUES + (loadw edx esi -1) + (loadw edi esi -2) + (inst mov esi nil-value) + (inst lea rsp-tn (make-ea :qword :base ebx :disp (* -2 n-word-bytes))) + (inst stc) + (inst jmp eax) + + THREE-VALUES + (loadw edx esi -1) + (loadw edi esi -2) + (loadw esi esi -3) + (inst lea rsp-tn (make-ea :qword :base ebx :disp (* -3 n-word-bytes))) + (inst stc) + (inst jmp eax)) + +;;;; TAIL-CALL-VARIABLE + +;;; For tail-call-variable, we have to copy the arguments from the end +;;; of our stack frame (were args are produced) to the start of our +;;; stack frame (were args are expected). +;;; +;;; We take the function to call in EAX and a pointer to the arguments in +;;; ESI. EBP says the same over the jump, and the old frame pointer is +;;; still saved in the first stack slot. The return-pc is saved in +;;; the second stack slot, so we have to push it to make it look like +;;; we actually called. We also have to compute ECX from the difference +;;; between ESI and the stack top. +#+sb-assembling ;; No vop for this one either. +(define-assembly-routine + (tail-call-variable + (:return-style :none)) + + ((:temp eax unsigned-reg rax-offset) + (:temp ebx unsigned-reg rbx-offset) + (:temp ecx unsigned-reg rcx-offset) + (:temp edx unsigned-reg rdx-offset) + (:temp edi unsigned-reg rdi-offset) + (:temp esi unsigned-reg rsi-offset)) + + ;; Calculate NARGS (as a fixnum) + (move ecx esi) + (inst sub ecx rsp-tn) + + ;; Check for all the args fitting the the registers. + (inst cmp ecx (fixnumize 3)) + (inst jmp :le REGISTER-ARGS) + + ;; Save the OLD-FP and RETURN-PC because the blit it going to trash + ;; those stack locations. Save the ECX, because the loop is going + ;; to trash it. + (pushw rbp-tn -1) + (loadw ebx rbp-tn -2) + (inst push ecx) + + ;; Do the blit. Because we are coping from smaller addresses to + ;; larger addresses, we have to start at the largest pair and work + ;; our way down. + (inst shr ecx 3) ; fixnum to raw words + (inst std) ; count down + (inst lea edi (make-ea :qword :base rbp-tn :disp (- n-word-bytes))) + (inst sub esi (fixnumize 1)) + (inst rep) + (inst movs :qword) + + ;; Load the register arguments carefully. + (loadw edx rbp-tn -1) + + ;; Restore OLD-FP and ECX. + (inst pop ecx) + (popw rbp-tn -1) ; overwrites a0 + + ;; Blow off the stack above the arguments. + (inst lea rsp-tn (make-ea :qword :base edi :disp n-word-bytes)) + + ;; remaining register args + (loadw edi rbp-tn -2) + (loadw esi rbp-tn -3) + + ;; Push the (saved) return-pc so it looks like we just called. + (inst push ebx) + + ;; And jump into the function. + (inst jmp + (make-ea :byte :base eax + :disp (- (* closure-fun-slot n-word-bytes) + fun-pointer-lowtag))) + + ;; All the arguments fit in registers, so load them. + REGISTER-ARGS + (loadw edx esi -1) + (loadw edi esi -2) + (loadw esi esi -3) + + ;; Clear most of the stack. + (inst lea rsp-tn + (make-ea :qword :base rbp-tn :disp (* -3 n-word-bytes))) + + ;; Push the return-pc so it looks like we just called. + (pushw rbp-tn -2) ; XXX dan ? + + ;; And away we go. + (inst jmp (make-ea :byte :base eax + :disp (- (* closure-fun-slot n-word-bytes) + fun-pointer-lowtag)))) + +(define-assembly-routine (throw + (:return-style :none)) + ((:arg target (descriptor-reg any-reg) rdx-offset) + (:arg start any-reg rbx-offset) + (:arg count any-reg rcx-offset) + (:temp catch any-reg rax-offset)) + + (declare (ignore start count)) + + (load-tl-symbol-value catch *current-catch-block*) + + LOOP + + (let ((error (generate-error-code nil unseen-throw-tag-error target))) + (inst or catch catch) ; check for NULL pointer + (inst jmp :z error)) + + (inst cmp target (make-ea-for-object-slot catch catch-block-tag-slot 0)) + (inst jmp :e EXIT) + + (loadw catch catch catch-block-previous-catch-slot) + (inst jmp LOOP) + + EXIT + + ;; Here EAX points to catch block containing symbol pointed to by EDX. + (inst jmp (make-fixup 'unwind :assembly-routine))) + +;;;; non-local exit noise + +(define-assembly-routine (unwind + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) rax-offset) + (:arg start (any-reg descriptor-reg) rbx-offset) + (:arg count (any-reg descriptor-reg) rcx-offset) + (:temp uwp unsigned-reg rsi-offset)) + (declare (ignore start count)) + + (let ((error (generate-error-code nil invalid-unwind-error))) + (inst or block block) ; check for NULL pointer + (inst jmp :z error)) + + (load-tl-symbol-value uwp *current-unwind-protect-block*) + + ;; Does *CURRENT-UNWIND-PROTECT-BLOCK* match the value stored in + ;; argument's CURRENT-UWP-SLOT? + (inst cmp uwp + (make-ea-for-object-slot block unwind-block-current-uwp-slot 0)) + ;; If a match, return to context in arg block. + (inst jmp :e DO-EXIT) + + ;; Not a match - return to *CURRENT-UNWIND-PROTECT-BLOCK* context. + ;; Important! Must save (and return) the arg 'block' for later use!! + (move rdx-tn block) + (move block uwp) + ;; Set next unwind protect context. + (loadw uwp uwp unwind-block-current-uwp-slot) + ;; we're about to reload ebp anyway, so let's borrow it here as a + ;; temporary. Hope this works + (store-tl-symbol-value uwp *current-unwind-protect-block* rbp-tn) + + DO-EXIT + + (loadw rbp-tn block unwind-block-current-cont-slot) + + ;; Uwp-entry expects some things in known locations so that they can + ;; be saved on the stack: the block in edx-tn, start in ebx-tn, and + ;; count in ecx-tn. + + (inst jmp (make-ea :byte :base block + :disp (* unwind-block-entry-pc-slot n-word-bytes)))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86-64/bit-bash.lisp sbcl-0.9.14/src/compiler/assembly/x86-64/bit-bash.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86-64/bit-bash.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/x86-64/bit-bash.lisp 2005-01-06 07:47:58.000000000 -0500 @@ -0,0 +1,12 @@ +;;;; just a dummy file to maintain parallelism with other VMs + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86-64/support.lisp sbcl-0.9.14/src/compiler/assembly/x86-64/support.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/assembly/x86-64/support.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/compiler/assembly/x86-64/support.lisp 2006-03-07 13:47:39.000000000 -0500 @@ -0,0 +1,43 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!VM") + +(!def-vm-support-routine generate-call-sequence (name style vop) + (ecase style + (:raw + (values + `((inst lea temp-reg-tn + (make-ea :qword :disp (make-fixup ',name :assembly-routine))) + (inst call temp-reg-tn)) + nil)) + (:full-call + (values + `((note-this-location ,vop :call-site) + (inst lea temp-reg-tn + (make-ea :qword :disp (make-fixup ',name :assembly-routine))) + (inst call temp-reg-tn) + (note-this-location ,vop :single-value-return) + (inst cmov :c rsp-tn rbx-tn)) + '((:save-p :compute-only)))) + (:none + (values + `((inst lea temp-reg-tn + (make-ea :qword :disp (make-fixup ',name :assembly-routine))) + (inst jmp temp-reg-tn)) + nil)))) + +(!def-vm-support-routine generate-return-sequence (style) + (ecase style + (:raw + `(inst ret)) + (:full-call + `((inst clc) + (inst ret))) + (:none))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/constraint.lisp sbcl-0.9.14/src/compiler/constraint.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/constraint.lisp 2006-03-28 04:59:07.000000000 -0500 +++ sbcl-0.9.14/src/compiler/constraint.lisp 2006-07-02 04:27:04.000000000 -0400 @@ -310,9 +310,9 @@ (aver (eql (numeric-type-class x) 'float)) (aver (eql (numeric-type-class y) 'float)) - #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) + #+sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) x - #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) + #-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (labels ((exclude (x) (cond ((not x) nil) (or-equal x) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/float-tran.lisp sbcl-0.9.14/src/compiler/float-tran.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/float-tran.lisp 2006-04-07 12:20:57.000000000 -0400 +++ sbcl-0.9.14/src/compiler/float-tran.lisp 2006-07-02 04:27:04.000000000 -0400 @@ -216,7 +216,7 @@ ;;; optimizers for SCALE-FLOAT. If the float has bounds, new bounds ;;; are computed for the result, if possible. -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (progn (defun scale-float-derive-type-aux (f ex same-arg) @@ -340,7 +340,7 @@ ;;; Derive the result to be float for argument types in the ;;; appropriate domain. -#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#+sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (dolist (stuff '((asin (real -1.0 1.0)) (acos (real -1.0 1.0)) (acosh (real 1.0)) @@ -356,7 +356,7 @@ type) (specifier-type 'float))))))) -#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#+sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (log derive-type) ((x &optional y)) (when (and (csubtypep (lvar-type x) (specifier-type '(real 0.0))) @@ -536,7 +536,7 @@ (list (coerce (car bound) type)) (coerce bound type)))) -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (progn ;;;; optimizers for elementary functions @@ -579,7 +579,7 @@ ;;; Test whether the numeric-type ARG is within in domain specified by ;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to ;;; be distinct. -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defun domain-subtypep (arg domain-low domain-high) (declare (type numeric-type arg) (type (or real null) domain-low domain-high)) @@ -615,7 +615,7 @@ (eval-when (:compile-toplevel :execute) (setf *read-default-float-format* 'single-float)) -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (progn ;;; Handle monotonic functions of a single variable whose domain is @@ -1085,7 +1085,7 @@ :complexp :real :low (numeric-type-low type) :high (numeric-type-high type)))))) -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (realpart derive-type) ((num)) (one-arg-derive-type num #'realpart-derive-type-aux #'realpart)) (defun imagpart-derive-type-aux (type) @@ -1109,7 +1109,7 @@ :complexp :real :low (numeric-type-low type) :high (numeric-type-high type)))))) -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (imagpart derive-type) ((num)) (one-arg-derive-type num #'imagpart-derive-type-aux #'imagpart)) @@ -1151,7 +1151,7 @@ :complex)))) (specifier-type 'complex))) -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (complex derive-type) ((re &optional im)) (if im (two-arg-derive-type re im #'complex-derive-type-aux-2 #'complex) @@ -1234,7 +1234,7 @@ ;;; possible answer. This gets around the problem of doing range ;;; reduction correctly but still provides useful results when the ;;; inputs are union types. -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (progn (defun trig-derive-type-aux (arg domain fcn &optional def-lo def-hi (increasingp t)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/fndb.lisp sbcl-0.9.14/src/compiler/fndb.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/fndb.lisp 2006-06-09 10:11:32.000000000 -0400 +++ sbcl-0.9.14/src/compiler/fndb.lisp 2006-07-02 04:27:04.000000000 -0400 @@ -244,12 +244,12 @@ (defknown lcm (&rest integer) unsigned-byte (movable foldable flushable explicit-check)) -#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#+sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defknown exp (number) irrational (movable foldable flushable explicit-check recursive) :derive-type #'result-type-float-contagion) -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defknown exp (number) irrational (movable foldable flushable explicit-check recursive)) @@ -267,7 +267,7 @@ (defknown cis (real) (complex float) (movable foldable flushable explicit-check)) -#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#+sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (progn (defknown (sin cos) (number) (or (float -1.0 1.0) (complex float)) @@ -284,7 +284,7 @@ :derive-type #'result-type-float-contagion) ) ; PROGN -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (progn (defknown (sin cos) (number) (or (float -1.0 1.0) (complex float)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/generic/genesis.lisp sbcl-0.9.14/src/compiler/generic/genesis.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/generic/genesis.lisp 2006-06-10 08:18:00.000000000 -0400 +++ sbcl-0.9.14/src/compiler/generic/genesis.lisp 2006-07-02 04:27:04.000000000 -0400 @@ -409,12 +409,17 @@ (let ((lowtag (descriptor-lowtag des)) (high (descriptor-high des)) (low (descriptor-low des))) + ;; We can only find a gspace for a pointer descriptor, so verify + ;; that we have a pointer lowtag. (if (or (eql lowtag sb!vm:fun-pointer-lowtag) (eql lowtag sb!vm:instance-pointer-lowtag) (eql lowtag sb!vm:list-pointer-lowtag) (eql lowtag sb!vm:other-pointer-lowtag)) (dolist (gspace (list *dynamic* *static* *read-only*) (error "couldn't find a GSPACE for ~S" des)) + ;; Check to see that the descriptor points to within the + ;; gspace, or is within the same 64k page as the end of the + ;; gspace. ;; This code relies on the fact that GSPACEs are aligned ;; such that the descriptor-low-bits low bits are zero. (when (and (>= high (ash (gspace-word-address gspace) @@ -1470,7 +1475,8 @@ (write-wordindexed fdefn sb!vm:fdefn-raw-addr-slot (make-random-descriptor - (cold-foreign-symbol-address "undefined_tramp")))) + (lookup-assembler-reference 'sb!vm::undefined-tramp) + #+nil (cold-foreign-symbol-address "undefined_tramp")))) fdefn)))) ;;; Handle the at-cold-init-time, fset-for-static-linkage operation @@ -1496,6 +1502,8 @@ (#.sb!vm:closure-header-widetag (/show0 "/static-fset (closure)") (make-random-descriptor + (lookup-assembler-reference 'sb!vm::closure-tramp) + #+nil (cold-foreign-symbol-address "closure_tramp"))))) fdefn)) @@ -1577,6 +1585,7 @@ (setf (gethash name *cold-foreign-symbol-table*) value)))))) (values)) ;; PROGN +#+(or) (defun cold-foreign-symbol-address (name) (or (find-foreign-symbol-in-table name *cold-foreign-symbol-table*) *foreign-symbol-placeholder-value* @@ -2492,6 +2501,7 @@ (write-wordindexed fn sb!vm:simple-fun-type-slot type) fn)) +#+(or) (define-cold-fop (fop-foreign-fixup) (let* ((kind (pop-stack)) (code-object (pop-stack)) @@ -2503,6 +2513,16 @@ (do-cold-fixup code-object offset value kind)) code-object)) +(define-cold-fop (fop-foreign-fixup) + (let* ((kind (pop-stack)) + (code-object (pop-stack)) + (len (read-byte-arg)) + (sym (make-string len))) + (read-string-as-bytes *fasl-input-stream* sym) + (let ((offset (read-word-arg))) + (cerror "Attempted foreign symbol access to ~A" sym)) + code-object)) + #!+linkage-table (define-cold-fop (fop-foreign-dataref-fixup) (let* ((kind (pop-stack)) @@ -2981,7 +3001,7 @@ ;; DATA PAGE ;; ADDRESS ;; PAGE COUNT - (write-word (gspace-identifier gspace)) +;; (write-word (gspace-identifier gspace)) (write-word (gspace-free-word-index gspace)) (write-word *data-page*) (multiple-value-bind (floor rem) @@ -3012,42 +3032,11 @@ :element-type '(unsigned-byte 8) :if-exists :rename-and-delete) - ;; Write the magic number. - (write-word core-magic) - - ;; Write the Version entry. - (write-word version-core-entry-type-code) - (write-word 3) - (write-word sbcl-core-version-integer) - - ;; Write the build ID. - (write-word build-id-core-entry-type-code) - (let ((build-id (with-open-file (s "output/build-id.tmp" - :direction :input) - (read s)))) - (declare (type simple-string build-id)) - (/show build-id (length build-id)) - ;; Write length of build ID record: BUILD-ID-CORE-ENTRY-TYPE-CODE - ;; word, this length word, and one word for each char of BUILD-ID. - (write-word (+ 2 (length build-id))) - (dovector (char build-id) - ;; (We write each character as a word in order to avoid - ;; having to think about word alignment issues in the - ;; sbcl-0.7.8 version of coreparse.c.) - (write-word (sb!xc:char-code char)))) - - ;; Write the New Directory entry header. - (write-word new-directory-core-entry-type-code) - (write-word 17) ; length = (5 words/space) * 3 spaces + 2 for header. - - (output-gspace *read-only*) - (output-gspace *static*) - (output-gspace *dynamic*) - ;; Write the initial function. - (write-word initial-fun-core-entry-type-code) - (write-word 3) - (let* ((cold-name (cold-intern '!cold-init)) +;; (write-word initial-fun-core-entry-type-code) +;; (write-word 3) + (let* ((cold-name (cold-intern 'sb!os-kernel:boot-kernel + #| '!cold-init |#)) (cold-fdefn (cold-fdefinition-object cold-name)) (initial-fun (read-wordindexed cold-fdefn sb!vm:fdefn-fun-slot))) @@ -3056,9 +3045,42 @@ (descriptor-bits initial-fun)) (write-word (descriptor-bits initial-fun))) +;; ;; Write the magic number. +;; (write-word core-magic) + +;; ;; Write the Version entry. +;; (write-word version-core-entry-type-code) +;; (write-word 3) +;; (write-word sbcl-core-version-integer) + +;; ;; Write the build ID. +;; (write-word build-id-core-entry-type-code) +;; (let ((build-id "" #+nil (with-open-file (s "output/build-id.tmp" +;; :direction :input) +;; (read s)))) +;; (declare (type simple-string build-id)) +;; (/show build-id (length build-id)) +;; ;; Write length of build ID record: BUILD-ID-CORE-ENTRY-TYPE-CODE +;; ;; word, this length word, and one word for each char of BUILD-ID. +;; (write-word (+ 2 (length build-id))) +;; (dovector (char build-id) +;; ;; (We write each character as a word in order to avoid +;; ;; having to think about word alignment issues in the +;; ;; sbcl-0.7.8 version of coreparse.c.) +;; (write-word (sb!xc:char-code char)))) + + ;; Write the New Directory entry header. +;; (write-word new-directory-core-entry-type-code) +;; (write-word 17) ; length = (5 words/space) * 3 spaces + 2 for header. + + (output-gspace *read-only*) + (output-gspace *static*) + (output-gspace *dynamic*) + ;; Write the End entry. - (write-word end-core-entry-type-code) - (write-word 2))) +;; (write-word end-core-entry-type-code) +;; (write-word 2) + )) (format t "done]~%") (force-output) @@ -3093,7 +3115,8 @@ symbol-table-file-name core-file-name map-file-name - c-header-dir-name) + c-header-dir-name + preload-file) (format t "~&beginning GENESIS, ~A~%" @@ -3110,7 +3133,7 @@ (when core-file-name (if symbol-table-file-name (load-cold-foreign-symbol-table symbol-table-file-name) - (error "can't output a core file without symbol table file input"))) + #+nil(error "can't output a core file without symbol table file input"))) ;; Now that we've successfully read our only input file (by ;; loading the symbol table, if any), it's a good time to ensure @@ -3153,6 +3176,9 @@ *cold-assembler-routines* #!+(or x86 x86-64) *load-time-code-fixups*) + (when preload-file + (cold-load preload-file)) + ;; Prepare for cold load. (initialize-non-nil-symbols) (initialize-layouts) @@ -3221,7 +3247,7 @@ (resolve-assembler-fixups) #!+(or x86 x86-64) (output-load-time-code-fixups) (foreign-symbols-to-core) - (finish-symbols) +;; (finish-symbols) (/show "back from FINISH-SYMBOLS") (finalize-load-time-value-noise) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/srctran.lisp sbcl-0.9.14/src/compiler/srctran.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/srctran.lisp 2006-05-15 07:47:44.000000000 -0400 +++ sbcl-0.9.14/src/compiler/srctran.lisp 2006-07-02 04:27:04.000000000 -0400 @@ -183,9 +183,9 @@ `(,',fun ,x 1))))) (deffrob truncate) (deffrob round) - #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) + #-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (deffrob floor) - #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) + #-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (deffrob ceiling)) ;;; This used to be a source transform (hence the lack of restrictions @@ -1199,7 +1199,7 @@ (make-canonical-union-type results) (first results))))))) -#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#+sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (progn (defoptimizer (+ derive-type) ((x y)) (derive-integer-type @@ -1250,7 +1250,7 @@ ) ; PROGN -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (progn (defun +-derive-type-aux (x y same-arg) (if (and (numeric-type-real-p x) @@ -1429,7 +1429,7 @@ (defoptimizer (ash derive-type) ((n shift)) (two-arg-derive-type n shift #'ash-derive-type-aux #'ash)) -#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#+sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (macrolet ((frob (fun) `#'(lambda (type type2) (declare (ignore type2)) @@ -1454,7 +1454,7 @@ (defoptimizer (lognot derive-type) ((int)) (lognot-derive-type-aux (lvar-type int))) -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (%negate derive-type) ((num)) (flet ((negate-bound (b) (and b @@ -1468,7 +1468,7 @@ :high (negate-bound (numeric-type-low type)))) #'-))) -#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#+sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (abs derive-type) ((num)) (let ((type (lvar-type num))) (if (and (numeric-type-p type) @@ -1488,7 +1488,7 @@ nil))) (numeric-contagion type type)))) -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defun abs-derive-type-aux (type) (cond ((eq (numeric-type-complexp type) :complex) ;; The absolute value of a complex number is always a @@ -1517,11 +1517,11 @@ :high (coerce-and-truncate-floats (interval-high abs-bnd) bound-type)))))) -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (abs derive-type) ((num)) (one-arg-derive-type num #'abs-derive-type-aux #'abs)) -#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#+sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (truncate derive-type) ((number divisor)) (let ((number-type (lvar-type number)) (divisor-type (lvar-type divisor)) @@ -1541,7 +1541,7 @@ divisor-low divisor-high)))) *universal-type*))) -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (progn (defun rem-result-type (number-type divisor-type) @@ -2124,7 +2124,7 @@ ;; anything about the result. `integer))))) -#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#+sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defun integer-rem-derive-type (number-low number-high divisor-low divisor-high) (if (and divisor-low divisor-high) @@ -2154,7 +2154,7 @@ 0 '*)))) -#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#+sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (random derive-type) ((bound &optional state)) (let ((type (lvar-type bound))) (when (numeric-type-p type) @@ -2170,7 +2170,7 @@ ((or (consp high) (zerop high)) high) (t `(,high)))))))) -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defun random-derive-type-aux (type) (let ((class (numeric-type-class type)) (high (numeric-type-high type)) @@ -2184,7 +2184,7 @@ ((or (consp high) (zerop high)) high) (t `(,high)))))) -#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) +#-sb-cross-float-infinity-kludge ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (defoptimizer (random derive-type) ((bound &optional state)) (one-arg-derive-type bound #'random-derive-type-aux nil)) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/x86/insts.lisp sbcl-0.9.14/src/compiler/x86/insts.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/x86/insts.lisp 2006-06-09 10:11:33.000000000 -0400 +++ sbcl-0.9.14/src/compiler/x86/insts.lisp 2006-07-02 04:27:04.000000000 -0400 @@ -1089,6 +1089,7 @@ (define-instruction fs-segment-prefix (segment) + (:printer byte ((op #x64))) (:emitter (emit-byte segment #x64))) @@ -1893,6 +1894,34 @@ (emit-byte segment #b00011000) (emit-ea segment ea #b011))) +;;;; I/O instructions + +(define-instruction in (segment accum port) + (:emitter + (aver (accumulator-p accum)) + (aver (or (and (integerp port) (<= 0 port #xff)) + (location= port dx-tn))) + (let ((size (operand-size accum))) + (maybe-emit-operand-size-prefix segment size) + (if (integerp port) + (progn + (emit-byte segment (if (eq size :byte) #b11100100 #b11100100)) + (emit-byte segment port)) + (emit-byte segment (if (eq size :byte) #b11101100 #b11101100)))))) + +(define-instruction out (segment port accum) + (:emitter + (aver (accumulator-p accum)) + (aver (or (and (integerp port) (<= 0 port #xff)) + (location= port dx-tn))) + (let ((size (operand-size accum))) + (maybe-emit-operand-size-prefix segment size) + (if (integerp port) + (progn + (emit-byte segment (if (eq size :byte) #b11100110 #b11100111)) + (emit-byte segment port)) + (emit-byte segment (if (eq size :byte) #b11101110 #b11101111)))))) + ;;;; interrupt instructions (defun snarf-error-junk (sap offset &optional length-only) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/compiler/x86/parms.lisp sbcl-0.9.14/src/compiler/x86/parms.lisp --- ../sbcl-sources/sbcl-0.9.14/src/compiler/x86/parms.lisp 2006-04-05 04:47:17.000000000 -0400 +++ sbcl-0.9.14/src/compiler/x86/parms.lisp 2006-07-02 04:27:04.000000000 -0400 @@ -151,6 +151,19 @@ ;;; set the top-down mmap allocation option in the kernel (not yet ;;; the default), all bets are totally off! +(progn + (def!constant read-only-space-start #x01000000) + (def!constant read-only-space-end #x037ff000) + + (def!constant static-space-start #x05000000) + (def!constant static-space-end #x07fff000) + + (def!constant dynamic-space-start #x09000000) + (def!constant dynamic-space-end #x29000000) + + (def!constant linkage-table-space-start #x70000000) + (def!constant linkage-table-space-end #x7ffff000)) + #!+win32 (progn @@ -362,7 +375,9 @@ sb!kernel:two-arg-ior sb!kernel:two-arg-xor sb!kernel:two-arg-gcd - sb!kernel:two-arg-lcm)) + sb!kernel:two-arg-lcm + + sb!os-kernel::common-interrupt-handler)) ;;;; stuff added by jrd diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/os/ata-hd.lisp sbcl-0.9.14/src/os/ata-hd.lisp --- ../sbcl-sources/sbcl-0.9.14/src/os/ata-hd.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/os/ata-hd.lisp 2006-07-02 07:55:34.000000000 -0400 @@ -0,0 +1,47 @@ +;;; +;;; ata-hd.lisp +;;; +;;; Quick hack ATA HD driver. +;;; + +(in-package "SB!OS-KERNEL") + +(locally + (declare (optimize (speed 3) (safety 0))) + + (defun hd-wait-busy () + (loop while (logbitp 7 (port-byte #x1f7)))) + + (defun hd-wait-ready () + (loop until (logbitp 3 (port-byte #x1f7)))) + + (defun hd-set-sector (sector one) + (declare (fixnum sector one)) + (setf (port-byte #x1f2) one) + (setf (port-byte #x1f3) (ldb (byte 8 0) sector)) + (setf (port-byte #x1f4) (ldb (byte 8 8) sector)) + (setf (port-byte #x1f5) (ldb (byte 8 16) sector)) + (setf (port-byte #x1f6) (logior #xe0 (ldb (byte 5 24) sector)))) + + (defun hd-read-sector (sector data) + (hd-wait-busy) + (hd-set-sector sector 1) + (setf (port-byte #x1f7) #x20) + (hd-wait-ready) + (read-port-words #x1f0 (sb!sys:int-sap data) #x100)) + + (defun hd-write-sector (sector data) + (hd-wait-busy) + (hd-set-sector sector 1) + (setf (port-byte #x1f7) #x30) + (hd-wait-ready) + (write-port-words #x1f0 (sb!sys:int-sap data) #x100)) + + #+(or) + (defun test-hd-read () + (hd-read-sector 0 #x8000) + (if (= (sap-ref-16 (sb!sys:int-sap #x8000) #x1fe) #xaa55) + (display-char #\!) + (display-char #\?)))) + +;;; EOF diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/os/display.lisp sbcl-0.9.14/src/os/display.lisp --- ../sbcl-sources/sbcl-0.9.14/src/os/display.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/os/display.lisp 2006-07-04 19:24:08.000000000 -0400 @@ -0,0 +1,148 @@ +;;; +;;; display.lisp +;;; +;;; textmode display driver +;;; + +(in-package "SB!OS-KERNEL") + +;;; Dword #x8000240c is specifically reserved to us. We need 3/4 of it. +;; DISPLAY-CURSOR-POSITION is where we store the position of the +;; hardware text cursor (the insertion point). +(def!constant display-cursor-position #x8000240c) +;; DISPLAY-ATTRIBUTE is where we store the color attribute byte +;; for text to be inserted. +(def!constant display-attribute #x8000240e) + +;; This is the address of the hardware framebuffer (it is in +;; identity-mapped memory) +(def!constant video-memory-base #xb8000) + +(def!constant display-width 80) +(def!constant display-height 25) +(def!constant display-total-chars (* display-width display-height)) + +;; The important setfs. +(defsetf crtc-reg %set-crtc-reg) +(defsetf hardware-cursor-position %set-hardware-cursor-position) +(defsetf display-cursor-position %set-display-cursor-position) +(defsetf display-attribute %set-display-attribute) + +(locally + (declare (optimize (speed 3) (safety 0))) + + ;; "simple" variable accessors. + ;; Probably should create a macro that uses define-symbol-macro + ;; and other junk to create the accessors and have them all look + ;; like normal symbols. + + (declaim (inline display-cursor-position)) + (defun display-cursor-position () + (sap-ref-16 (int-sap display-cursor-position) 0)) + + (declaim (inline %set-display-cursor-position)) + (defun %set-display-cursor-position (value) + (declare (type (unsigned-byte 16) value)) + (setf (sap-ref-16 (int-sap display-cursor-position) 0) value)) + + (declaim (inline display-attribute)) + (defun display-attribute () + (sap-ref-8 (int-sap display-attribute) 0)) + + (declaim (inline %set-display-attribute)) + (defun %set-display-attribute (value) + (declare (type (unsigned-byte 8) value)) + (setf (sap-ref-8 (int-sap display-attribute) 0) value)) + + + ;; Display controller register accessors + + (declaim (ftype (function ((unsigned-byte 8)) (values (unsigned-byte 8) &optional)) crtc-reg)) + (defun crtc-reg (reg) + (setf (port-byte #x3d4) reg) + (port-byte #x3d5)) + + (defun %set-crtc-reg (reg value) + (setf (port-byte #x3d4) reg) + (setf (port-byte #x3d5) value)) + + (defun hardware-cursor-position () + (dpb (crtc-reg #x0e) (byte 8 8) (crtc-reg #x0f))) + + (defun %set-hardware-cursor-position (value) + (declare (type (unsigned-byte 16) value)) + (setf (crtc-reg #x0e) (ldb (byte 8 8) value) + (crtc-reg #x0f) (ldb (byte 8 0) value)) + value) + + ;; Display driver functions + + (defun scroll-display-up () + (copy-dwords (int-sap (+ video-memory-base (* display-width 2))) + (int-sap video-memory-base) + (* (1- display-height) (/ display-width 2))) + (store-words (int-sap (+ video-memory-base + (* display-width 2 (1- display-height)))) + display-width #x0720)) + + (defun display-char (char) + (let ((code (logand #xff (char-code char)))) + (cond + ((= code 10) + ;; #\Newline + (let* ((position (display-cursor-position)) + (line (1+ (the (unsigned-byte 16) + ;; My preference is for floor, but truncate + ;; behaves the same for unsigned args, and + ;; manages to get inlined. + (#|floor|# truncate position display-width))))) + (declare (type (unsigned-byte 16) position line)) + (if (>= line display-height) + (progn + (scroll-display-up) + (setf position (* (1- display-height) display-width))) + (setf position (* line display-width))) + (setf (hardware-cursor-position) position + (display-cursor-position) position))) + ((= code 8) + ;; #\Backspace + (unless (zerop (display-cursor-position)) + (setf (hardware-cursor-position) + (decf (display-cursor-position))))) + (t + ;; presumed-displayable + (when (>= (display-cursor-position) display-total-chars) + (scroll-display-up)) + (let* ((position (display-cursor-position)) + (offset (ash position 1)) + (video-buffer (int-sap video-memory-base))) + (setf (sap-ref-16 video-buffer offset) + (dpb (display-attribute) (byte 8 8) code)) + (setf (hardware-cursor-position) + (setf (display-cursor-position) + (1+ position)))))))) + + (defun display-string (string) + (declare (type simple-base-string string)) + (loop for char across string + do (display-char char))) + + (defun display-byte (value) + (declare (type (unsigned-byte 8) value)) + (display-char (aref "0123456789abcdef" (ldb (byte 4 4) value))) + (display-char (aref "0123456789abcdef" (ldb (byte 4 0) value)))) + + (defun display-halfword (value) + (declare (type (unsigned-byte 16) value)) + (display-byte (ldb (byte 8 8) value)) + (display-byte (ldb (byte 8 0) value))) + + (defun init-display-driver () + ;; Use white text with a black background + (setf (display-attribute) 7) + ;; Read current cursor position from hardware. + (setf (display-cursor-position) + (hardware-cursor-position)))) + + +;;; EOF diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/os/idle.lisp sbcl-0.9.14/src/os/idle.lisp --- ../sbcl-sources/sbcl-0.9.14/src/os/idle.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/os/idle.lisp 2006-07-03 22:38:01.000000000 -0400 @@ -0,0 +1,16 @@ +;;; +;;; idle.lisp +;;; +;;; Idle task code +;;; + +(in-package "SB!VM") + +(define-assembly-routine + (idle-task-code (:return-style :none)) + () + OFF-A-CLIFF + (inst hlt) + (inst jmp off-a-cliff)) + +;;; EOF diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/os/interrupt-stubs.lisp sbcl-0.9.14/src/os/interrupt-stubs.lisp --- ../sbcl-sources/sbcl-0.9.14/src/os/interrupt-stubs.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/os/interrupt-stubs.lisp 2006-07-05 01:52:33.000000000 -0400 @@ -0,0 +1,127 @@ +;;; +;;; interrupt-stubs.lisp +;;; +;;; Initial stubs for interrupt handlers. +;;; + +(in-package "SB!VM") + +(define-assembly-routine + (interrupt-common (:return-style :none)) + () + ;; Save off the integer registers + (inst pusha) + + ;; In case this is a page fault, we need to save off CR2. + ;; The assembler doesn't know about control regs, so we hand code it + ;; to clobber and push EAX (since that encodes to 32 bits total). + (inst dword #x50d0220f) + + ;; Save off the user-mode segment registers + ;; The assembler doesn't know about segregs, so these are hand-coded + ;; DS, ES, FS, GS. + (inst byte #x1e) + (inst byte #x06) + (inst word #xa00f) + (inst word #xa80f) + + ;; Call out to central interrupt handler + (inst xor esi-tn esi-tn) + (inst push ebp-tn) + (inst push ebp-tn) + (inst push ebp-tn) + (inst lea ebp-tn (make-ea :dword :base esp-tn :disp 12)) + ;(inst mov ecx-tn (fixnumize 2)) + (inst xor ecx-tn ecx-tn) + (inst call (make-ea :dword :disp + (+ nil-value + (static-fun-offset + 'sb!os-kernel::common-interrupt-handler)))) + + ;; The central interrupt handler never returns normally, + ;; it calls ring3-restart, below. + ) + +(define-assembly-routine + (ring3-restart (:return-style :none)) + () + ;; We are called from a VOP which reloads ESP to point to the + ;; last word pushed as part of the standard entry prologue and + ;; then JMPs to us. We just have to restore the ring3 machine + ;; state and do an interrupt return. + + ;; Restore segregs + ;; Again, hand-coded. + ;; GS, FS, ES, DS. + (inst word #xa90f) + (inst word #xa10f) + (inst byte #x07) + (inst byte #x1f) + + ;; Skip the saved CR2 (eax is about to be reloaded anyway) + (inst pop eax-tn) + + ;; Restore integer registers + (inst popa) + + ;; Lose entry reason and error code (or dummy value) + (inst add esp-tn 8) + + ;; Return to caller + (inst iret)) + +(macrolet + ((stub (number push-code name) + `(define-assembly-routine (,name (:return-style :none)) + () + ;; Equalize stack depth + ,(unless push-code `(inst push 0)) + + ;; Save our interrupt number (entry reason) + (inst push ,number) + + ;; And jump to the common routine + (inst jmp (make-fixup 'interrupt-common :assembly-routine))))) + ;; First #x20 entries are CPU exceptions + (stub #x00 nil divide-by-zero) + (stub #x01 nil single-step) + (stub #x02 nil nonmaskable-interrupt) + (stub #x03 nil breakpoint) + (stub #x04 nil into-overflow) + (stub #x05 nil bound-overflow) + (stub #x06 nil invalid-opcode) + (stub #x07 nil coprocessor-unavailable) + (stub #x08 t double-fault) + (stub #x09 nil coprocessor-overrun) + (stub #x0a t invalid-task-segment) + (stub #x0b t segment-not-present) + (stub #x0c t stack-fault) + (stub #x0d t general-protection-fault) + (stub #x0e t page-fault) + ;; 0F is "reserved". + (stub #x10 nil coprocessor-error) + (stub #x11 t alignment-check) + ;; 12-1F are "reserved". + + ;; Next #x10 entries are hardware interrupts + (stub #x20 nil irq-0) + (stub #x21 nil irq-1) + (stub #x22 nil irq-2) + (stub #x23 nil irq-3) + (stub #x24 nil irq-4) + (stub #x25 nil irq-5) + (stub #x26 nil irq-6) + (stub #x27 nil irq-7) + (stub #x28 nil irq-8) + (stub #x29 nil irq-9) + (stub #x2a nil irq-10) + (stub #x2b nil irq-11) + (stub #x2c nil irq-12) + (stub #x2d nil irq-13) + (stub #x2e nil irq-14) + (stub #x2f nil irq-15) + + ;; Next is the special case syscall interface + (stub #xfffffffe nil syscall-entry)) + +;;; EOF diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/os/scratch.lisp sbcl-0.9.14/src/os/scratch.lisp --- ../sbcl-sources/sbcl-0.9.14/src/os/scratch.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/os/scratch.lisp 2006-07-02 04:27:04.000000000 -0400 @@ -0,0 +1,35 @@ +;;; +;;; scratch test file +;;; + +(cl:defpackage :foo + (:use :common-lisp :sb-sys :sb-int)) + +(in-package :foo) + +(def!constant gdt-base #x80010000) +(def!constant next-gdt-descriptor-address #x80002404) +(def!constant gdt-descriptor-limit-address #x80002408) + +(locally + (declare (optimize (speed 3) (safety 0))) + + (defun allocate-gdt-descriptor () + (let* ((next-gdt-descriptor-sap (int-sap next-gdt-descriptor-address)) + (gdt-limit (sap-ref-32 (int-sap gdt-descriptor-limit-address) 0)) + (initial-position (sap-ref-16 next-gdt-descriptor-sap 0)) + (gdt-sap (int-sap gdt-base))) + (declare (type (integer 0 #x10000) gdt-limit) + (type (integer 8 #xfff8) initial-position)) + (loop with position of-type (integer 8 #x10000) = initial-position + unless (logbitp 15 (sap-ref-16 gdt-sap (+ position 4))) + return (prog1 position + (setf (sap-ref-16 gdt-sap (+ position 4)) #x8000) + (setf (sap-ref-16 next-gdt-descriptor-sap 0) position)) + do (incf position 8) + when (= position gdt-limit) + do (setf position 8) + when (= position initial-position) + return nil)))) + +;;; EOF diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/os/system-vops.lisp sbcl-0.9.14/src/os/system-vops.lisp --- ../sbcl-sources/sbcl-0.9.14/src/os/system-vops.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/os/system-vops.lisp 2006-07-05 01:01:36.000000000 -0400 @@ -0,0 +1,355 @@ +;;; +;;; x86 OS kernel system hacking operations +;;; + +(in-package "SB!VM") + + +;;; CPU register access VOPs + +(defknown sb!os-kernel::load-idt-register + (system-area-pointer (unsigned-byte 32)) + (values) ()) + +(define-vop (load-idt-register) + (:translate sb!os-kernel::load-idt-register) + (:args (idt-sap :scs (sap-reg)) (idt-limit :scs (unsigned-reg))) + (:arg-types system-area-pointer unsigned-num) + (:generator 3 + (inst push idt-sap) + (inst shl idt-limit #x10) + (inst push idt-limit) + + ;; LIDT [ESP+2] + (inst byte #x0f) + (inst byte #x01) + (inst byte #x5c) + (inst byte #x24) + (inst byte #x02) + + (inst add esp-tn 8))) + +(defknown sb!os-kernel::load-task-register + ((unsigned-byte 16)) + (values) ()) + +(define-vop (load-task-register) + (:translate sb!os-kernel::load-task-register) + (:args (selector :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:generator 3 + ;; LTR + (inst byte #x0f) + (inst byte #x00) + (inst byte (logior #xd8 (reg-tn-encoding selector))))) + + +;;; HLT (stop-the-CPU) VOP + +(defknown sb!os-kernel::wait-for-interrupt + () + (values) ()) + +(define-vop (wait-for-interrupt) + (:translate sb!os-kernel::wait-for-interrupt) + (:generator 3 + (inst hlt))) + + +;;; Return-to-ring3 VOP (used during start-the-world) + +(defknown sb!os-kernel::start-ring3 + ((unsigned-byte 32)) + () ()) + +(define-vop (start-ring3) + (:translate sb!os-kernel::start-ring3) + (:args (ring0-esp :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:generator 3 + (inst mov esp-tn ring0-esp) + (inst jmp (make-fixup 'ring3-restart :assembly-routine)))) + + +;;; Ring-0 syscall interface + +(defmacro ring0-syscall (call-gate) + `(progn + ;; Okay, this is a little tricky. We reach the ring-0 context + ;; switcher by means of a call gate, but we -return- by way + ;; of an IRET instruction. In order to set the stack up for + ;; the IRET, and to make the saved context come out right, we + ;; have the call gate copy one argument, and PUSHFD the flags + ;; there. Because we return by IRET, the CPU doesn't clear + ;; the argument, so we have to. This must be done without + ;; interrupts, since we can't afford to take an interrupt + ;; while in ring 0.. + (inst pushf) + (inst cli) + ;; The assembler doesn't know about far calls, so... + (inst byte #x9a) + (inst dword 0) + (inst word ,call-gate) + (inst popf))) + + +;;; Manager thread switch-task-and-wait VOP + +(defknown sb!os-kernel::switch-task-and-wait + ((unsigned-byte 32) (unsigned-byte 16)) + (values (unsigned-byte 32)) ()) + +(define-vop (switch-task-and-wait) + (:translate sb!os-kernel::switch-task-and-wait) + (:args (task-thread-pointer :scs (unsigned-reg) :target edx)) + (:arg-types unsigned-num + (:constant (unsigned-byte 16))) + (:info call-gate) + (:temporary (:sc unsigned-reg :offset eax-offset) eax) + (:temporary (:sc unsigned-reg :offset edx-offset :target result :from (:argument 1) :to (:result 0)) edx) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 3 + ;; The context switcher takes a pointer to the lisp-side + ;; thread struct in EDX, and returns when an interrupt or + ;; exception occurs to another thread, with the faulting + ;; thread struct pointer in EDX. To request a context switch, + ;; we load AL with the value 0. + (move edx task-thread-pointer) + (inst xor al-tn al-tn) + (ring0-syscall call-gate) + (move result edx))) + + +;;; System panic stop + +(defknown sb!os-kernel::system-panic-stop + ((unsigned-byte 16)) + (values) ()) + +(define-vop (system-panic-stop) + (:translate sb!os-kernel::system-panic-stop) + (:arg-types (:constant (unsigned-byte 16))) + (:info call-gate) + (:temporary (:sc unsigned-reg :offset eax-offset) eax) + (:generator 3 + (inst mov al-tn 1) + (ring0-syscall call-gate))) + + +;;; Assembly-routine finding VOP + +(defknown sb!os-kernel::assembly-routine-address + (symbol) + (values (unsigned-byte 32)) (flushable)) + +(define-vop (assembly-routine-address) + (:translate sb!os-kernel::assembly-routine-address) + (:arg-types (:constant symbol)) + (:info routine-name) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 3 + ;; This is MOV , immed, with 32-bit immediate data. + (inst byte (logior #xb8 (reg-tn-encoding result))) + ;; And this is the 32-bit immediate data in question. + (emit-absolute-fixup (sb!assem::%%current-segment%%) + (make-fixup routine-name :assembly-routine)))) + +;;; I/O access VOPs + +(macrolet + ((def (name width reg) + (let ((setfun (intern (format nil "%SET-PORT-~A" name) "SB!OS-KERNEL")) + (getfun (intern (format nil "PORT-~A" name) "SB!OS-KERNEL")) + (setvop (intern (format nil "%SET-PORT-~A" name))) + (getvop (intern (format nil "PORT-~A" name))) + (setvop-c (intern (format nil "%SET-PORT-~A-C" name))) + (getvop-c (intern (format nil "PORT-~A-C" name)))) + `(progn + (defknown ,setfun ((unsigned-byte 16) (unsigned-byte ,width)) + (unsigned-byte ,width) ()) + (defknown ,getfun ((unsigned-byte 16)) + (unsigned-byte ,width) ()) + (define-vop (,setvop) + (:translate ,setfun) + (:args (port :scs (unsigned-reg) :target edx) + (value :scs (unsigned-reg) :target eax)) + (:arg-types unsigned-num unsigned-num) + (:temporary (:sc unsigned-reg :offset eax-offset :target result :from (:argument 1) :to (:result 0)) eax) + (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)) edx) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 5 + (move edx port) + (move eax value) + (inst out dx-tn ,reg) + (move result eax))) + (define-vop (,setvop-c) + (:translate ,setfun) + (:args (value :scs (unsigned-reg) :target eax)) + (:arg-types (:constant (unsigned-byte 8)) unsigned-num) + (:info port) + (:temporary (:sc unsigned-reg :offset eax-offset :target result :from (:argument 0) :to (:result 0)) eax) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 4 + (move eax value) + (inst out port ,reg) + (move result eax))) + (define-vop (,getvop) + (:translate ,getfun) + (:args (port :scs (unsigned-reg) :target edx)) + (:arg-types unsigned-num) + (:temporary (:sc unsigned-reg :offset eax-offset :target result :to (:result 0)) eax) + (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)) edx) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 5 + (move edx port) + ,(unless (= width 32) `(inst xor eax eax)) + (inst in ,reg dx-tn) + (move result eax))) + (define-vop (,getvop-c) + (:translate ,getfun) + (:arg-types (:constant (unsigned-byte 8))) + (:info port) + (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 4 + ,(unless (= width 32) `(inst xor eax eax)) + (inst in ,reg port) + (move result eax))))))) + (def byte 8 al-tn) + (def word 16 ax-tn) + (def dword 32 eax-tn)) + + +;;; "String" instruction operations (block data moves) + +(macrolet + ((def (name width accumulator) + (let ((fun (intern (format nil "COPY-~AS" name) "SB!OS-KERNEL")) + (dfun (intern (format nil "COPY-~AS-DOWN" name) "SB!OS-KERNEL")) + (sfun (intern (format nil "STORE-~AS" name) "SB!OS-KERNEL")) + (vop (intern (format nil "COPY-~AS" name))) + (dvop (intern (format nil "COPY-~AS-DOWN" name))) + (svop (intern (format nil "STORE-~AS" name)))) + `(progn + (defknown ,fun (system-area-pointer system-area-pointer + (unsigned-byte 32)) + (values) ()) + (defknown ,dfun (system-area-pointer system-area-pointer + (unsigned-byte 32)) + (values) ()) + (defknown ,sfun (system-area-pointer (unsigned-byte 32) + (unsigned-byte ,width)) + (values) ()) + (define-vop (,vop) + (:translate ,fun) + (:args (source :scs (sap-reg) :target esi) + (dest :scs (sap-reg) :target edi) + (count :scs (unsigned-reg) :target ecx)) + (:arg-types system-area-pointer system-area-pointer unsigned-num) + (:temporary (:sc sap-reg :offset esi-offset :from (:argument 0)) esi) + (:temporary (:sc sap-reg :offset edi-offset :from (:argument 1)) edi) + (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 2)) ecx) + (:generator 4 + (move esi source) + (move edi dest) + (move ecx count) + (inst cld) + (inst rep) + (inst movs ,name))) + (define-vop (,dvop) + (:translate ,dfun) + (:args (source :scs (sap-reg) :target esi) + (dest :scs (sap-reg) :target edi) + (count :scs (unsigned-reg) :target ecx)) + (:arg-types system-area-pointer system-area-pointer unsigned-num) + (:temporary (:sc sap-reg :offset esi-offset :from (:argument 0)) esi) + (:temporary (:sc sap-reg :offset edi-offset :from (:argument 1)) edi) + (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 2)) ecx) + (:generator 4 + (move esi source) + (move edi dest) + (move ecx count) + (inst lea esi (make-ea :dword :base esi :index ecx :scale ,(ash width -3) :offset ,(- (ash width -3)))) + (inst lea edi (make-ea :dword :base edi :index ecx :scale ,(ash width -3) :offset ,(- (ash width -3)))) + (inst std) + (inst rep) + (inst movs ,name))) + (define-vop (,svop) + (:translate ,sfun) + (:args (dest :scs (sap-reg) :target edi) + (count :scs (unsigned-reg) :target ecx) + (value :scs (unsigned-reg) :target eax)) + (:arg-types system-area-pointer unsigned-num unsigned-num) + (:temporary (:sc sap-reg :offset edi-offset :from (:argument 0)) edi) + (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx) + (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 2)) eax) + (:generator 4 + (move edi dest) + (move ecx count) + (move eax value) + (inst cld) + (inst rep) + (inst stos ,accumulator))))))) + (def :byte 8 al-tn) + (def :word 16 ax-tn) + (def :dword 32 eax-tn)) + + +;;; "String" I/O access + +(macrolet + ((def (name accumulator) + (let ((rfun (intern (format nil "READ-PORT-~AS" name) "SB!OS-KERNEL")) + (wfun (intern (format nil "WRITE-PORT-~AS" name) "SB!OS-KERNEL")) + (rvop (intern (format nil "READ-PORT-~AS" name))) + (wvop (intern (format nil "WRITE-PORT-~AS" name)))) + `(progn + (defknown ,rfun ((unsigned-byte 16) system-area-pointer + (unsigned-byte 32)) + (values) ()) + (defknown ,wfun ((unsigned-byte 16) system-area-pointer + (unsigned-byte 32)) + (values) ()) + (define-vop (,rvop) + (:translate ,rfun) + (:args (port :scs (unsigned-reg) :target edx) + (dest :scs (sap-reg) :target edi) + (count :scs (unsigned-reg) :target ecx)) + (:arg-types unsigned-num system-area-pointer unsigned-num) + (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)) edx) + (:temporary (:sc sap-reg :offset edi-offset :from (:argument 1)) edi) + (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 2)) ecx) + (:generator 4 + (move edx port) + (move edi dest) + (move ecx count) + (inst cld) + (inst rep) + (inst ins ,accumulator))) + (define-vop (,wvop) + (:translate ,wfun) + (:args (port :scs (unsigned-reg) :target edx) + (source :scs (sap-reg) :target esi) + (count :scs (unsigned-reg) :target ecx)) + (:arg-types unsigned-num system-area-pointer unsigned-num) + (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)) edx) + (:temporary (:sc sap-reg :offset esi-offset :from (:argument 1)) esi) + (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 2)) ecx) + (:generator 4 + (move edx port) + (move esi source) + (move ecx count) + (inst cld) + (inst rep) + (inst outs ,accumulator))))))) + (def :byte al-tn) + (def :word ax-tn) + (def :dword eax-tn)) + +;;; EOF diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/os/test.lisp sbcl-0.9.14/src/os/test.lisp --- ../sbcl-sources/sbcl-0.9.14/src/os/test.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/os/test.lisp 2006-07-05 02:07:28.000000000 -0400 @@ -0,0 +1,556 @@ +;;; +;;; test.lisp +;;; +;;; test for os-specific genesis. +;;; + +(in-package "SB!OS-KERNEL") + +;; Where we put things in our address space +(def!constant page-table-base #x80400000) +(def!constant page-directory-base #x80000000) +(def!constant gdt-base #x80010000) + +(def!constant page-table-base-pfn #x80400) + +(def!constant core-header-ppn #x400) +(def!constant core-header-pfn #x80002) +(def!constant page-allocator-address #x80002400) + +(def!constant next-gdt-descriptor-address #x80002404) +(def!constant gdt-descriptor-limit-address #x80002408) +;; #x8000240c is reserved to the display driver. +(def!constant manager-thread-pointer #x80002410) + +(def!constant manager-event-handler-table-pointer #x80002600) + +(def!constant idt-base #x80006000) +(def!constant idt-pfn #x80006) +(def!constant tss-base #x80006400) + +;; Memory management hardware constants +(def!constant page-protection-bits-ro 3) +(def!constant page-protection-bits-rw 7) + +;; Segment Descriptor types +(def!constant segment-type-data-read-only #x10) +(def!constant segment-type-data-read-write #x12) +(def!constant segment-type-code #x1a) + +(def!constant segment-type-ldt #x02) +(def!constant segment-type-tss #x09) +(def!constant segment-type-active-tss #x0b) +(def!constant segment-type-interrupt-gate #x0e) ;; Disables interrupts +(def!constant segment-type-trap-gate #x0f) ;; Leaves interrupt state unchanged + +;; Our initial task (later the manager thread for the first CPU). +(def!constant initial-task-address #x7c000400) +(def!constant initial-task-pfn #x7c000) + +;; Idle task +(def!constant idle-task-address #x7c010400) +(def!constant idle-task-pfn #x7c010) + +;; Known segment selectors (from Forth GDT setup) +(def!constant ring0-cs #x0008) +(def!constant ring0-ds #x0010) +(def!constant ring3-cs #x001b) +(def!constant ring3-ds #x0023) +(def!constant syscall-selector #x002b) + +;; Kernel-side task layout +(macrolet + ((frob (&rest slots) + `(progn + ,@(loop with slot-name + for slot in slots + for offset downfrom -4 by 4 + do (setf slot-name + (intern (format nil "KERNEL-TASK-~A-SLOT" slot))) + if slot + collect `(def!constant ,slot-name ,offset))))) + (frob ss esp eflags cs eip error-code entry-reason eax ecx edx ebx + nil ebp esi edi cr2 ds es fs gs)) +(def!constant kernel-task-ring3-restart-offset kernel-task-gs-slot) + +;; Port accessor setfs +(defsetf port-byte %set-port-byte) +(defsetf port-word %set-port-word) +(defsetf port-dword %set-port-dword) + +;; Manager thread access +(define-symbol-macro manager-thread-sap (sap-ref-sap (int-sap manager-thread-pointer) 0)) +(define-symbol-macro manager-thread-addr (sap-ref-32 (int-sap manager-thread-pointer) 0)) + +(locally + (declare (optimize (speed 3) (safety 0))) + + (defun new-page () + (let* ((page-allocator-sap (int-sap page-allocator-address)) + (ppn (sap-ref-32 page-allocator-sap 0))) + (declare (type (unsigned-byte 20) ppn)) + (setf (sap-ref-32 page-allocator-sap 0) (1+ ppn)) + ppn)) + + (defun clear-page (pfn) + (declare (type (unsigned-byte 20) pfn)) + (let ((page-sap (int-sap (* pfn #x1000)))) + (dotimes (offset #x400) + (setf (sap-ref-32 page-sap (* 4 offset)) 0)))) + + (defun map-page (ppn pfn protection) + (declare (type (unsigned-byte 20) ppn pfn)) + (declare (type (unsigned-byte 12) protection)) + (let ((page-table (ldb (byte 10 10) pfn)) + (page-directory-sap (int-sap page-directory-base)) + (page-table-sap (int-sap page-table-base))) + + ;; If there's no page table for that 4-meg range, map one. + (when (zerop (sap-ref-32 page-directory-sap (* 4 page-table))) + (let ((page-table-page (new-page)) + (page-table-pfn (+ page-table-base-pfn page-table))) + (declare (type (unsigned-byte 20) page-table-page page-table-pfn)) + (map-page page-table-page page-table-pfn page-protection-bits-rw) + (clear-page page-table-pfn) + (setf (sap-ref-32 page-directory-sap (* 4 page-table)) + (logior protection (* #x1000 page-table-page))))) + + (setf (sap-ref-32 page-table-sap (* 4 pfn)) + (logior protection (* #x1000 ppn)))) + pfn) + + (defun allocate-gdt-descriptor () + (let* ((next-gdt-descriptor-sap (int-sap next-gdt-descriptor-address)) + (gdt-limit (sap-ref-32 (int-sap gdt-descriptor-limit-address) 0)) + (initial-position (sap-ref-16 next-gdt-descriptor-sap 0)) + (gdt-sap (int-sap gdt-base))) + (declare (type (integer 0 #x10000) gdt-limit) + (type (integer 8 #xfff8) initial-position)) + (loop with position of-type (integer 8 #x10000) = initial-position + unless (logbitp 15 (sap-ref-16 gdt-sap (+ position 4))) + return (progn + ;; FIXME: the THE FIXNUM below is to work around + ;; type info lossage in the compiler. + (setf (sap-ref-16 gdt-sap (the fixnum (+ position 4))) #x8000) + (setf (sap-ref-16 next-gdt-descriptor-sap 0) position) + position) + do (incf position 8) + when (= position gdt-limit) + do (setf position 8) + when (= position initial-position) + return nil))) + + (defun configure-descriptor (table descriptor base-low-word base-high-word limit type dpl &key (granularity :16-bit) (default :16-bit)) + (declare (type (unsigned-byte 16) descriptor base-low-word base-high-word) + (type (integer 0 3) dpl) + (type (unsigned-byte 5) type) + (type (unsigned-byte 20) limit)) + (let* ((table-base (ecase table + (:gdt gdt-base) + (:idt idt-base) + ;; FIXME: What about LDT descriptors? + )) + (descriptor-sap (int-sap (logand #xffffffff (the (unsigned-byte 32) (+ (the (unsigned-byte 32) table-base) (the (unsigned-byte 32) descriptor)))))) + (word-0 (logand #xffff limit)) + (word-1 base-low-word) + (word-2 (logior #x8000 (ash dpl 13) (ash type 8) + (logand #xff base-high-word))) + (word-3 (logior (ldb (byte 4 16) limit) + (logand #xff00 base-high-word) + (ecase granularity + (:16-bit 0) + (:32-bit #x80)) + (ecase default + (:16-bit 0) + (:32-bit #x40))))) + (declare (type (unsigned-byte 32) table-base)) + (setf (sap-ref-16 descriptor-sap 0) word-0) + (setf (sap-ref-16 descriptor-sap 2) word-1) + (setf (sap-ref-16 descriptor-sap 4) word-2) + (setf (sap-ref-16 descriptor-sap 6) word-3))) + + (defun configure-interrupt-descriptor + (number dpl code-segment offset-low-word offset-high-word) + (declare (type (unsigned-byte 16) code-segment offset-low-word offset-high-word) + (type (unsigned-byte 8) number) + (type (integer 0 3) dpl)) + (let ((descriptor-sap (int-sap (logand #xffffffff (+ idt-base (* 8 number))))) + (word-2 (logior #x8000 (ash dpl 13) + (ash segment-type-interrupt-gate 8)))) + (setf (sap-ref-16 descriptor-sap 0) offset-low-word) + (setf (sap-ref-16 descriptor-sap 2) code-segment) + (setf (sap-ref-16 descriptor-sap 4) word-2) + (setf (sap-ref-16 descriptor-sap 6) offset-high-word))) + + (defun boot-kernel () + #!+sb-doc "Give the world a shove and hope it spins." + + ;; Map the core file header + (map-page core-header-ppn core-header-pfn page-protection-bits-rw) + + ;; Initialize the GDT descriptor allocator + (setf (sap-ref-32 (int-sap next-gdt-descriptor-address) 0) 8) + (setf (sap-ref-32 (int-sap gdt-descriptor-limit-address) 0) #x1000) + + ;; Map a page for the IDT and load IDTR + (map-page (new-page) idt-pfn page-protection-bits-rw) + (clear-page idt-pfn) + (let ((idt-sap (int-sap idt-base))) + (load-idt-register idt-sap #x7ff)) + + ;; Set up a TSS in the other half of the IDT page + (let ((tss-descriptor (allocate-gdt-descriptor))) + (configure-descriptor :gdt tss-descriptor + (ldb (byte 16 0) tss-base) + (ldb (byte 16 16) tss-base) + #x68 segment-type-tss 0) + ;; Set up CPL0 SS (ESP is per-task data) + (setf (sap-ref-32 (int-sap tss-base) 8) ring0-ds) + (load-task-register tss-descriptor)) + + ;; Set up our temporary alloc region + #+(or) + (let ((current-thread-sap (sb!vm::current-thread-offset-sap sb!vm::thread-this-slot))) + (setf (sap-ref-32 current-thread-sap (* 4 sb!vm::thread-alloc-region-slot)) #x7c00) + (setf (sap-ref-32 current-thread-sap (* 4 (1+ sb!vm::thread-alloc-region-slot))) #x8000)) + + ;; Create and start the initial task + (let* ((task-descriptor (allocate-gdt-descriptor)) + (task-seg (logior 3 task-descriptor)) + (task-sap (int-sap initial-task-address)) + (ebp (+ initial-task-address #x7400)) + (bsp (+ initial-task-address #x1400)) + (eflags #x00003000) ; IOPL3, no interrupts + (esp (- ebp #x10)) + (initial-function #'ring3-startup) + (eip (sap-ref-32 (int-sap (sb!kernel:get-lisp-obj-address initial-function)) -1))) + (declare (type (unsigned-byte 32) esp bsp eflags ebp eip) + (type (unsigned-byte 16) task-descriptor task-seg)) + + ;; One page for the thread structs, one page for the binding + ;; stack, six pages for the control stack, 8 pages total. + (dotimes (i 8) + (map-page (new-page) (+ initial-task-pfn i) page-protection-bits-rw) + (clear-page (+ initial-task-pfn i))) + + ;; Set up TLS descriptor. + (configure-descriptor :gdt task-descriptor + (ldb (byte 16 0) initial-task-address) + (ldb (byte 16 16) initial-task-address) + #x400 segment-type-data-read-write 3 + :granularity :32-bit) + + ;; Set up lisp thread structure. + (setf (sap-ref-32 task-sap (* 4 sb!vm::thread-no-tls-value-marker-slot)) + sb!vm:no-tls-value-marker-widetag) + (setf (sap-ref-32 task-sap + (* 4 sb!vm::thread-binding-stack-pointer-slot)) bsp) + (setf (sap-ref-32 task-sap (* 4 sb!vm::thread-os-thread-slot)) + initial-task-address) + (setf (sap-ref-32 task-sap (* 4 sb!vm::thread-this-slot)) + initial-task-address) + + ;; Set up CPL0 ESP in TSS + (setf (sap-ref-32 (int-sap tss-base) 4) initial-task-address) + + ;; Fake up a simple stack frame. + ;; frame link + (setf (sap-ref-32 (int-sap esp) 12) 0) + ;; return address save + (setf (sap-ref-32 (int-sap esp) 8) 0) + ;; useless spot + (setf (sap-ref-32 (int-sap esp) 4) 0) + ;; return address + (setf (sap-ref-32 (int-sap esp) 0) 0) + + ;; Set up saved task state. + (let () + ;; Exception frame + (setf (sap-ref-32 task-sap kernel-task-ss-slot) ring3-ds) + (setf (sap-ref-32 task-sap kernel-task-esp-slot) esp) + (setf (sap-ref-32 task-sap kernel-task-eflags-slot) eflags) + (setf (sap-ref-32 task-sap kernel-task-cs-slot) ring3-cs) + (setf (sap-ref-32 task-sap kernel-task-eip-slot) eip) + ;; Exception error code + (setf (sap-ref-32 task-sap kernel-task-error-code-slot) 0) + ;; Entry reason (exception/interrupt number) + (setf (sap-ref-32 task-sap kernel-task-entry-reason-slot) #xffffffff) + ;; Register values + (setf (sap-ref-32 task-sap kernel-task-eax-slot) + (sb!kernel:get-lisp-obj-address initial-function)) + (setf (sap-ref-32 task-sap kernel-task-ecx-slot) 0) + (setf (sap-ref-32 task-sap kernel-task-edx-slot) 0) + (setf (sap-ref-32 task-sap kernel-task-ebx-slot) 0) + (setf (sap-ref-32 task-sap kernel-task-ebp-slot) ebp) + (setf (sap-ref-32 task-sap kernel-task-esi-slot) 0) + (setf (sap-ref-32 task-sap kernel-task-edi-slot) 0) + ;; Segment registers + (setf (sap-ref-32 task-sap kernel-task-ds-slot) ring3-ds) + (setf (sap-ref-32 task-sap kernel-task-es-slot) ring3-ds) + (setf (sap-ref-32 task-sap kernel-task-fs-slot) task-seg) + (setf (sap-ref-32 task-sap kernel-task-gs-slot) 0) + ) + + ;; And see if she spins. + (start-ring3 (+ initial-task-address kernel-task-ring3-restart-offset)))) + + (defun initialize-ring0-interrupt-handlers () + (macrolet + ((stub (number push-code name) + (declare (ignore push-code)) + (let ((name (intern (symbol-name name) "SB!VM"))) + `(let ((address (assembly-routine-address ',name))) + (configure-interrupt-descriptor ,number 0 #x8 + (ldb (byte 16 0) address) + (ldb (byte 16 16) address)))))) + ;; FIXME: Massive duplication between here and interrupt-stubs.lisp. + (stub #x00 nil divide-by-zero) + (stub #x01 nil single-step) + (stub #x02 nil nonmaskable-interrupt) + (stub #x03 nil breakpoint) + (stub #x04 nil into-overflow) + (stub #x05 nil bound-overflow) + (stub #x06 nil invalid-opcode) + (stub #x07 nil coprocessor-unavailable) + (stub #x08 t double-fault) + (stub #x09 nil coprocessor-overrun) + (stub #x0a t invalid-task-segment) + (stub #x0b t segment-not-present) + (stub #x0c t stack-fault) + (stub #x0d t general-protection-fault) + (stub #x0e t page-fault) + ;; 0F is "reserved". + (stub #x10 nil coprocessor-error) + (stub #x11 t alignment-check) + ;; 12-1F are "reserved". + + (stub #x20 nil irq-0) + (stub #x21 nil irq-1) + (stub #x22 nil irq-2) + (stub #x23 nil irq-3) + (stub #x24 nil irq-4) + (stub #x25 nil irq-5) + (stub #x26 nil irq-6) + (stub #x27 nil irq-7) + (stub #x28 nil irq-8) + (stub #x29 nil irq-9) + (stub #x2a nil irq-10) + (stub #x2b nil irq-11) + (stub #x2c nil irq-12) + (stub #x2d nil irq-13) + (stub #x2e nil irq-14) + (stub #x2f nil irq-15))) + + (defun common-interrupt-handler () + ;; The TSS contains the CPL0 ESP for the current thread, + ;; which is also the address of the lisp-side thread + ;; structure and the top-end of the kernel-side thread + ;; structure. We read that to find the interrupted + ;; thread, and check the saved interrupt reason to see + ;; if we need to switch to the manager thread or if this + ;; is a syscall activation. + (let* ((thread-sap (sap-ref-sap (int-sap tss-base) 4)) + (interrupt-reason (sap-ref-32 thread-sap kernel-task-entry-reason-slot))) + (if (= interrupt-reason #xfffffffe) + (case (sap-ref-8 thread-sap kernel-task-eax-slot) + (0 ;; Task switch request + (let ((next-task (sap-ref-32 thread-sap kernel-task-edx-slot))) + ;; Task switch request. + ;; Set up CPL0 ESP in TSS + (setf (sap-ref-32 (int-sap tss-base) 4) next-task) + (start-ring3 (logand #xffffffff + (+ next-task + kernel-task-ring3-restart-offset))))) + (1 ;; System panic stop request + ;; FIXME: might want to figure out how to restart Forth here. + (loop (wait-for-interrupt))) + (t ;; Bogus syscall + (display-char #\Newline) + (display-string "") + (loop (wait-for-interrupt)))) + (progn + ;; Interrupt or exception. + (setf (sap-ref-sap manager-thread-sap + kernel-task-edx-slot) + thread-sap) + ;; Set up CPL0 ESP in TSS + (setf (sap-ref-32 (int-sap tss-base) 4) manager-thread-addr) + (start-ring3 (logand #xffffffff + (+ manager-thread-addr + kernel-task-ring3-restart-offset))))))) + + (defun setup-idle-task () + (let* ((task-sap (int-sap idle-task-address)) + (eflags #x00003200) ; IOPL3, interrupts enabled + (eip (assembly-routine-address 'sb!vm::idle-task-code))) + (declare (type (unsigned-byte 32) eflags eip)) + + ;; One page for the thread structs, nothing else. + (map-page (new-page) idle-task-pfn page-protection-bits-rw) + (clear-page idle-task-pfn) + + ;; Set up saved task state. + (let () + ;; Exception frame + (setf (sap-ref-32 task-sap kernel-task-ss-slot) 0) + (setf (sap-ref-32 task-sap kernel-task-esp-slot) 0) + (setf (sap-ref-32 task-sap kernel-task-eflags-slot) eflags) + (setf (sap-ref-32 task-sap kernel-task-cs-slot) ring0-cs) + (setf (sap-ref-32 task-sap kernel-task-eip-slot) eip) + ;; Exception error code + (setf (sap-ref-32 task-sap kernel-task-error-code-slot) 0) + ;; Entry reason (exception/interrupt number) + (setf (sap-ref-32 task-sap kernel-task-entry-reason-slot) #xffffffff) + ;; Register values + (setf (sap-ref-32 task-sap kernel-task-eax-slot) 0) + (setf (sap-ref-32 task-sap kernel-task-ecx-slot) 0) + (setf (sap-ref-32 task-sap kernel-task-edx-slot) 0) + (setf (sap-ref-32 task-sap kernel-task-ebx-slot) 0) + (setf (sap-ref-32 task-sap kernel-task-ebp-slot) 0) + (setf (sap-ref-32 task-sap kernel-task-esi-slot) 0) + (setf (sap-ref-32 task-sap kernel-task-edi-slot) 0) + ;; Segment registers + (setf (sap-ref-32 task-sap kernel-task-ds-slot) ring3-ds) + (setf (sap-ref-32 task-sap kernel-task-es-slot) ring3-ds) + (setf (sap-ref-32 task-sap kernel-task-fs-slot) 0) + (setf (sap-ref-32 task-sap kernel-task-gs-slot) 0))) + (values)) + + (defun setup-syscall-selector () + (let ((descriptor-sap (int-sap (+ gdt-base (logand -8 syscall-selector)))) + (entry-point (assembly-routine-address 'sb!vm::syscall-entry))) + (setf (sap-ref-16 descriptor-sap 0) (ldb (byte 16 0) entry-point)) + (setf (sap-ref-16 descriptor-sap 2) ring0-cs) + (setf (sap-ref-16 descriptor-sap 4) #xec01) + (setf (sap-ref-16 descriptor-sap 6) (ldb (byte 16 16) entry-point)))) + + (defun default-interrupt-handler (thread-low thread-high) + (declare (type (unsigned-byte 16) thread-low thread-high)) + (let* ((thread-ptr #+(or)(dpb thread-high (byte 16 16) thread-low) + (logior (ash thread-high 16) thread-low)) + (thread-sap (int-sap thread-ptr))) + (declare (type (unsigned-byte 32) thread-ptr)) + (display-char #\Newline) + (display-string "Unhandled interrupt ") + (display-byte (sap-ref-8 thread-sap kernel-task-entry-reason-slot)) + (display-string " from task ") + (display-halfword thread-high) + (display-halfword thread-low) + (display-char #\Newline) + + (display-string "EAX: ") + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-eax-slot 2))) + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-eax-slot 0))) + (display-string " EDX: ") + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-edx-slot 2))) + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-edx-slot 0))) + (display-string " ECX: ") + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-ecx-slot 2))) + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-ecx-slot 0))) + (display-string " EBX: ") + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-ebx-slot 2))) + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-ebx-slot 0))) + (display-char #\Newline) + (display-string "ESP: ") + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-esp-slot 2))) + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-esp-slot 0))) + (display-string " EBP: ") + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-ebp-slot 2))) + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-ebp-slot 0))) + (display-string " ESI: ") + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-esi-slot 2))) + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-esi-slot 0))) + (display-string " EDI: ") + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-edi-slot 2))) + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-edi-slot 0))) + (display-char #\Newline) + + (display-string "CS: ") + (display-halfword (sap-ref-16 thread-sap kernel-task-cs-slot)) + (display-string " DS: ") + (display-halfword (sap-ref-16 thread-sap kernel-task-ds-slot)) + (display-string " ES: ") + (display-halfword (sap-ref-16 thread-sap kernel-task-es-slot)) + (display-string " SS: ") + (display-halfword (sap-ref-16 thread-sap kernel-task-ss-slot)) + (display-string " FS: ") + (display-halfword (sap-ref-16 thread-sap kernel-task-fs-slot)) + (display-string " GS: ") + (display-halfword (sap-ref-16 thread-sap kernel-task-gs-slot)) + (display-char #\Newline) + + (display-string "EFLAGS: ") + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-eflags-slot 2))) + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-eflags-slot 0))) + (display-string " ERROR-CODE: ") + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-error-code-slot 2))) + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-error-code-slot 0))) + (display-string " CR2: ") + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-cr2-slot 2))) + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-cr2-slot 0))) + (system-panic-stop syscall-selector))) + + (defun setup-default-ring3-interrupt-handlers () + ;; Put the catch-all panic handlers in first. + (dotimes (i #x30) + (setf (sap-ref-32 (int-sap manager-event-handler-table-pointer) + (* i 4)) + (sb!kernel:get-lisp-obj-address #'default-interrupt-handler)))) + + (defun timer-interrupt-handler (thread-low thread-high) + (declare (ignore thread-low thread-high)) + ;; Timer was already configured by Forth, and I've forgotten + ;; the details. This is a literal translation of the disassembly. + (setf (port-byte #x70) #x0c) + (port-byte #x71) + (setf (port-byte #x20) #x20) + (setf (port-byte #xa0) #x20)) + + (defun setup-timer-interrupt () + (setf (sap-ref-32 (int-sap manager-event-handler-table-pointer) + (* #x28 4)) + (sb!kernel:get-lisp-obj-address #'timer-interrupt-handler)) + (values)) + + (defun ring3-startup () + (init-display-driver) + (initialize-ring0-interrupt-handlers) + (setup-default-ring3-interrupt-handlers) + (setup-idle-task) + (setup-syscall-selector) + (setup-timer-interrupt) + (display-string " +SBCL-os pre-milestone-1 (Boston) +") + (setf manager-thread-addr initial-task-address) + (manager-thread-toplevel)) + + (defun manager-thread-toplevel () + (loop with next-task = idle-task-address + do + (let* ((interrupted-task + (switch-task-and-wait next-task syscall-selector)) + (task-sap (int-sap interrupted-task)) + (interrupt-reason (sap-ref-16 task-sap + kernel-task-entry-reason-slot))) + ;; Interrupt-reason is an integer between 0 and 47 inclusive. + ;; 0 - 31 are CPU exceptions. 32 - 47 are IRQs. Anything else + ;; shouldn't get here. At this point we just use a table of + ;; function pointers to figure out what to do, but we could + ;; conceivably check to make sure we didn't get passed a + ;; bogus interrupt reason. + + ;; The compiler won't respect d-x for SAPs, so we split the + ;; task address in twain to pass to the handlers. + (funcall (the function + (sb!kernel:make-lisp-obj + (sap-ref-32 (int-sap + manager-event-handler-table-pointer) + (* interrupt-reason 4)))) + (ldb (byte 16 0) interrupted-task) + (ldb (byte 16 16) interrupted-task))))) + + ) + + +;;; EOF diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp ../sbcl-sources/sbcl-0.9.14/src/os/tramps.lisp sbcl-0.9.14/src/os/tramps.lisp --- ../sbcl-sources/sbcl-0.9.14/src/os/tramps.lisp 1969-12-31 19:00:00.000000000 -0500 +++ sbcl-0.9.14/src/os/tramps.lisp 2006-07-05 01:04:50.000000000 -0400 @@ -0,0 +1,23 @@ +;;; +;;; tramps.lisp +;;; +;;; critical trampolines. +;;; + +;;; This file preloaded by genesis so that the values are available to it. + +(in-package "SB!VM") + +(define-assembly-routine + (undefined-tramp (:return-style :none)) + () + (error-call nil undefined-fun-error eax-tn) + (inst ret)) + +(define-assembly-routine + (closure-tramp (:return-style :none)) + () + (inst mov eax-tn (make-ea :dword :base eax-tn)) + (inst jmp (make-ea :dword :base eax-tn))) + +;;; EOF