[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/11: Refactor (system base types internal) to use more
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/11: Refactor (system base types internal) to use more macros |
|
Date: |
Sun, 29 Oct 2017 05:09:39 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 0a9fa88a853f4146777cf4796723456f8d448890
Author: Andy Wingo <address@hidden>
Date: Fri Oct 27 10:00:54 2017 +0200
Refactor (system base types internal) to use more macros
* module/system/base/types/internal.scm (visit-immediate-tags)
(visit-heap-tags): New helpers.
* module/system/base/types/internal.scm (define-tags, define-tag): New
helpers.
(immediate-tags, heap-tags): Use define-tags to define all of the tag
values. For consistency some names are changed:
(%tc2-fixnum): Renamed from %tc2-inum.
(%tc8-flag): Removed.
(%tc16-null): Renamed from %tc16-eol.
(%tc7-weak-vector): Renamed from %tc7-wvect.
(%tc7-hash-table): Renamed from %tc7-hashtable.
(%tc7-flonum): Renamed from %tc7-real.
(visit-heap-tags, visit-immediate-tags): New exports.
* module/system/base/types.scm (cell->object): Adapt to renamings.
(match-bit-pattern): Add a case to match immediate SCM bits
literally.
(scm->object): Adapt to use the special immediate values directly.
* module/system/vm/disassembler.scm (immediate-tag-annotations):
(heap-tag-annotations): Adapt to new names.
---
module/system/base/types.scm | 29 +++---
module/system/base/types/internal.scm | 186 +++++++++++++++++++++++-----------
module/system/vm/disassembler.scm | 14 +--
3 files changed, 151 insertions(+), 78 deletions(-)
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index e8f51ba..cc37acd 100644
--- a/module/system/base/types.scm
+++ b/module/system/base/types.scm
@@ -162,6 +162,10 @@ SIZE is omitted, return an unbounded port to the memory at
ADDRESS."
(a (logand bits (bitwise-not n))))
consequent)
alternate)))
+ ((match-bit-pattern bits (= c) consequent alternate)
+ (if (= bits c)
+ consequent
+ alternate))
((match-bit-pattern bits (x & n = c) consequent alternate)
(let ((tag (logand bits n)))
(if (= tag c)
@@ -396,7 +400,7 @@ using BACKEND."
(bytevector->uint-list words (native-endianness)
%word-size)))
vector)))
- (((_ & #x7f = %tc7-wvect))
+ (((_ & #x7f = %tc7-weak-vector))
(inferior-object 'weak-vector address)) ; TODO: show elements
(((_ & #x7f = %tc7-fluid) init-value)
(inferior-object 'fluid address))
@@ -408,14 +412,14 @@ using BACKEND."
(inferior-object 'program address))
(((_ & #xffff = %tc16-bignum))
(inferior-object 'bignum address))
- (((_ & #xffff = %tc16-real) pad)
+ (((_ & #xffff = %tc16-flonum) pad)
(let* ((address (+ address (* 2 %word-size)))
(port (memory-port backend address (sizeof double)))
(words (get-bytevector-n port (sizeof double))))
(bytevector-ieee-double-ref words 0 (native-endianness))))
(((_ & #x7f = %tc7-number) mpi)
(inferior-object 'number address))
- (((_ & #x7f = %tc7-hashtable) buckets meta-data unused)
+ (((_ & #x7f = %tc7-hash-table) buckets meta-data unused)
(inferior-object 'hash-table address))
(((_ & #x7f = %tc7-pointer) address)
(make-pointer address))
@@ -443,7 +447,7 @@ using BACKEND."
"Return the Scheme object corresponding to BITS, the bits of an 'SCM'
object."
(match-scm bits
- (((integer << 2) || %tc2-inum)
+ (((integer << 2) || %tc2-fixnum)
integer)
((address & 7 = %tc3-heap-object)
(let* ((type (dereference-word backend address))
@@ -462,16 +466,13 @@ object."
(cell->object address backend))))
(((char << 8) || %tc8-char)
(integer->char char))
- (((flag << 8) || %tc8-flag)
- (case flag
- ((0) #f)
- ((1) #nil)
- ((3) '())
- ((4) #t)
- ((8) (if #f #f))
- ((9) (inferior-object 'undefined bits))
- ((10) (eof-object))
- ((11) (inferior-object 'unbound bits))))))
+ ((= %tc16-false) #f)
+ ((= %tc16-nil) #nil)
+ ((= %tc16-null) '())
+ ((= %tc16-true) #t)
+ ((= %tc16-unspecified) (if #f #f))
+ ((= %tc16-undefined) (inferior-object 'undefined bits))
+ ((= %tc16-eof) (eof-object))))
;;; Local Variables:
;;; eval: (put 'match-scm 'scheme-indent-function 1)
diff --git a/module/system/base/types/internal.scm
b/module/system/base/types/internal.scm
index 41d55ef..fbb11d4 100644
--- a/module/system/base/types/internal.scm
+++ b/module/system/base/types/internal.scm
@@ -16,18 +16,17 @@
(define-module (system base types internal)
#:export (;; Immediate tags.
- %tc2-inum
- %tc3-imm24
+ %tc2-fixnum
%tc3-heap-object
%tc8-char
- %tc8-flag
%tc16-false
%tc16-nil
- %tc16-eol
+ %tc16-null
%tc16-true
%tc16-unspecified
%tc16-undefined
%tc16-eof
+ visit-immediate-tags
;; Heap object tags (cell types).
%tc1-pair
@@ -35,10 +34,10 @@
%tc7-symbol
%tc7-variable
%tc7-vector
- %tc7-wvect
+ %tc7-weak-vector
%tc7-string
%tc7-number
- %tc7-hashtable
+ %tc7-hash-table
%tc7-pointer
%tc7-fluid
%tc7-stringbuf
@@ -56,9 +55,10 @@
%tc7-port
%tc7-smob
%tc16-bignum
- %tc16-real
+ %tc16-flonum
%tc16-complex
- %tc16-fraction))
+ %tc16-fraction
+ visit-heap-tags))
;;; Commentary:
;;;
@@ -71,26 +71,116 @@
;;; Tags---keep in sync with libguile/tags.h!
;;;
-;; Immediate tags.
-(eval-when (expand load eval)
- (define %tc2-inum #b10)
- (define %tc3-imm24 #b100)
- (define %tc3-heap-object #b000)
+(define-syntax define-tags
+ (lambda (x)
+ (define (id-append ctx a b)
+ (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
+ (syntax-case x ()
+ ((_ tag-set (name pred mask tag) ...)
+ #`(define-syntax #,(id-append #'tag-set #'visit- #'tag-set)
+ (lambda (x)
+ (define (introduce ctx id)
+ (datum->syntax ctx (syntax->datum id)))
+ (syntax-case x ()
+ ((_ f)
+ #`(begin
+ (f #,(introduce #'f #'name)
+ #,(introduce #'f #'pred)
+ mask
+ tag)
+ ...)))))))))
- (define %tc8-flag (+ %tc3-imm24 0))
- (define %tc8-char (+ %tc3-imm24 8))
+(define-tags immediate-tags
+ ;; 321076543210 321076543210
+ (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)
- (define %tc16-false (+ (ash #b0000 8) %tc8-flag))
- (define %tc16-nil (+ (ash #b0001 8) %tc8-flag))
- (define %tc16-eol (+ (ash #b0011 8) %tc8-flag))
- (define %tc16-true (+ (ash #b0100 8) %tc8-flag))
- (define %tc16-unspecified (+ (ash #b1000 8) %tc8-flag))
- (define %tc16-undefined (+ (ash #b1001 8) %tc8-flag))
- (define %tc16-eof (+ (ash #b1010 8) %tc8-flag)))
+ ;;(nil eq-nil? #b111111111111 #b000100000100)
+ ;;(eol eq-null? #b111111111111 #b001100000100)
+ ;;(false eq-false? #b111111111111 #b000000000100)
+ (null+nil null? #b110111111111 #b000100000100)
+ (false+nil false? #b111011111111 #b000000000100)
+ (null+false+nil nil? #b110011111111 #b000000000100))
+
+(define-tags heap-tags
+ ;; 321076543210 321076543210
+ (pair pair? #b1 #b0)
+ (struct struct? #b111 #b001)
+ ;; For tc7 values, low bits 2 and 0 must be 1.
+ (symbol symbol? #b1111111 #b0000101)
+ (variable variable? #b1111111 #b0000111)
+ (vector vector? #b1111111 #b0001101)
+ (weak-vector weak-vector? #b1111111 #b0001111)
+ (string string? #b1111111 #b0010101)
+ (number number? #b1111111 #b0010111)
+ (hash-table hash-table? #b1111111 #b0011101)
+ (pointer pointer? #b1111111 #b0011111)
+ (fluid fluid? #b1111111 #b0100101)
+ (stringbuf stringbuf? #b1111111 #b0100111)
+ (dynamic-state dynamic-state? #b1111111 #b0101101)
+ (frame frame? #b1111111 #b0101111)
+ (keyword keyword? #b1111111 #b0110101)
+ (atomic-box atomic-box? #b1111111 #b0110111)
+ (syntax syntax? #b1111111 #b0111101)
+ ;;(unused unused #b1111111 #b0111111)
+ (program program? #b1111111 #b1000101)
+ (vm-continuation vm-continuation? #b1111111 #b1000111)
+ (bytevector bytevector? #b1111111 #b1001101)
+ ;;(unused unused #b1111111 #b1001111)
+ (weak-set weak-set? #b1111111 #b1010101)
+ (weak-table weak-table? #b1111111 #b1010111)
+ (array array? #b1111111 #b1011101)
+ (bitvector bitvector? #b1111111 #b1011111)
+ ;;(unused unused #b1111111 #b1100101)
+ ;;(unused unused #b1111111 #b1100111)
+ ;;(unused unused #b1111111 #b1101101)
+ ;;(unused unused #b1111111 #b1101111)
+ ;;(unused unused #b1111111 #b1110101)
+ (smob smob? #b1111111 #b1110111)
+ (port port? #b1111111 #b1111101)
+ ;;(unused unused #b1111111 #b1111111)
+
+ ;(number number? #b1111111 #b0010111)
+ (bignum bignum? #b111111111111 #b000100010111)
+ (flonum flonum? #b111111111111 #b001000010111)
+ (complex complex? #b111111111111 #b001100010111)
+ (fraction fraction? #b111111111111 #b010000010111))
+
+(define-syntax define-tag
+ (lambda (x)
+ (define (id-append ctx a b)
+ (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
+ (define (def prefix name tag)
+ #`(define #,(id-append name prefix name) #,tag))
+ (syntax-case x ()
+ ((_ name pred #b1 tag) (def #'%tc1- #'name #'tag))
+ ((_ name pred #b11 tag) (def #'%tc2- #'name #'tag))
+ ((_ name pred #b111 tag) (def #'%tc3- #'name #'tag))
+ ((_ name pred #b1111111 tag) (def #'%tc7- #'name #'tag))
+ ((_ name pred #b11111111 tag) (def #'%tc8- #'name #'tag))
+ ;; Only 12 bits of mask but for historic reasons these are called
+ ;; tc16 values.
+ ((_ name pred #b111111111111 tag) (def #'%tc16- #'name #'tag))
+ ((_ name pred mask tag)
+ #`(begin
+ (define #,(id-append #'name #'name #'-mask) mask)
+ (define #,(id-append #'name #'name #'-tag) tag))))))
+
+(visit-immediate-tags define-tag)
+(visit-heap-tags define-tag)
;; See discussion in tags.h and boolean.h.
(eval-when (expand)
(let ()
+ (visit-immediate-tags define-tag)
(define (exactly-one-bit-set? x)
(and (not (zero? x)) (zero? (logand x (1- x)))))
(define (exactly-two-bits-set? x)
@@ -99,42 +189,24 @@
(exactly-one-bit-set? (logxor a b)))
(define (bits-differ-in-exactly-two-bit-positions? a b)
(exactly-two-bits-set? (logxor a b)))
+ (define (common-bits a b)
+ (values (logand #xfff (lognot (logxor a b))) (logand a b)))
- (unless (bits-differ-in-exactly-one-bit-position? %tc16-eol %tc16-nil)
+ (unless (bits-differ-in-exactly-one-bit-position? %tc16-null %tc16-nil)
(error "expected #nil and '() to differ in exactly one bit position"))
(unless (bits-differ-in-exactly-one-bit-position? %tc16-false %tc16-nil)
(error "expected #f and '() to differ in exactly one bit position"))
- (unless (bits-differ-in-exactly-two-bit-positions? %tc16-false %tc16-eol)
- (error "expected #f and '() to differ in exactly two bit positions"))))
-
-;; Heap object tags (cell types).
-(define %tc1-pair #b0)
-(define %tc3-struct #x01)
-(define %tc7-symbol #x05)
-(define %tc7-variable #x07)
-(define %tc7-vector #x0d)
-(define %tc7-wvect #x0f)
-(define %tc7-string #x15)
-(define %tc7-number #x17)
-(define %tc7-hashtable #x1d)
-(define %tc7-pointer #x1f)
-(define %tc7-fluid #x25)
-(define %tc7-stringbuf #x27)
-(define %tc7-dynamic-state #x2d)
-(define %tc7-frame #x2f)
-(define %tc7-keyword #x35)
-(define %tc7-syntax #x3d)
-(define %tc7-program #x45)
-(define %tc7-vm-continuation #x47)
-(define %tc7-bytevector #x4d)
-(define %tc7-weak-set #x55)
-(define %tc7-weak-table #x57)
-(define %tc7-array #x5d)
-(define %tc7-bitvector #x5f)
-(define %tc7-port #x7d)
-(define %tc7-smob #x77)
-
-(define %tc16-bignum (+ %tc7-number (* 1 256)))
-(define %tc16-real (+ %tc7-number (* 2 256)))
-(define %tc16-complex (+ %tc7-number (* 3 256)))
-(define %tc16-fraction (+ %tc7-number (* 4 256)))
+ (unless (bits-differ-in-exactly-two-bit-positions? %tc16-false %tc16-null)
+ (error "expected #f and '() to differ in exactly two bit positions"))
+ (call-with-values (lambda () (common-bits %tc16-null %tc16-nil))
+ (lambda (mask tag)
+ (unless (= mask null+nil-mask) (error "unexpected mask for null?"))
+ (unless (= tag null+nil-tag) (error "unexpected tag for null?"))))
+ (call-with-values (lambda () (common-bits %tc16-false %tc16-nil))
+ (lambda (mask tag)
+ (unless (= mask false+nil-mask) (error "unexpected mask for false?"))
+ (unless (= tag false+nil-tag) (error "unexpected tag for false?"))))
+ (call-with-values (lambda () (common-bits %tc16-false %tc16-null))
+ (lambda (mask tag)
+ (unless (= mask null+false+nil-mask) (error "unexpected mask for
nil?"))
+ (unless (= tag null+false+nil-tag) (error "unexpected tag for
nil?"))))))
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index 8ffa6bc..16208f1 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -185,20 +185,20 @@ address of that offset."
(let ()
(define (common-bits a b)
(list (lognot (logxor a b)) (logand a b)))
- `((#b11 ,%tc2-inum "inum?")
+ `((#b11 ,%tc2-fixnum "fixnum?")
(#b111 ,%tc3-heap-object "heap-object?")
(#xff ,%tc8-char "char?")
(#xffff ,%tc16-nil "eq? #nil")
- (#xffff ,%tc16-eol "eq? '()")
+ (#xffff ,%tc16-null "eq? '()")
(#xffff ,%tc16-false "eq? #f")
(#xffff ,%tc16-true "eq? #t")
(#xffff ,%tc16-unspecified "unspecified?")
(#xffff ,%tc16-undefined "undefined?")
(#xffff ,%tc16-eof "eof-object?")
;; See discussions in boolean.h.
- (,@(common-bits %tc16-eol %tc16-nil) "null?")
+ (,@(common-bits %tc16-null %tc16-nil) "null?")
(,@(common-bits %tc16-false %tc16-nil) "false?")
- (,@(common-bits %tc16-false %tc16-eol) "nil?"))))
+ (,@(common-bits %tc16-false %tc16-null) "nil?"))))
(define heap-tag-annotations
`((#b1 ,%tc1-pair "pair?")
@@ -206,10 +206,10 @@ address of that offset."
(#xff ,%tc7-symbol "symbol?")
(#xff ,%tc7-variable "variable?")
(#xff ,%tc7-vector "vector?")
- (#xff ,%tc7-wvect "weak-vector?")
+ (#xff ,%tc7-weak-vector "weak-vector?")
(#xff ,%tc7-string "string?")
(#xff ,%tc7-number "number?")
- (#xff ,%tc7-hashtable "hash-table?")
+ (#xff ,%tc7-hash-table "hash-table?")
(#xff ,%tc7-pointer "pointer?")
(#xff ,%tc7-fluid "fluid?")
(#xff ,%tc7-stringbuf "stringbuf?")
@@ -227,7 +227,7 @@ address of that offset."
(#xff ,%tc7-port "port?")
(#xff ,%tc7-smob "smob?")
(#xffff ,%tc16-bignum "bignum?")
- (#xffff ,%tc16-real "flonum?")
+ (#xffff ,%tc16-flonum "flonum?")
(#xffff ,%tc16-complex "complex?")
(#xffff ,%tc16-fraction "fraction?")))
- [Guile-commits] branch master updated (cd947a1 -> 9d1235a), Andy Wingo, 2017/10/29
- [Guile-commits] 02/11: Use tag visitors to generate assemblers, disassembly annotations, Andy Wingo, 2017/10/29
- [Guile-commits] 05/11: Emit char? instead of br-if-char, Andy Wingo, 2017/10/29
- [Guile-commits] 04/11: Emit new instructions for heap object type tests, Andy Wingo, 2017/10/29
- [Guile-commits] 08/11: Emit new eq? instruction, Andy Wingo, 2017/10/29
- [Guile-commits] 10/11: Use new instructions for u64 comparisons., Andy Wingo, 2017/10/29
- [Guile-commits] 09/11: Use new instructions for less-than, etc, Andy Wingo, 2017/10/29
- [Guile-commits] 11/11: Use new instructions for f64 comparisons, Andy Wingo, 2017/10/29
- [Guile-commits] 03/11: Heap type predicates preceded by heap-object?, Andy Wingo, 2017/10/29
- [Guile-commits] 01/11: Refactor (system base types internal) to use more macros,
Andy Wingo <=
- [Guile-commits] 06/11: Use new instructions for null?, nil?, Andy Wingo, 2017/10/29
- [Guile-commits] 07/11: Simplify $branch to always take a $primcall, Andy Wingo, 2017/10/29