summaryrefslogtreecommitdiff
path: root/module/system
diff options
context:
space:
mode:
Diffstat (limited to 'module/system')
-rw-r--r--module/system/base/types/internal.scm35
-rw-r--r--module/system/vm/assembler.scm16
-rw-r--r--module/system/vm/disassembler.scm6
3 files changed, 30 insertions, 27 deletions
diff --git a/module/system/base/types/internal.scm b/module/system/base/types/internal.scm
index 768deae92..c75ca3bf6 100644
--- a/module/system/base/types/internal.scm
+++ b/module/system/base/types/internal.scm
@@ -103,13 +103,16 @@
(fixnum fixnum? #b11 #b10)
(heap-object heap-object? #b111 #b000)
(char char? #b11111111 #b00001100)
- (false eq-false? #b111111111111 #b000000000100)
- (nil eq-nil? #b111111111111 #b000100000100)
- (null eq-null? #b111111111111 #b001100000100)
- (true eq-true? #b111111111111 #b010000000100)
- (unspecified unspecified? #b111111111111 #b100000000100)
(undefined undefined? #b111111111111 #b100100000100)
- (eof eof-object? #b111111111111 #b101000000100)
+
+ ;; To check for these values from Scheme, use eq?. From assembler,
+ ;; use eq-immediate?.
+ (false #f #b111111111111 #b000000000100)
+ (nil #f #b111111111111 #b000100000100)
+ (null #f #b111111111111 #b001100000100)
+ (true #f #b111111111111 #b010000000100)
+ (unspecified #f #b111111111111 #b100000000100)
+ (eof #f #b111111111111 #b101000000100)
;;(nil eq-nil? #b111111111111 #b000100000100)
;;(eol eq-null? #b111111111111 #b001100000100)
@@ -200,24 +203,24 @@ may not fit into a word on the target platform."
((eq? x #t) %tc16-true)
((unspecified? x) %tc16-unspecified)
;; FIXME: %tc16-undefined.
- ((eof-object? x) %tc16-eof)
+ ((eof-object? x) %tc16-eof)
(else #f)))
(define (immediate-bits->scm imm)
"Return the SCM object corresponding to the immediate encoding
@code{imm}. Note that this value should be sign-extended already."
(define-syntax-rule (define-predicate name pred mask tag)
- (define (pred) (eqv? (logand imm mask) tag)))
+ (define (name) (eqv? (logand imm mask) tag)))
(visit-immediate-tags define-predicate)
(cond
- ((fixnum?) (ash imm -2))
- ((char?) (integer->char (ash imm -8)))
- ((eq-false?) #f)
- ((eq-nil?) #nil)
- ((eq-null?) '())
- ((eq-true?) #t)
- ((unspecified?) (if #f #f))
- ((eof-object?) the-eof-object)
+ ((fixnum) (ash imm -2))
+ ((char) (integer->char (ash imm -8)))
+ ((false) #f)
+ ((nil) #nil)
+ ((null) '())
+ ((true) #t)
+ ((unspecified) (if #f #f))
+ ((eof) the-eof-object)
(else (error "invalid immediate" imm))) )
(define (sign-extend x bits)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 8f67cac51..698d44dac 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -95,14 +95,7 @@
emit-fixnum?
emit-heap-object?
emit-char?
- emit-eq-null?
- emit-eq-nil?
- emit-eq-false?
- emit-eq-true?
- emit-unspecified?
emit-undefined?
- emit-eof-object?
-
emit-null?
emit-false?
emit-nil?
@@ -1390,9 +1383,12 @@ returned instead."
(let ((loc (intern-constant asm (make-static-procedure label))))
(emit-make-non-immediate asm dst loc)))
-(define-syntax-rule (define-immediate-tag=?-macro-assembler name pred mask tag)
- (define-macro-assembler (pred asm slot)
- (emit-immediate-tag=? asm slot mask tag)))
+(define-syntax define-immediate-tag=?-macro-assembler
+ (syntax-rules ()
+ ((_ name #f mask tag) #f)
+ ((_ name pred mask tag)
+ (define-macro-assembler (pred asm slot)
+ (emit-immediate-tag=? asm slot mask tag)))))
(visit-immediate-tags define-immediate-tag=?-macro-assembler)
diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index 28f4338d6..cc055491d 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -195,7 +195,11 @@ address of that offset."
(define immediate-tag-annotations '())
(define-syntax-rule (define-immediate-tag-annotation name pred mask tag)
(set! immediate-tag-annotations
- (cons `((,mask ,tag) ,(symbol->string 'pred)) immediate-tag-annotations)))
+ (cons `((,mask ,tag)
+ ,(cond
+ ('pred => symbol->string)
+ (else (string-append "eq-" (symbol->string 'name) "?"))))
+ immediate-tag-annotations)))
(visit-immediate-tags define-immediate-tag-annotation)
(define heap-tag-annotations '())