Date: Fri, 31 May 2013 09:47:44 -0700
From: Joe Marshall <jmarsh...@alum.mit.edu>
We should have a new release so this isn't a problem.
Another approach would be to write a portable fasdump so that we can
begin to fix the source of the problem rather than keep working around
it release by release. This code is totally untested (and not quite
finished -- still need to write code to write the fasl header), but
it's a start. (Some day, maybe we can run it in Schemes other than
MIT Scheme too and reduce the chance of a Thompson-style back door...)
#| -*-Scheme-*-
Copyright (C) 2013 Taylor R Campbell
This file is part of MIT/GNU Scheme.
MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.
MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.
|#
;;;; Portable fasdumper
;;; package: (runtime portable-fasdump)
(declare (usual-integrations))
;;;; Fasdump formats
(define-structure (fasdump-format
(conc-name format.)
(keyword-constructor make-fasdump-format))
(architecture #f read-only #t)
(version #f read-only #t)
(bits-per-type #f read-only #t)
(bits-per-datum #f read-only #t)
(bits-per-byte #f read-only #t)
(bytes-per-word #f read-only #t)
(words-per-float #f read-only #t)
(greatest-fixnum #f read-only #t)
(least-fixnum #f read-only #t)
(write-word #f read-only #t)
(write-float #f read-only #t))
(define (make-std-fasdump-format architecture
bytes-per-word
write-word
write-bignum-digit
write-float)
(make-fasdump-format
'VERSION 10 ;FASL_VERSION_C_CODE
'ARCHITECTURE architecture
'BITS-PER-TYPE 6
'BITS-PER-DATUM (- (* bytes-per-word 8) 6)
'BITS-PER-BYTE 8
'BYTES-PER-WORD bytes-per-word
'WORDS-PER-FLOAT (/ 8 bytes-per-word)
'GREATEST-FIXNUM (bitwise-not (shift-left -1 (* bytes-per-word 8)))
'LEAST-FIXNUM (shift-left -1 (* bytes-per-word 8))
'WRITE-WORD write-word
'WRITE-BIGNUM-DIGIT write-bignum-digit
'WRITE-FLOAT write-float))
(define (make-std32be-fasdump-format architecture bytes-per-word)
(make-std-fasdump-format architecture
bytes-per-word
write-std32be-word
write-std32be-bignum-digit
write-ieee754-double-be))
(define (make-std32le-fasdump-format architecture bytes-per-word)
(make-std-fasdump-format architecture
bytes-per-word
write-std32le-word
write-std32le-bignum-digit
write-ieee754-double-le))
(define (make-std64be-fasdump-format architecture bytes-per-word)
(make-std-fasdump-format architecture
bytes-per-word
write-std64be-word
write-std64be-bignum-digit
write-ieee754-double-be))
(define (make-std64le-fasdump-format architecture bytes-per-word)
(make-std-fasdump-format architecture
bytes-per-word
write-std64le-word
write-std64le-bignum-digit
write-ieee754-double-le))
;;;; Bits
(define (write-std32be-word type datum output-port)
(write-std32-word type datum write-be-halves output-port))
(define (write-std32le-word type datum output-port)
(write-std32-word type datum write-le-halves output-port))
(define (write-std64be-word type datum output-port)
(write-std64-word type datum write-be-halves output-port))
(define (write-std64le-word type datum output-port)
(write-std64-word type datum write-le-halves output-port))
(define (write-std32-word type datum write-halves output-port)
(assert (<= 0 type #x3f))
(assert (zero? (shiftout datum #xfc000000)))
(let ((high (shiftout datum #x03ff0000))
(low (shiftout datum #x0000ffff)))
(let ((high
(bitwise-ior (shiftin type #xfc00)
(shiftin high #x003f))))
(write-halves write-halves write-16 low high output-port))))
(define (write-std64-word type datum write-halves output-port)
(assert (<= 0 type #x3f))
(assert (zero? (shiftout datum #xfc00000000000000)))
(let ((high (shiftout datum #x03ffffff00000000))
(low (shiftout datum #x00000000ffffffff)))
(let ((high
(bitwise-ior (shiftin type #xfc000000)
(shiftin high #x03ffffff))))
(write-halves write-halves write-32 low high output-port))))
(define (write-std32le-bignum-digit digit output-port)
(write-32 write-le-halves digit output-port))
(define (write-std32be-bignum-digit digit output-port)
(write-32 write-be-halves digit output-port))
(define (write-std64le-bignum-digit digit output-port)
(write-64 write-le-halves digit output-port))
(define (write-std32le-bignum-digit digit output-port)
(write-64 write-be-halves digit output-port))
(define (write-halves* write-halves write-half bits mask n output-port)
(assert (< 0 bits))
(assert (= mask (bit-mask bits 0)))
(let ((low (bitwise-and n mask))
(high (bitwise-and (shift-right n bits) mask)))
(write-halves write-halves write-half low high output-port)))
(define (write-le-halves write-halves write-half low high output-port)
(write-half write-halves low output-port)
(write-half write-halves high output-port))
(define (write-be-halves write-halves write-half low high output-port)
(write-half write-halves low output-port)
(write-half write-halves high output-port))
(define (write-64 write-halves n output-port)
(write-halves* write-halves write-32 32 #xfffffffff n output-port))
(define (write-32 write-halves n output-port)
(write-halves* write-halves write-16 16 #xffff n output-port))
(define (write-16 write-halves n output-port)
(write-halves* write-halves write-8 8 #xff n output-port))
(define (write-8 write-halves n output-port)
(write-octet n output-port))
;;;;; Floating bits
(define (write-ieee754-double-be x output-port)
(write-ieee754-double write-be-halves x output-port))
(define (write-ieee754-double-le x output-port)
(write-ieee754-double write-le-halves x output-port))
(define (write-ieee754-double write-halves x output-port)
(receive (sign exponent significand) (decompose-ieee754-double x)
(let ((low (shiftout significand #xffffffff))
(high (shiftout significand #x000fffff)))
(let ((sign&exponent
(bitwise-ior (shiftin sign #x80000000)
(shiftin exponent #x7ff00000))))
(let ((high (bitwise-ior high sign&exponent)))
(write-halves write-halves low high output-port))))))
(define (decompose-ieee754-double x)
(cond ((not (= x x))
;; There are, of course, 2^53 different NaNs. There is no
;; obvious way to computationally detect the sign of a NaN,
;; and no standard way to get at the significand bits, so
;; we'll just canonicalize everything to an arbitrary choice
;; of NaN with nonnegative sign and significand all bits one.
(values 0 (- #x7ff 1023) #xfffffffffffff))
;; The decimal point in (< 1. (abs x)) works around a bug in
;; 9.1.1 for reasons I don't understand and am not at present
;; terribly keen to figure out.
((and (< 1. (abs x)) (= x (/ x 2)))
(values (if (< x 0.) 1 0) (- #x7ff 1023) 0))
(else
(decompose-ieee754-real x 2 1023 53))))
(define (compose-ieee754-double sign exponent significand)
(assert (exact-integer? sign))
(assert (exact-integer? exponent))
(assert (exact-integer? significand))
(assert (<= 0 sign 1))
(assert (<= -1023 exponent 1024))
(assert (<= 0 significand #x1fffffffffffff))
(assert (or (< -1023 exponent) (<= significand #xfffffffffffff)))
(if (= exponent 1024)
(error "Can't compose infinities or NaNs!" sign exponent significand))
(compose-ieee754-real sign exponent significand 2 1023 53))
(define (ieee754-double-recomposes? x)
(= x
(receive (sign exponent significand) (decompose-ieee754-double x)
(compose-ieee754-double sign exponent significand))))
;;;;; Known formats
(define fasdump-format:i386 (make-std32le-fasdump-format 6))
(define fasdump-format:sparc32 (make-std32le-fasdump-format 14))
(define fasdump-format:mips32be (make-std32be-fasdump-format 15))
(define fasdump-format:mips32le (make-std32le-fasdump-format 15))
(define fasdump-format:alpha (make-std64le-fasdump-format 18))
(define fasdump-format:ppc32 (make-std32be-fasdump-format 20))
(define fasdump-format:amd64 (make-std64le-fasdump-format 21))
(define fasdump-format:arm32 (make-std32le-fasdump-format 24))
#;
(define fasdump-format:pdp10
(make-fasdump-format
'VERSION 10 ;FASL_VERSION_C_CODE
'ARCHITECTURE 1
'BITS-PER-TYPE 6
'BITS-PER-DATUM 30
'BITS-PER-BYTE 36
'BYTES-PER-WORD 1
'WORDS-PER-FLOAT 42 ;XXX
'GREATEST-FIXNUM #x1fffffff
'GREATEST-FIXNUM #x-20000000
'WRITE-WORD write-pdp10-word
'WRITE-BIGNUM-DIGIT write-pdp10-bignum-digit
'WRITE-FLOAT write-pdp10-float))
;;;; Fasdump top-level
(define-structure (state
(conc-name state.)
(constructor make-state (format output-port)))
(format #f read-only #t)
(output-port #f read-only #t)
(n-words 0)
(addresses (make-strong-eqv-hash-table) read-only #t)
(primitive-name->number (make-string-hash-table) read-only #t)
(primitives-reversed '())
(queue (make-queue) read-only #t))
(define (portable-fasdump object pathname format)
;; XXX Write to temporary, rename to permanent.
(call-with-output-file pathname
(lambda (output-port)
(let ((state (make-state format output-port)))
(fasdump-initial-header state)
(fasdump-object state object)
(do () ((queue-empty? (state.queue state)))
(fasdump-storage state (dequeue! (state.queue state))))
(fasdump-primitive-table state)
(fasdump-final-header state)))))
(define (fasdump-initial-header state)
(set-port/position! (state.output-port state) 0)
...)
(define (fasdump-final-header state)
(set-port/position! (state.output-port state) 0)
...)
(define (fasdump-word state type datum)
(let ((format (state.format state)))
(assert (<= 0 type (bit-mask (format.bits-per-type format) 0)))
(assert (<= 0 datum (bit-mask (format.bits-per-datum format))))
((format.write-word format) type datum (state.output-port state))))
(define (fasdump-float state value)
(let ((format (state.format state)))
((format.write-float format) value (state.output-port state))))
(define (fasdump-string-n-words format string)
;; Add a terminating null byte.
(quotient (+ 1 (string-length string))
(format.bytes-per-word format)))
(define (fasdump-string state string)
(let ((format (state.format state)))
(let ((bytes (string-length string))
(words (fasdump-string-n-words format string)))
(let ((zeros (- (* words (format.bytes-per-word format)) bytes)))
(write-string string output-port)
(do ((i 0 (+ i 1))) ((>= i n-zeros))
(write-byte 0 output-port))))))
(define (fasdump-bignum-n-digits format integer)
(assert (exact-integer? integer))
(let ((bits-per-digit (format.bits-per-bignum-digit format)))
;; There is always one `digit' for the sign/length.
(let loop ((integer integer) (digits 1))
(if (zero? integer)
digits
(loop (shift-right integer bits-per-digit) (+ digits 1))))))
(define (fasdump-bignum-n-words format integer)
(assert (exact-integer? integer))
(let ((words-per-bignum-digit (format.words-per-bignum-digit format))
(bits-per-word (format.bits-per-word format))
(n-digits (fasdump-bignum-n-digits format integer)))
(* (quotient (+ words-per-bignum-digit (- bits-per-word 1)) bits-per-word)
n-digits)))
(define (fasdump-bignum-digit state digit)
(let ((format (state.format state)))
((format.write-bignum-digit format) digit (state.output-port state))))
(define (fasdump-bignum state integer)
(let ((n-digits (fasdump-bignum-n-digits format object))
(shift (format.bits-per-bignum-digit format)))
(let ((mask (bit-mask shift 0)))
(assert (<= 0 n-digits))
(assert (= 0 (bitwise-and n-digits mask)))
(let ((sign (if (< integer 0) -1 0))
(magnitude (abs integer)))
(let ((header (bitwise-ior (shift-left sign shift) n-digits)))
(fasdump-bignum-digit state header)
(let loop ((integer integer) (digits 1))
(if (zero? integer)
(assert (= digits n-digits))
(begin (fasdump-bignum-digit state (bitwise-and integer mask))
(loop (shift-right integer shift) (+ digits 1))))))))))
(define (fasdump-primitive-table state)
(for-each (lambda (primitive)
(fasdump-primitive-table-entry state primitive))
(reverse (state.primitives-reversed state))))
(define (fasdump-primitive-table-entry state primitive)
(let ((name (car primitive))
(arity (cdr primitive)))
(let ((n-words (fasdump-string-n-words (state.format state) name)))
(fasdump-word state tc:fixnum arity)
(fasdump-word state tc:manifest-nm-vector n-words)
(fasdump-string state name))))
;;;; Fasdumping an object
(define (fasdump-object state object)
(define (dump type datum)
(fasdump-word state type datum))
(fasdump-classify state object
(lambda (type datum) ;if-non-pointer
(dump type datum))
(lambda (type name arity) ;if-primitive
(dump type (get-primitive-number state name arity)))
(lambda (type n-words alignment) ;if-pointer
(dump type (get-object-address state object n-words alignment)))))
(define (get-primitive-number state name arity)
(let* ((primitive-name->index (state.primitive-name->number state))
(n (hash-table/count primitive-name->number)))
(hash-table/intern! primitive-name->number name
(lambda ()
(set-state.primitives-reversed!
state
(cons (cons name arity) (state.primitives-reversed state)))
n))))
(define (get-object-address state object n-words alignment)
(hash-table/intern! (state.addresses state) object
(lambda ()
(enqueue! (state.queue state) object)
(allocate state n-words alignment))))
(define (allocate state n-words alignment)
(let* ((unaligned-word-address (state.n-words state))
(aligned-word-address (round-up unaligned-word-address alignment)))
(set-state.n-words! state (+ aligned-word-address n-words))
(* aligned-word-address (format.bytes-per-word (state.format state)))))
(define (fasdump-at-address? state address)
(= address (port/position (state.output-port state))))
;;;;; Object classification
(define (fasdump-classify state object if-non-pointer if-primitive if-pointer)
(let ((format (state.format state)))
(cond ((pair? object) (if-pointer tc:list 2 1))
((vector? object)
(if-pointer tc:vector (+ 1 (vector-length object)) 1))
((string? object)
(if-pointer tc:character-string
;; One for the real length, one for the manifest.
(+ 2 (fasdump-string-n-words format object))
1))
((symbol? object)
(let ((type
(if (uninterned-symbol? object)
tc:uninterned-symbol
tc:interned-symbol)))
(if-pointer type 2 1)))
((primitive? object)
(if-primitive tc:primitive (primitive-procedure-name object)))
((number? object)
(fasdump-classify/number state object if-non-pointer if-pointer))
((scode? object)
(fasdump-classify/scode state object if-pointer if-non-pointer))
((char? object) (if-non-pointer tc:character (char->integer object)))
((eqv? object #f) (if-non-pointer tc:null null:false))
((eqv? object #t) (if-non-pointer tc:constant constant:true))
((eqv? object (unspecific-object))
(if-non-pointer tc:constant constant:unspecific))
((eqv? object (default-object))
(if-non-pointer tc:constant constant:default))
((null? object) (if-non-pointer tc:constant constant:null))
(else
(fasdump-error state "Invalid object for fasdump:" object)))))
(define (fasdump-classify/number state object if-non-pointer if-pointer)
(let ((format (state.format state)))
(cond ((exact-integer? object)
(if (and (<= (format.least-fixnum format) object)
(<= object (format.greatest-fixnum format)))
(if-non-pointer tc:fixnum
(signed->unsigned (format.bits-per-datum format)
object))
(if-pointer tc:big-fixnum
(+ 1 (fasdump-bignum-n-words format object))
1)))
((exact-rational? object) (if-pointer tc:ratnum 2 1))
((inexact-real? object)
(if-pointer tc:big-flonum
(fasdump-flonum-n-words format object)
(format.words-per-float format)))
((complex? object) (if-pointer tc:complex 2 1))
(else
(fasdump-error state "Invalid number for fasdump:" object)))))
;;;;;; Scode classification
(define (fasdump-classify/scode state scode if-pointer if-non-pointer)
(cond ((access? scode) (if-pointer tc:access 2 1))
((assignment? scode) (if-pointer tc:assignment 2 1))
((combination? scode)
(if-pointer tc:combination
(+ 1 (length (combination-operands scode)))
1))
((comment? scode) (if-pointer tc:comment 2 1))
((conditional? scode) (if-pointer tc:conditional 3 1))
((definition? scode) (if-pointer tc:definition 2 1))
((delay? scode) (if-pointer tc:delay 1 1))
((disjunction? scode) (if-pointer tc:disjunction 2 1))
((lambda? scode) (fasdump-classify/lambda state scode if-pointer))
((quotation? scode) (if-pointer tc:scode-quote 1 1))
((sequence? scode) (if-pointer tc:sequence 2 1))
((the-environment? scode) (if-non-pointer tc:the-environment 0))
((variable? scode) (if-pointer tc:variable 3 1))
(else (error "This is not scode!" scode))))
(define (fasdump-classify/lambda state scode if-pointer)
(lambda-components* scode
(lambda (name required optional rest body)
(if (or (pair? optional) rest)
(begin
(if (not (and (length<=? required #xff)
(length<=? optional #xff)))
(fasdump-error state "Lambda too large!" scode))
(if-pointer tc:extended-lambda 3 1))
(if-pointer tc:lambda 2 1)))))
;;;; Fasdumping a pointer object's storage
(define (fasdump-storage state object)
(assert (let ((address
(or (hash-table/get (state.addresses state) object #f)
(error "Unallocated queued object:" object))))
(fasdump-at-address? state address)))
(let ((format (state.format state)))
(cond ((pair? object)
(fasdump-object state (car object))
(fasdump-object state (cdr object)))
((vector? object)
(fasdump-word state tc:manifest-vector (vector-length object))
(do ((i 0 (+ i 1))) ((>= i (vector-length object)))
(fasdump-object state (vector-ref object i))))
((string? object)
(let ((n-words (fasdump-string-n-words format object)))
(fasdump-word state tc:manifest-nm-vector n-words)
(fasdump-word state 0 (string-length object))
(fasdump-string state object)))
((symbol? object)
(fasdump-object state (symbol->string object))
(fasdump-word state tc:reference-trap trap:unbound))
((number? object)
(fasdump-storage/number state object))
(else
(error "Fasdump bug -- object should have been rejected:"
object)))))
(define (fasdump-storage/number state object)
(let ((format (state.format state)))
(cond ((exact-integer? object)
(assert (or (< object (format.least-fixnum format))
(< (format.greatest-fixnum format) object)))
(fasdump-word state
tc:manifest-nm-vector
(fasdump-bignum-n-words format object))
(fasdump-bignum state object))
((exact-rational? object)
(fasdump-object state (numerator object))
(fasdump-object state (denominator object)))
((inexact-real? object)
(fasdump-padding-words state (format.words-per-float format))
(fasdump-float state object))
((complex? object)
(fasdump-object state (real-part object))
(fasdump-object state (imag-part object)))
(else
(error "Fasdump bug -- number should have been rejected:"
object)))))
;;;;; Fasdumping an scode pointer's storage
(define (fasdump-storage/scode state scode)
(cond ((access? scode)
(fasdump-object state (access-environment scode))
(fasdump-object state (access-namescode)))
((assignment? scode)
(fasdump-object state (assignment-variable scode))
(fasdump-object state (assignment-value scode)))
((comment? scode)
(fasdump-object state (comment-expression scode))
(fasdump-object state (comment-text scode)))a
((definition? scode)
(fasdump-object state (definition-name scode))
(fasdump-object state (definition-value scode)))
((delay? scode)
(fasdump-object state (delay-expression scode)))
((lambda? scode)
(lambda-components* scode
(lambda (name required optional rest body)
(if (or (pair? optional) rest)
(fasdump-xlambda state name required optional rest body)
(fasdump-lambda state name required body)))))
((quotation? scode)
(fasdump-object state (quotation-expression scode)))
((variable? scode)
(fasdump-object state (variable-name scode)))
(else
(error "Fasdump bug -- this is not scode!" scode))))
(define (fasdump-lambda state name required body)
(fasdump-object state body)
(fasdump-object state (list->vector (cons name required))))
(define (fasdump-xlambda state name required optional rest body)
(assert (length<=? required #xff))
(assert (length<=? optional #xff))
(let ((variables
(cons name (append required optional (if rest (list rest) '()))))
(arity
(encode-xlambda-arity (length required)
(length optional)
(pair? rest))))
(fasdump-object state body)
(fasdump-object state (list->vector variables))
(fasdump-word state tc:fixnum arity)))
;;;; Type codes and other magic numbers
(define tc:access #x1f)
(define tc:assignment #x23)
(define tc:big-fixnum #x0e)
(define tc:big-flonum #x06)
(define tc:character #x02)
(define tc:character-string #x1e)
(define tc:combination #x26)
(define tc:comment #x15)
(define tc:complex #x3c)
(define tc:conditional #x34)
(define tc:constant #x08)
(define tc:definition #x21)
(define tc:delay #x13)
(define tc:disjunction #x35)
(define tc:extended-lambda #x14)
(define tc:fixnum #x1a)
(define tc:interned-symbol #x1d)
(define tc:lambda #x17)
(define tc:list #x01) ;pair
(define tc:manifest-nm-vector #x27)
(define tc:null #x00)
(define tc:primitive #x18)
(define tc:ratnum #x3a)
(define tc:reference-trap #x32)
(define tc:scode-quote #x03)
(define tc:sequence #x19)
(define tc:the-environment #x2d)
(define tc:uninterned-symbol #x05)
(define tc:variable #x2c)
(define tc:vector #x0a)
(define tc:manifest-vector tc:null)
(define null:false 0)
(define constant:true 0)
(define constant:unspecific 1)
(define constant:default 7)
(define constant:null 9)
;;;; Utilities
(define (scode? object)
(or (access? object)
(assignment? object)
(comment? object)
(definition? object)
(delay? object)
(quotation? object)
(the-environment? object)
(variable? object)))
(define (shiftout n mask)
(shift-right (bitwise-and n mask) (first-set-bit mask)))
(define (shiftin n mask)
(shift-left n (first-set-bit mask)))
(define (shift-left n bits)
(assert (>= bits 0))
(arithmetic-shift n bits))
(define (shift-right n bits)
(assert (>= bits 0))
(arithmetic-shift n (- 0 bits)))
(define (round-up n alignment)
(assert (<= n 0))
(assert (< alignment 0))
(* n (quotient (+ n (- alignment 1)) alignment)))
(define (signed->unsigned bits n)
(bitwise-and n (bit-mask bits 0)))
(define (length<=? list length)
(let loop ((list list) (length length))
(cond ((pair? list) (and (> length 0) (loop (cdr list) (- length 1))))
((null? list) (zero? length))
(else (error "Invalid list:" list)))))
(define (truncate->exact x)
(inexact->exact (truncate x)))
;;;; IEEE 754 utilities
(define (decompose-ieee754-double x)
(decompose-ieee754-binary x 11 53))
(define (decompose-ieee754-binary x exponent-bits precision)
(assert (zero? (modulo (+ exponent-bits precision) 32)))
(receive (base emin emax bias exp-subnormal exp-inf/nan)
(ieee754-binary-parameters exponent-bits precision)
(decompose-ieee754 x base emax precision
(lambda (sign) ;if-zero
(values sign 0 0))
(lambda (sign scaled-significand) ;if-subnormal
(assert (= 0 (shift-right scaled-significand precision)))
(values sign exp-subnormal scaled-significand))
(lambda (sign exponent scaled-significand) ;if-normal
(assert (<= emin exponent emax))
(assert (= 1 (shift-right scaled-significand precision)))
(values sign
(+ exponent bias)
(bitwise-and scaled-significand (bit-mask precision 0))))
(lambda (sign) ;if-infinite
(values sign exp-inf/nan 0))
(lambda () ;if-nan
(values 0 exp-inf/nan 1)))))
(define (decompose-ieee754 x base emax precision
if-zero if-subnormal if-normal if-infinite if-nan)
(cond ((not (= x x))
;; There are, of course, b^p different NaNs. There is no
;; obvious way to computationally detect the sign of a NaN,
;; and no standard way to get at the significand bits, so
;; we'll just ignore those here and hope the caller has a good
;; story...
(if-nan))
;; XXX The decimal points here are a kludge to work around bugs
;; in MIT Scheme's comparisons to infinities.
((and (< 1. (abs x)) (= x (/ x 2)))
(if-infinite (if (< 0. x) 0 1)))
(else
(let ((sign (ieee754-sign x)) (x (abs x)) (emin (- 1 emax)))
(define (significand x)
(truncate->exact (* x (expt base precision))))
(cond ((<= 1 x) ;Nonnegative exponent
(let loop ((exponent 0) (x x))
(cond ((< emax exponent) (if-infinite sign))
((< base x) (loop (+ exponent 1) (/ x base)))
(else (if-normal sign exponent (significand x))))))
((< (expt base emin) x) ;Negative exponent, normal
(let loop ((exponent 0) (x x))
(assert (<= emin exponent))
(if (<= 1 x)
(if-normal sign exponent (significand x))
(loop (- exponent 1) (* x base)))))
((< 0 x) ;Negative exponent, subnormal
(if (<= x (- (expt base emin) (expt base (- 0 precision))))
(if-zero sign)
(if-subnormal
sign
(significand (* x (expt base (- 0 emin)))))))
(else
(if-zero sign)))))))
(define (ieee754-sign x)
(cond ((< 0 x) 0)
((< x 0) 1)
;; Zero -- can't use < directly to detect sign. Elicit a
;; computational difference.
((negative? (imag-part (log (make-rectangular -1 x)))) 1)
(else 0)))
(define (compose-ieee754-double sign biased-exponent trailing-significand)
(compose-ieee754-binary sign biased-exponent trailing-significand 11 53))
(define (compose-ieee754-binary sign biased-exponent trailing-significand
exponent-bits precision)
(receive (base emin emax bias exp-subnormal exp-inf/nan)
(ieee754-binary-parameters exponent-bits precision)
(let ((exponent (- biased-exponent bias)))
(cond ((= exponent exp-subnormal)
(if (zero? trailing-significand)
(compose-ieee754-zero sign base emax precision)
(compose-ieee754-subnormal sign trailing-significand
base emax precision)))
((= exponent exp-inf/nan)
(if (zero? trailing-significand)
(compose-ieee754-infinity sign base emax precision)
(compose-ieee754-nan sign trailing-significand
base emax precision)))
(else
(let ((scaled-significand
(bitwise-ior (shift-left 1 precision)
trailing-significand)))
(compose-ieee754-normal sign exponent scaled-significand
base emax precision)))))))
(define (compose-ieee754-zero sign base emax precision)
base emax precision ;ignore
(* (exact->inexact (expt -1 sign)) base))
(define (compose-ieee754-subnormal sign significand base emax precision)
(* (exact->inexact (expt -1 sign))
(* significand (expt base (- precision emax)))))
(define (compose-ieee754-normal sign exponent significand base emax precision)
(assert (<= (- 1 emax) exponent emax))
(pp `(* (expt -1 ,sign)
(expt ,base ,exponent)
(/ ,significand (expt ,base ,precision))))
(* (exact->inexact (expt -1 sign))
(expt base exponent)
(/ significand (expt base precision))))
(define (compose-ieee754-infinity sign)
(error "Can't compose an IEEE754 infinity!" sign))
(define (compose-ieee754-nan sign scaled-significand)
(error "Can't compose an IEEE754 NaN!" sign scaled-significand))
(define (ieee754-binary-parameters exponent-bits precision)
(let* ((base 2)
(emax (- (expt base (- exponent-bits 1)) 1)))
(let ((bias emax)
(emin (- 1 emax)))
(let ((exp-subnormal (- emin 1))
(exp-inf/nan (+ emax 1)))
(values base emin emax bias exp-subnormal exp-inf/nan)))))
(define (ieee754-double-recomposable? x)
(= x
(receive (sign biased-exponent trailing-significand)
(decompose-ieee754-double x)
(compose-ieee754-double sign biased-exponent trailing-significand))))
_______________________________________________
MIT-Scheme-devel mailing list
MIT-Scheme-devel@gnu.org
https://lists.gnu.org/mailman/listinfo/mit-scheme-devel
