? src/os/ata-hd.trace ? src/os/display.trace ? src/os/port-io.trace ? src/os/test.trace Index: build-order.lisp-expr =================================================================== RCS file: /cvsroot/sbcl/sbcl/build-order.lisp-expr,v retrieving revision 1.67 diff -u -r1.67 build-order.lisp-expr --- build-order.lisp-expr 20 Jun 2006 05:38:42 -0000 1.67 +++ build-order.lisp-expr 18 Apr 2008 22:42:24 -0000 @@ -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,13 @@ ;; 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/port-io" :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/test" :not-host :target-os :trace-file) + ("src/os/system-vops")) Index: local-target-features.lisp-expr =================================================================== RCS file: local-target-features.lisp-expr diff -N local-target-features.lisp-expr --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ local-target-features.lisp-expr 18 Apr 2008 22:42:24 -0000 @@ -0,0 +1,4 @@ +;;;; This is a machine-generated file. +;;;; Please do not edit it by hand. +;;;; See make-config.sh. +(:x86 :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :stack-allocatable-closures :sb-thread) Index: make-stuff-happen.lisp =================================================================== RCS file: make-stuff-happen.lisp diff -N make-stuff-happen.lisp --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ make-stuff-happen.lisp 18 Apr 2008 22:42:24 -0000 @@ -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) Index: package-data-list.lisp-expr =================================================================== RCS file: /cvsroot/sbcl/sbcl/package-data-list.lisp-expr,v retrieving revision 1.357 diff -u -r1.357 package-data-list.lisp-expr --- package-data-list.lisp-expr 20 Jun 2006 05:38:42 -0000 1.357 +++ package-data-list.lisp-expr 18 Apr 2008 22:42:25 -0000 @@ -846,6 +846,9 @@ ;; in the cross-compiler's environment "DEF!CONSTANT" "DEF!MACRO" "DEF!METHOD" "DEF!STRUCT" "DEF!TYPE" + ;; os kernel support magic + "DEFUN-NONPAGED" + ;; stuff for hinting to the compiler "NAMED-LAMBDA" @@ -1081,6 +1084,7 @@ "!BEGIN-COLLECTING-COLD-INIT-FORMS" "!COLD-INIT-FORMS" "COLD-FSET" + "COLD-NONPAGED" "!DEFUN-FROM-COLLECTED-COLD-INIT-FORMS" ;; catch tags @@ -2347,6 +2351,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" Index: src/code/cross-char.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/cross-char.lisp,v retrieving revision 1.3 diff -u -r1.3 cross-char.lisp --- src/code/cross-char.lisp 14 Jul 2005 16:30:14 -0000 1.3 +++ src/code/cross-char.lisp 18 Apr 2008 22:42:25 -0000 @@ -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))))) Index: src/code/defboot.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/defboot.lisp,v retrieving revision 1.52 diff -u -r1.52 defboot.lisp --- src/code/defboot.lisp 15 May 2006 16:11:38 -0000 1.52 +++ src/code/defboot.lisp 18 Apr 2008 22:42:25 -0000 @@ -205,6 +205,12 @@ ',inline-lambda (sb!c:source-location))))))) +#+sb-xc-host +(defmacro-mundanely defun-nonpaged (name args &body body) + `(progn + (cold-nonpaged) + (defun ,name ,args ,@body))) + #-sb-xc-host (defun %defun (name def doc inline-lambda source-location) (declare (ignore source-location)) Index: src/code/fop.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/fop.lisp,v retrieving revision 1.44 diff -u -r1.44 fop.lisp --- src/code/fop.lisp 13 May 2006 17:20:03 -0000 1.44 +++ src/code/fop.lisp 18 Apr 2008 22:42:25 -0000 @@ -777,3 +777,7 @@ (when (eql *skip-until* label) (setf *skip-until* nil))) (values)) + +;;; For non-paged code +(define-fop (fop-cold-nonpaged 220 :pushp nil) + (values)) Index: src/code/stream.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/stream.lisp,v retrieving revision 1.83 diff -u -r1.83 stream.lisp --- src/code/stream.lisp 20 Nov 2005 19:40:03 -0000 1.83 +++ src/code/stream.lisp 18 Apr 2008 22:42:26 -0000 @@ -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 Index: src/cold/compile-cold-sbcl.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/cold/compile-cold-sbcl.lisp,v retrieving revision 1.7 diff -u -r1.7 compile-cold-sbcl.lisp --- src/cold/compile-cold-sbcl.lisp 14 Jul 2005 16:30:41 -0000 1.7 +++ src/cold/compile-cold-sbcl.lisp 18 Apr 2008 22:42:26 -0000 @@ -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))) Index: src/cold/shared.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/cold/shared.lisp,v retrieving revision 1.38 diff -u -r1.38 shared.lisp --- src/cold/shared.lisp 14 Jul 2005 16:30:41 -0000 1.38 +++ src/cold/shared.lisp 18 Apr 2008 22:42:26 -0000 @@ -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) Index: src/compiler/constraint.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/constraint.lisp,v retrieving revision 1.29 diff -u -r1.29 constraint.lisp --- src/compiler/constraint.lisp 28 Mar 2006 09:59:07 -0000 1.29 +++ src/compiler/constraint.lisp 18 Apr 2008 22:42:26 -0000 @@ -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) Index: src/compiler/float-tran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/float-tran.lisp,v retrieving revision 1.38 diff -u -r1.38 float-tran.lisp --- src/compiler/float-tran.lisp 7 Apr 2006 16:20:57 -0000 1.38 +++ src/compiler/float-tran.lisp 18 Apr 2008 22:42:26 -0000 @@ -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)) Index: src/compiler/fndb.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/fndb.lisp,v retrieving revision 1.117 diff -u -r1.117 fndb.lisp --- src/compiler/fndb.lisp 6 Jun 2006 02:42:51 -0000 1.117 +++ src/compiler/fndb.lisp 18 Apr 2008 22:42:26 -0000 @@ -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)) Index: src/compiler/main.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/main.lisp,v retrieving revision 1.115 diff -u -r1.115 main.lisp --- src/compiler/main.lisp 13 May 2006 17:20:04 -0000 1.115 +++ src/compiler/main.lisp 18 Apr 2008 22:42:27 -0000 @@ -1081,6 +1081,11 @@ (mapc #'clear-ir1-info components-from-dfo) (clear-stuff))))))) +(defun process-toplevel-cold-nonpaged () + (unless (producing-fasl-file) + (error "can't COLD-NONPAGED except in a fasl file")) + (sb!fasl::dump-fop 'sb!fasl::fop-cold-nonpaged *compile-object*)) + (defun process-toplevel-cold-fset (name lambda-expression path) (unless (producing-fasl-file) (error "can't COLD-FSET except in a fasl file")) @@ -1227,6 +1232,10 @@ (process-toplevel-cold-fset fun-name lambda-expression path))) + #+sb-xc-host + ((cold-nonpaged) + (aver (not compile-time-too)) + (process-toplevel-cold-nonpaged)) ((eval-when macrolet symbol-macrolet);things w/ 1 arg before body (need-at-least-one-arg form) (destructuring-bind (special-operator magic &rest body) form Index: src/compiler/srctran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/srctran.lisp,v retrieving revision 1.140 diff -u -r1.140 srctran.lisp --- src/compiler/srctran.lisp 15 May 2006 11:47:44 -0000 1.140 +++ src/compiler/srctran.lisp 18 Apr 2008 22:42:28 -0000 @@ -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)) Index: src/compiler/generic/genesis.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/generic/genesis.lisp,v retrieving revision 1.121 diff -u -r1.121 genesis.lisp --- src/compiler/generic/genesis.lisp 10 Jun 2006 05:07:24 -0000 1.121 +++ src/compiler/generic/genesis.lisp 18 Apr 2008 22:42:29 -0000 @@ -222,6 +222,7 @@ ;;; copying GC is in use), then only the active dynamic space gets ;;; dumped to core. (defvar *dynamic*) +(defvar *real-dynamic*) ;; KLUDGE: Sometimes we want to allocate into static. (defconstant dynamic-core-space-id 1) (defvar *static*) @@ -409,12 +410,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*) + (dolist (gspace (list *real-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 +1476,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 +1503,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 +1586,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* @@ -2352,7 +2362,8 @@ (if (gethash warm-name *cold-fset-warm-names*) (error "duplicate COLD-FSET for ~S" warm-name) (setf (gethash warm-name *cold-fset-warm-names*) t)) - (static-fset cold-name fn))) + (static-fset cold-name fn) + (setf *dynamic* *real-dynamic*))) (define-cold-fop (fop-fdefinition) (cold-fdefinition-object (pop-stack))) @@ -2360,6 +2371,9 @@ (define-cold-fop (fop-sanctify-for-execution) (pop-stack)) +(define-cold-fop (fop-cold-nonpaged :pushp nil) + (setf *dynamic* *static*)) + ;;; Setting this variable shows what code looks like before any ;;; fixups (or function headers) are applied. #!+sb-show (defvar *show-pre-fixup-code-p* nil) @@ -2492,6 +2506,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 +2518,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 +3006,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 +3037,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 +3050,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 *real-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 +3120,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 +3138,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 @@ -3140,10 +3168,11 @@ (*static* (make-gspace :static static-core-space-id sb!vm:static-space-start)) - (*dynamic* (make-gspace :dynamic - dynamic-core-space-id - #!+gencgc sb!vm:dynamic-space-start - #!-gencgc sb!vm:dynamic-0-space-start)) + (*real-dynamic* (make-gspace :dynamic + dynamic-core-space-id + #!+gencgc sb!vm:dynamic-space-start + #!-gencgc sb!vm:dynamic-0-space-start)) + (*dynamic* *real-dynamic*) (*nil-descriptor* (make-nil-descriptor)) (*current-reversed-cold-toplevels* *nil-descriptor*) (*unbound-marker* (make-other-immediate-descriptor @@ -3153,6 +3182,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 +3253,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) Index: src/compiler/x86/insts.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/insts.lisp,v retrieving revision 1.37 diff -u -r1.37 insts.lisp --- src/compiler/x86/insts.lisp 31 May 2006 02:26:34 -0000 1.37 +++ src/compiler/x86/insts.lisp 18 Apr 2008 22:42:29 -0000 @@ -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) Index: src/compiler/x86/parms.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/parms.lisp,v retrieving revision 1.59 diff -u -r1.59 parms.lisp --- src/compiler/x86/parms.lisp 5 Apr 2006 08:47:17 -0000 1.59 +++ src/compiler/x86/parms.lisp 18 Apr 2008 22:42:29 -0000 @@ -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 Index: src/os/ata-hd.lisp =================================================================== RCS file: src/os/ata-hd.lisp diff -N src/os/ata-hd.lisp --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ src/os/ata-hd.lisp 18 Apr 2008 22:42:30 -0000 @@ -0,0 +1,55 @@ +;;; +;;; ata-hd.lisp +;;; +;;; Quick hack ATA HD driver. +;;; + +(in-package "SB!OS-KERNEL") + +(locally + (declare (optimize (speed 3) (safety 0))) + + (defun-nonpaged hd-wait-busy () + (loop while (logbitp 7 (port-byte #x1f7)))) + + (defun-nonpaged hd-wait-ready () + (loop until (logbitp 3 (port-byte #x1f7)))) + + (defun-nonpaged 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-nonpaged 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-nonpaged 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)) + + (defun-nonpaged hd-page-in (sector pfn) + (declare (type (unsigned-byte 20) pfn)) + (hd-wait-busy) + (hd-set-sector sector 8) ;; #x200 bytes/sector, #x1000 bytes/page. + (setf (port-byte #x1f7) #x20) + (hd-wait-ready) + (read-port-words #x1f0 (sb!sys:int-sap (ash pfn 12)) #x800)) + + #+(or) + (defun-nonpaged test-hd-read () + (hd-read-sector 0 #x8000) + (if (= (sap-ref-16 (sb!sys:int-sap #x8000) #x1fe) #xaa55) + (display-char #\!) + (display-char #\?)))) + +;;; EOF Index: src/os/display.lisp =================================================================== RCS file: src/os/display.lisp diff -N src/os/display.lisp --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ src/os/display.lisp 18 Apr 2008 22:42:30 -0000 @@ -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-nonpaged display-cursor-position () + (sap-ref-16 (int-sap display-cursor-position) 0)) + + (declaim (inline %set-display-cursor-position)) + (defun-nonpaged %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-nonpaged display-attribute () + (sap-ref-8 (int-sap display-attribute) 0)) + + (declaim (inline %set-display-attribute)) + (defun-nonpaged %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-nonpaged crtc-reg (reg) + (setf (port-byte #x3d4) reg) + (port-byte #x3d5)) + + (defun-nonpaged %set-crtc-reg (reg value) + (setf (port-byte #x3d4) reg) + (setf (port-byte #x3d5) value)) + + (defun-nonpaged hardware-cursor-position () + (dpb (crtc-reg #x0e) (byte 8 8) (crtc-reg #x0f))) + + (defun-nonpaged %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-nonpaged 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-nonpaged 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-nonpaged display-string (string) + (declare (type simple-base-string string)) + (loop for char across string + do (display-char char))) + + (defun-nonpaged 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-nonpaged display-halfword (value) + (declare (type (unsigned-byte 16) value)) + (display-byte (ldb (byte 8 8) value)) + (display-byte (ldb (byte 8 0) value))) + + (defun-nonpaged 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 Index: src/os/idle.lisp =================================================================== RCS file: src/os/idle.lisp diff -N src/os/idle.lisp --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ src/os/idle.lisp 18 Apr 2008 22:42:30 -0000 @@ -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 Index: src/os/interrupt-stubs.lisp =================================================================== RCS file: src/os/interrupt-stubs.lisp diff -N src/os/interrupt-stubs.lisp --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ src/os/interrupt-stubs.lisp 18 Apr 2008 22:42:30 -0000 @@ -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 #x50d0200f) + + ;; 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 Index: src/os/port-io.lisp =================================================================== RCS file: src/os/port-io.lisp diff -N src/os/port-io.lisp --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ src/os/port-io.lisp 18 Apr 2008 22:42:30 -0000 @@ -0,0 +1,14 @@ +;;; +;;; port-io.lisp +;;; +;;; x86 I/O port access. +;;; + +(in-package "SB!OS-KERNEL") + +;; Port accessor setfs +(defsetf port-byte %set-port-byte) +(defsetf port-word %set-port-word) +(defsetf port-dword %set-port-dword) + +;;; EOF Index: src/os/scratch.lisp =================================================================== RCS file: src/os/scratch.lisp diff -N src/os/scratch.lisp --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ src/os/scratch.lisp 18 Apr 2008 22:42:30 -0000 @@ -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 Index: src/os/system-vops.lisp =================================================================== RCS file: src/os/system-vops.lisp diff -N src/os/system-vops.lisp --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ src/os/system-vops.lisp 18 Apr 2008 22:42:30 -0000 @@ -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 Index: src/os/test.lisp =================================================================== RCS file: src/os/test.lisp diff -N src/os/test.lisp --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ src/os/test.lisp 18 Apr 2008 22:42:30 -0000 @@ -0,0 +1,817 @@ +;;; +;;; 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 address-allocator-address #x80002414) + +(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) + +;; 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-nonpaged 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-nonpaged 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-nonpaged 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-nonpaged allocate-address-range (pages) + (declare (type (unsigned-byte 20) pages)) + (the (unsigned-byte 20) + (prog1 + (sap-ref-32 (int-sap address-allocator-address) 0) + (setf (sap-ref-32 (int-sap address-allocator-address) 0) + (the (unsigned-byte 20) + (+ (sap-ref-32 (int-sap address-allocator-address) 0) + pages)))))) + + (defun-nonpaged 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-nonpaged 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-nonpaged 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-nonpaged 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)) + + ;; Initialize the address-space allocator + (setf (sap-ref-32 (int-sap address-allocator-address) 0) #x30000) + + ;; 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-nonpaged 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-nonpaged 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 + ;; FIXME: Should probably dump to debugger instead. + (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-nonpaged 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-nonpaged 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-nonpaged dump-task-state-and-panic (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-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))) + + (display-char #\Newline) + (display-string "EIP: ") + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-eip-slot 2))) + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-eip-slot 0))) + + (system-panic-stop syscall-selector))) + + (defun-nonpaged 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) + + (dump-task-state-and-panic thread-low thread-high))) + + (defun-nonpaged 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-nonpaged 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-nonpaged page-fault-handler (thread-low thread-high) + (declare (type (unsigned-byte 16) thread-low thread-high)) + (let* ((thread-ptr (logior (ash thread-high 16) thread-low)) + (thread-sap (int-sap thread-ptr)) + (error-code (sap-ref-32 thread-sap kernel-task-error-code-slot))) + (declare (type (unsigned-byte 32) thread-ptr)) + (display-char #\Newline) + (display-string "Page fault from task ") + (display-halfword thread-high) + (display-halfword thread-low) + (if (logbitp 1 error-code) + (display-string " writing") + (display-string " reading")) + (if (logbitp 0 error-code) + (display-string " protected") + (display-string " not-present")) + (display-string " address #x") + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-cr2-slot 2))) + (display-halfword (sap-ref-16 thread-sap (+ kernel-task-cr2-slot 0))) + (display-char #\Newline) + + (let* ((core-header (int-sap #x80002000)) + (pfn (ash (sap-ref-32 thread-sap kernel-task-cr2-slot) -12)) + (page-region-start-pfn (sap-ref-32 core-header #x2c)) + (page-region-last-pfn (+ page-region-start-pfn + ;; Size is in words, not bytes. + (ash (sap-ref-32 core-header #x24) -10))) + (page-region-start-dpn (+ 1 (the (unsigned-byte 20) + (sap-ref-32 core-header #x28))))) + (declare (type (unsigned-byte 20) + page-region-start-pfn page-region-last-pfn)) + (if (and (not (logbitp 0 error-code)) ;; page-not-present + (<= page-region-start-pfn pfn page-region-last-pfn)) + (progn + (display-string "Page fill required.") + (display-char #\Newline) + ;; Map new page to faulted pfn. + (map-page (new-page) pfn page-protection-bits-rw) + ;; Read page contents from disk. + (hd-page-in (* 8 (+ page-region-start-dpn + (- pfn page-region-start-pfn))) + pfn) + #+(or) + (dump-task-state-and-panic thread-low thread-high)) + (progn + (display-string "Out of bounds: (< ") + (display-halfword (ash page-region-start-pfn -16)) + (display-halfword (logand #xffff page-region-start-pfn)) + (display-char #\Space) + (display-halfword (ash pfn -16)) + (display-halfword (logand #xffff pfn)) + (display-char #\Space) + (display-halfword (ash page-region-last-pfn -16)) + (display-halfword (logand #xffff page-region-last-pfn)) + (display-string ") +") + (dump-task-state-and-panic thread-low thread-high)))))) + + (defun-nonpaged setup-page-fault-handler () + (setf (sap-ref-32 (int-sap manager-event-handler-table-pointer) + (* #x0e 4)) + (sb!kernel:get-lisp-obj-address #'page-fault-handler)) + (values)) + + (defun-nonpaged 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-nonpaged test-ring3-function () + (display-string " +TEST-RING3-FUNCTION invoked. +") + (test-page-fault)) + + (defun test-page-fault () + + (display-string "In paged (dynamic) space. +") + ;; More to trigger a breakpoint than to actually do cold-init. + (!cold-init)) + + (defun-nonpaged create-task-struct () + ;; Returns task-address as a lisp object (the low bits are 00, so a fixnum). + (let* ((num-task-pages 4) + (task-page-pfn (allocate-address-range num-task-pages)) + + (task-descriptor (allocate-gdt-descriptor)) + (task-seg (logior 3 task-descriptor)) + + (task-address (+ (ash task-page-pfn 12) #x400)) + (task-sap (int-sap task-address))) + (declare (type (unsigned-byte 16) task-descriptor task-seg) + (type (unsigned-byte 20) task-page-pfn) + (type (unsigned-byte 32) task-address)) + + ;; Map task and TLS memory. + (dotimes (i num-task-pages) + (map-page (new-page) (+ task-page-pfn i) page-protection-bits-rw)) + + ;; Initialize task and TLS memory. + (dotimes (offset #x100) + (setf (sap-ref-32 task-sap (* 4 (- offset #x100))) 0)) + (dotimes (offset #xf00) + (setf (sap-ref-32 task-sap (* 4 offset)) + sb!vm:no-tls-value-marker-widetag)) + + ;; Set up TLS descriptor. + (configure-descriptor :gdt task-descriptor + (ldb (byte 16 0) task-address) + (ldb (byte 16 16) task-address) + #x3c00 segment-type-data-read-write 3 + :granularity :32-bit) + + ;; Set up lisp thread structure. + (setf (sap-ref-32 task-sap (* 4 sb!vm::thread-os-thread-slot)) + task-address) + (setf (sap-ref-32 task-sap (* 4 sb!vm::thread-this-slot)) + task-address) + + ;; Set up initial register state. + (setf (sap-ref-32 task-sap kernel-task-ss-slot) ring3-ds) + (setf (sap-ref-32 task-sap kernel-task-cs-slot) ring3-cs) + (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) + + (setf (sap-ref-32 task-sap kernel-task-eflags-slot) + #x00003200) ;; IOPL 3, interrupts enabled. + + (setf (sap-ref-32 task-sap kernel-task-entry-reason-slot) #xffffffff) + + ;; Set up pseudo-atomic (p-a must die): + (setf (sap-ref-32 task-sap + (* 4 sb!vm::thread-pseudo-atomic-atomic-slot)) 0) + (setf (sap-ref-32 task-sap + (* 4 sb!vm::thread-pseudo-atomic-interrupted-slot)) 0) + + ;; FIXME: Set up empty alloc region. + + (sb!kernel:make-lisp-obj task-address))) + + (defun-nonpaged create-control-stack (task pages) + (declare (type (unsigned-byte 20) pages)) + (let* ((task-sap (int-sap (sb!kernel:get-lisp-obj-address task))) + (stack-base (allocate-address-range pages)) + (stack-top-addr (ash stack-base 12)) + (stack-bottom-addr (ash (+ stack-base pages) 12))) + (declare (type (unsigned-byte 20) stack-base) + (type (unsigned-byte 32) stack-bottom-addr)) + + ;; FIXME: Lazy-commit stack memory, add guard page. + (dotimes (i pages) + (map-page (new-page) (+ stack-base i) page-protection-bits-rw)) + + (setf (sap-ref-32 task-sap (* 4 sb!vm::thread-control-stack-start-slot)) + stack-top-addr) + (setf (sap-ref-32 task-sap (* 4 sb!vm::thread-control-stack-end-slot)) + stack-bottom-addr) + (setf (sap-ref-32 task-sap kernel-task-esp-slot) stack-bottom-addr) + (setf (sap-ref-32 task-sap kernel-task-ebp-slot) stack-bottom-addr)) + + (values)) + + (defun-nonpaged create-binding-stack (task pages) + (declare (type (unsigned-byte 20) pages)) + (let* ((task-sap (int-sap (sb!kernel:get-lisp-obj-address task))) + (stack-base (allocate-address-range pages)) + (stack-top-addr (ash stack-base 12)) + #+(or) + (stack-bottom-addr (ash (+ stack-base pages) 12))) + (declare (type (unsigned-byte 20) stack-base)) + + ;; FIXME: Lazy-commit stack memory, add guard page. + (dotimes (i pages) + (map-page (new-page) (+ stack-base i) page-protection-bits-rw)) + + (setf (sap-ref-32 task-sap (* 4 sb!vm::thread-binding-stack-start-slot)) + stack-top-addr) + (setf (sap-ref-32 task-sap (* 4 sb!vm::thread-binding-stack-pointer-slot)) + stack-top-addr)) + + (values)) + + (defun-nonpaged create-ring3-task (initial-function args &key (control-stack-pages 8) (binding-stack-pages 4)) + (declare (dynamic-extent args) + (type list args)) + + (let* ((task (create-task-struct)) + (task-sap (int-sap (sb!kernel:get-lisp-obj-address task)))) + + (create-control-stack task control-stack-pages) + (create-binding-stack task binding-stack-pages) + + ;; FIXME: Initial call frame setup belongs in separate function. + ;; FIXME: Link thread into thread chain (next/prev slots in thread). + + (let* ((ebp (sap-ref-32 task-sap kernel-task-esp-slot)) + (esp (- ebp #x10)) + + (function-address (sb!kernel:get-lisp-obj-address initial-function)) + (eip (sap-ref-32 (int-sap function-address) -1)) + + (argcount (length args)) + (arg0 (sb!kernel:get-lisp-obj-address + (if (> argcount 0) (elt args 0) nil))) + (arg1 (sb!kernel:get-lisp-obj-address + (if (> argcount 1) (elt args 1) nil))) + (arg2 (sb!kernel:get-lisp-obj-address + (if (> argcount 2) (elt args 2) nil)))) + (declare (type (unsigned-byte 32) esp)) + + ;; Set stack and frame pointers. + (setf (sap-ref-32 task-sap kernel-task-esp-slot) + (the (unsigned-byte 32) (- esp (* 4 (max 0 (- argcount 3)))))) + (setf (sap-ref-32 task-sap kernel-task-ebp-slot) ebp) + + ;; Set up stack frame. + (setf (sap-ref-32 (int-sap esp) 12) 0) ;; frame link + (setf (sap-ref-32 (int-sap esp) 8) 0) ;; return address save + (setf (sap-ref-32 (int-sap esp) 4) 0) ;; useless spot + (setf (sap-ref-32 (int-sap esp) 0) 0) ;; return address + + ;; Set up stack args. + (dotimes (i (max 0 (- argcount 3))) + (setf (sap-ref-32 (int-sap esp) (* (1+ i) -4)) + (sb!kernel:get-lisp-obj-address (elt args (+ 3 i))))) + + ;; Set current function. + (setf (sap-ref-32 task-sap kernel-task-eip-slot) eip) + (setf (sap-ref-32 task-sap kernel-task-eax-slot) function-address) + + ;; Set register args. + (setf (sap-ref-32 task-sap kernel-task-ecx-slot) (* 4 argcount)) + (setf (sap-ref-32 task-sap kernel-task-edx-slot) arg0) + (setf (sap-ref-32 task-sap kernel-task-edi-slot) arg1) + (setf (sap-ref-32 task-sap kernel-task-esi-slot) arg2)) + task)) + + (defun-nonpaged ring3-startup () + (init-display-driver) + (initialize-ring0-interrupt-handlers) + (setup-default-ring3-interrupt-handlers) + (setup-idle-task) + (setup-syscall-selector) + (setup-timer-interrupt) + (setup-page-fault-handler) + (display-string " +SBCL-os milestone-3 (Arlington) +") + (setf manager-thread-addr initial-task-address) + (manager-thread-toplevel (create-ring3-task #'test-ring3-function nil))) + + (defun-nonpaged manager-thread-toplevel (task) + (loop with next-task = (sb!kernel:get-lisp-obj-address 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 Index: src/os/tramps.lisp =================================================================== RCS file: src/os/tramps.lisp diff -N src/os/tramps.lisp --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ src/os/tramps.lisp 18 Apr 2008 22:42:30 -0000 @@ -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