From: Chris Hanson Date: Tue, 15 May 2018 04:35:24 +0000 (-0700) Subject: Rewrite microcode-tables.scm for simplicity. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~39 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=37a4d9c5c23c1ad1625c3c7b87f3dcb2fae43e06;p=mit-scheme.git Rewrite microcode-tables.scm for simplicity. Also add a 'fixed-objects boot-actions list and change record.scm to use it. --- diff --git a/doc/ref-manual/os-interface.texi b/doc/ref-manual/os-interface.texi index 7eef0277d..28176015e 100644 --- a/doc/ref-manual/os-interface.texi +++ b/doc/ref-manual/os-interface.texi @@ -2505,14 +2505,13 @@ This section contains assorted operating-system facilities that don't fit into other categories. @defvr variable microcode-id/operating-system -@defvrx variable microcode-id/operating-system-name +@defvrx {obsolete variable} microcode-id/operating-system-name @code{microcode-id/operating-system} is bound to a symbol that specifies the type of operating system that Scheme is running under. There are two possible values: @code{unix} or @code{nt}. -@code{microcode-id/operating-system-name} is a string containing the -same name as @code{microcode-id/operating-system}; the latter is created -by interning the former as a symbol. +The @strong{deprecated} variable @code{microcode-id/operating-system-name} is +a string that's equivalent to @code{microcode-id/operating-system}. @end defvr @defvr variable microcode-id/operating-system-variant diff --git a/src/runtime/make.scm b/src/runtime/make.scm index b7044064e..8df7a12ce 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -447,9 +447,8 @@ USA. (package-initialization-sequence '( ;; Microcode interface - ((runtime microcode-tables) read-microcode-tables!) + (runtime microcode-tables) (runtime apply) - ((runtime record) initialize-applicator-context!) (runtime primitive-io) (runtime system-clock) ((runtime gc-finalizer) initialize-events!) diff --git a/src/runtime/microcode-tables.scm b/src/runtime/microcode-tables.scm index ed5b1eecd..76c5a49c3 100644 --- a/src/runtime/microcode-tables.scm +++ b/src/runtime/microcode-tables.scm @@ -24,101 +24,16 @@ USA. |# -;;;; Microcode Name <-> Code Maps +;;;; Microcode shared object tables ;;; package: (runtime microcode-tables) (declare (usual-integrations)) -(define (read-microcode-tables!) - (set! identification-vector ((ucode-primitive microcode-identify))) - (set! errors-slot (fixed-object/name->code 'microcode-errors-vector)) - (set! identifications-slot - (fixed-object/name->code 'microcode-identification-vector)) - (set! returns-slot (fixed-object/name->code 'microcode-returns-vector)) - (set! terminations-slot - (fixed-object/name->code 'microcode-terminations-vector)) - (set! types-slot (fixed-object/name->code 'microcode-types-vector)) - (set! non-object-slot (fixed-object/name->code 'non-object)) - (set! system-call-names-slot (fixed-object/name->code 'system-call-names)) - (set! system-call-errors-slot (fixed-object/name->code 'system-call-errors)) - (set! microcode-version-string - (microcode-identification-item 'microcode-version)) - (set! char:newline (microcode-identification-item 'newline-char)) - (set! microcode-id/floating-mantissa-bits - (microcode-identification-item 'flonum-mantissa-length)) - (set! microcode-id/floating-epsilon - (microcode-identification-item 'flonum-epsilon)) - (let ((name (microcode-identification-item 'os-name-string))) - (set! microcode-id/operating-system (intern name)) - (set! microcode-id/operating-system-name name)) - (set! microcode-id/operating-system-variant - (microcode-identification-item 'os-variant-string)) - (set! microcode-id/stack-type - (let ((string (microcode-identification-item 'stack-type-string))) - (cond ((string? string) (intern string)) - ((not string) 'standard) - (else (error "Illegal stack type:" string))))) - (set! microcode-id/machine-type - (or (microcode-identification-item 'machine-type-string #f) - "unknown-machine")) - (set! microcode-id/compiled-code-type - (intern (or (microcode-identification-item 'cc-arch-string #f) - "unknown"))) - (set! microcode-id/tty-x-size - (microcode-identification-item 'console-width)) - (set! microcode-id/tty-y-size - (microcode-identification-item 'console-height)) - - unspecific) - -(define (intern string) - ((ucode-primitive string->symbol) - (let ((size ((ucode-primitive string-length) string))) - (let ((result ((ucode-primitive string-allocate) size))) - ((ucode-primitive substring-move-right!) string 0 size result 0) - ((ucode-primitive substring-downcase!) result 0 size) - result)))) - -(define (get-microcode-version-string) - microcode-version-string) - -(define (get-microcode-version-numbers) - (map (lambda (s) (or (string->number s) s)) - (burst-string microcode-version-string #\. #f))) - -(define microcode-version-string) -(define char:newline) -(define microcode-id/tty-x-size) -(define microcode-id/tty-y-size) -(define microcode-id/floating-mantissa-bits) -(define microcode-id/floating-epsilon) -(define microcode-id/operating-system) -(define microcode-id/operating-system-name) -(define microcode-id/operating-system-variant) -(define microcode-id/stack-type) -(define microcode-id/machine-type) -(define microcode-id/compiled-code-type) - -(define (microcode-id/operating-system-suffix #!optional os-type) - (case (if (default-object? os-type) - microcode-id/operating-system - os-type) - ((nt) "w32") - ((unix) "unx") - (else (error "Unknown operating system:" os-type)))) - (define-integrable fixed-objects-slot 15) -(define non-object-slot) (define (fixed-object/name->code name) (microcode-table-search fixed-objects-slot name)) -(define (fixed-object/code->name code) - (microcode-table-ref fixed-objects-slot code)) - -(define (fixed-object/code-limit) - (vector-length (vector-ref (get-fixed-objects-vector) fixed-objects-slot))) - (define (fixed-objects-vector-slot name) (or (fixed-object/name->code name) (error:bad-range-argument name 'fixed-objects-vector-slot))) @@ -148,9 +63,6 @@ USA. (define (update-fixed-objects-item! name updater) ((fixed-objects-updater name) updater)) -(define (microcode-object/unassigned) - (vector-ref (get-fixed-objects-vector) non-object-slot)) - (define (microcode-table-search slot name) (let ((vector (vector-ref (get-fixed-objects-vector) slot))) (let ((end (vector-length vector))) @@ -163,45 +75,28 @@ USA. i (loop (fix:+ i 1))))))))) -(define (microcode-table-entry slot index) - (let ((vector (vector-ref (get-fixed-objects-vector) slot))) - (and (fix:< index (vector-length vector)) - (vector-ref vector index)))) - (define (microcode-table-ref slot index) - (let ((entry (microcode-table-entry slot index))) - (if (pair? entry) - (car entry) - entry))) + (let ((v (vector-ref (get-fixed-objects-vector) slot))) + (and (fix:< index (vector-length v)) + (let ((entry (vector-ref v index))) + (if (pair? entry) + (car entry) + entry))))) -(define returns-slot) +(define-deferred returns-slot + (fixed-object/name->code 'microcode-returns-vector)) (define (microcode-return/name->code name) - (microcode-table-search returns-slot - (let ((p - (find (lambda (p) - (memq name (cdr p))) - returns-aliases))) - (if p - (car p) - name)))) + (microcode-table-search returns-slot name)) (define (microcode-return/code->name code) (microcode-table-ref returns-slot code)) -(define (microcode-return/code->names code) - (let ((name (microcode-table-entry types-slot code))) - (if name - (or (assq name returns-aliases) - (list name)) - '()))) - (define (microcode-return/code-limit) (vector-length (vector-ref (get-fixed-objects-vector) returns-slot))) -(define returns-aliases '()) - -(define errors-slot) +(define-deferred errors-slot + (fixed-object/name->code 'microcode-errors-vector)) (define (microcode-error/name->code name) (microcode-table-search errors-slot name)) @@ -212,7 +107,8 @@ USA. (define (microcode-error/code-limit) (vector-length (vector-ref (get-fixed-objects-vector) errors-slot))) -(define terminations-slot) +(define-deferred terminations-slot + (fixed-object/name->code 'microcode-terminations-vector)) (define (microcode-termination/name->code name) (microcode-table-search terminations-slot name)) @@ -223,37 +119,26 @@ USA. (define (microcode-termination/code-limit) (vector-length (vector-ref (get-fixed-objects-vector) terminations-slot))) -(define identifications-slot) -(define identification-vector) - -(define (microcode-identification-vector-slot name #!optional error?) - (let ((v (microcode-table-search identifications-slot name))) - (if (and (not v) (if (default-object? error?) #t error?)) - (error:bad-range-argument name 'microcode-identification-vector-slot)) - v)) - -(define (microcode-identification-item name #!optional error?) - (let ((slot (microcode-identification-vector-slot name error?))) - (and slot - (vector-ref identification-vector slot)))) - -(define system-call-names-slot) +(define-deferred system-call-names-slot + (fixed-object/name->code 'system-call-names)) (define (microcode-system-call/name->code name) (microcode-table-search system-call-names-slot name)) (define (microcode-system-call/code->name code) (microcode-table-ref system-call-names-slot code)) - -(define system-call-errors-slot) + +(define-deferred system-call-errors-slot + (fixed-object/name->code 'system-call-errors)) (define (microcode-system-call-error/name->code name) (microcode-table-search system-call-errors-slot name)) (define (microcode-system-call-error/code->name code) (microcode-table-ref system-call-errors-slot code)) - -(define types-slot) + +(define-deferred types-slot + (fixed-object/name->code 'microcode-types-vector)) (define (microcode-type/name->code name) (microcode-table-search types-slot @@ -268,13 +153,6 @@ USA. (define (microcode-type/code->name code) (microcode-table-ref types-slot code)) -(define (microcode-type/code->names code) - (let ((name (microcode-table-entry types-slot code))) - (if name - (or (assq name type-aliases) - (list name)) - '()))) - (define (microcode-type/code-limit) (vector-length (vector-ref (get-fixed-objects-vector) types-slot))) @@ -291,4 +169,65 @@ USA. (hunk3-a unmarked-history) (triple hunk3 hunk3-b marked-history) (reference-trap unassigned) - (recnum complex))) \ No newline at end of file + (recnum complex))) + +;;;; Microcode identification + +(define-deferred identifications-slot + (fixed-object/name->code 'microcode-identification-vector)) + +(define identification-vector) +(define microcode-version-string) +(define microcode-id/floating-mantissa-bits) +(define microcode-id/floating-epsilon) +(define microcode-id/operating-system) +(define microcode-id/operating-system-name) +(define microcode-id/operating-system-variant) +(define microcode-id/machine-type) +(define microcode-id/compiled-code-type) +(define (read-microcode-identification!) + (set! identification-vector + ((ucode-primitive microcode-identify))) + (set! microcode-version-string + (microcode-identification-item 'microcode-version)) + (set! microcode-id/floating-mantissa-bits + (microcode-identification-item 'flonum-mantissa-length)) + (set! microcode-id/floating-epsilon + (microcode-identification-item 'flonum-epsilon)) + (set! microcode-id/operating-system-name + (microcode-identification-item 'os-name-string)) + (set! microcode-id/operating-system + (intern microcode-id/operating-system-name)) + (set! microcode-id/operating-system-variant + (microcode-identification-item 'os-variant-string)) + (set! microcode-id/machine-type + (microcode-identification-item 'machine-type-string "unknown")) + (set! microcode-id/compiled-code-type + (intern (microcode-identification-item 'cc-arch-string "unknown"))) + unspecific) + +(add-boot-init! + (lambda () + (read-microcode-identification!) + (run-deferred-boot-actions 'fixed-objects))) + +(define (microcode-identification-item name #!optional default-value) + (let ((index (microcode-table-search identifications-slot name))) + (if index + (vector-ref identification-vector index) + (begin + (if (default-object? default-value) + (error:bad-range-argument name 'microcode-identification-item)) + default-value)))) + +(define (get-microcode-version-numbers) + (map (lambda (s) (or (string->number s) s)) + (burst-string microcode-version-string #\. #f))) + +(define (microcode-id/operating-system-suffix #!optional os-type) + (case (if (default-object? os-type) + microcode-id/operating-system + os-type) + ((nt) "w32") + ((unix) "unx") + (else (error "Unknown operating system:" os-type)))) \ No newline at end of file diff --git a/src/runtime/record.scm b/src/runtime/record.scm index 537a00388..8dbb87ea7 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -202,10 +202,11 @@ USA. (define-integrable (%set-record-type-applicator! record-type applicator) (%dispatch-tag-extra-set! record-type 4 applicator)) -(define (initialize-applicator-context!) - (set-fixed-objects-item! 'record-dispatch-tag %record-metatag) - (set-fixed-objects-item! 'record-applicator-index - (%dispatch-tag-extra-index 4))) +(defer-boot-action 'fixed-objects + (lambda () + (set-fixed-objects-item! 'record-dispatch-tag %record-metatag) + (set-fixed-objects-item! 'record-applicator-index + (%dispatch-tag-extra-index 4)))) (define-integrable (%record-type-n-fields record-type) (vector-length (%record-type-field-names record-type))) @@ -300,7 +301,7 @@ USA. (vector-set! %proxied-record-types (%record-type-proxy->index proxy) type)) (define %proxied-record-types) -(defer-boot-action 'record-procedures +(defer-boot-action 'fixed-objects (lambda () (set! %proxied-record-types (fixed-objects-item 'proxied-record-types)) unspecific)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 237190710..5eb537305 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3202,28 +3202,24 @@ USA. (define-package (runtime microcode-tables) (files "microcode-tables") (parent (runtime)) + (export () deprecated:microcode-tables + microcode-id/operating-system-name) (export () microcode-id/compiled-code-type microcode-id/floating-epsilon microcode-id/floating-mantissa-bits microcode-id/machine-type microcode-id/operating-system - microcode-id/operating-system-name microcode-id/operating-system-suffix microcode-id/operating-system-variant - microcode-id/stack-type - microcode-id/tty-x-size - microcode-id/tty-y-size microcode-type/code-limit) (export (runtime) - char:newline fixed-objects-accessor fixed-objects-item fixed-objects-modifier fixed-objects-updater get-microcode-version-numbers microcode-type/code->name - microcode-type/code->names microcode-type/name->code set-fixed-objects-item! update-fixed-objects-item!) @@ -3255,7 +3251,7 @@ USA. microcode-termination/code-limit microcode-termination/name->code) (export (runtime save/restore) - read-microcode-tables!) + read-microcode-identification!) (initialization (initialize-package!))) (define-package (runtime number) diff --git a/src/runtime/savres.scm b/src/runtime/savres.scm index ab2018634..0176b061a 100644 --- a/src/runtime/savres.scm +++ b/src/runtime/savres.scm @@ -79,7 +79,7 @@ USA. (set! time-world-saved time) (if (string? id) unspecific #f))))))) ((ucode-primitive set-fixed-objects-vector!) fixed-objects)))) - (read-microcode-tables!) + (read-microcode-identification!) (lambda () (set! time-world-saved time) (set! time-world-restored (get-universal-time))