Gecko [ tsuru-no-tsurugi.tokyo ]

Name	Size	Permission	Date	Action
internal.scm	11.73 KB	-rw-r--r--	2021-05-10 17:28

Rename

;;; Details on internal value representation.
;;; Copyright (C) 2014, 2015, 2017, 2018, 2020, 2021 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; This library 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 Lesser
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(define-module (system base types internal)
  #:export (;; Immediate tags.
            %tc2-fixnum
            %tc3-heap-object
            %tc8-char
            %tc16-false
            %tc16-nil
            %tc16-null
            %tc16-true
            %tc16-unspecified
            %tc16-undefined
            %tc16-eof
            visit-immediate-tags

;; Heap object tags (cell types).
            %tc1-pair
            %tc3-struct
            %tc7-symbol
            %tc7-variable
            %tc7-vector
            %tc8-immutable-vector
            %tc8-mutable-vector
            %tc7-weak-vector
            %tc7-string
            %tc7-heap-number
            %tc7-hash-table
            %tc7-pointer
            %tc7-fluid
            %tc7-stringbuf
            %tc7-dynamic-state
            %tc7-frame
            %tc7-keyword
            %tc7-atomic-box
            %tc7-syntax
            %tc7-program
            %tc7-vm-continuation
            %tc7-bytevector
            %tc7-weak-set
            %tc7-weak-table
            %tc7-array
            %tc7-bitvector
            %tc7-port
            %tc7-smob
            %tc16-bignum
            %tc16-flonum
            %tc16-complex
            %tc16-fraction
            visit-heap-tags

scm->immediate-bits
            immediate-bits->scm
            truncate-bits
            sign-extend))

;;; Commentary:
;;;
;;; Tag values used to represent Scheme values, internally to Guile.
;;;
;;; Code:

;;;
;;; Tags---keep in sync with libguile/tags.h!
;;;

(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-tags immediate-tags
  ;;                                    321076543210    321076543210
  (fixnum           fixnum?                     #b11            #b10)
  (heap-object      heap-object?               #b111           #b000)
  (char             char?                 #b11111111      #b00001100)
  (undefined        undefined?        #b111111111111  #b100100000100)

;; 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)
  ;;(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)
  (immutable-vector immutable-vector?     #b11111111      #b10001101)
  (mutable-vector   mutable-vector?       #b11111111      #b00001101)
  (weak-vector      weak-vector?           #b1111111       #b0001111)
  (string           string?                #b1111111       #b0010101)
  (heap-number      heap-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)
  
  ;(heap-number     heap-number?           #b1111111       #b0010111)
  (bignum           bignum?           #b111111111111  #b000100010111)
  (flonum           flonum?           #b111111111111  #b001000010111)
  (complex          compnum?          #b111111111111  #b001100010111)
  (fraction         fracnum?          #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)

(define (scm->immediate-bits x)
  "If @var{x} is of a type that could be encoded as an immediate, return
that bit pattern, or @code{#f} otherwise..  Note that the immediate bits
may not fit into a word on the target platform."
  (cond
   ((exact-integer? x) (logior %tc2-fixnum (ash x 2)))
   ((char? x)          (logior %tc8-char (ash (char->integer x) 8)))
   ((eq? x #f)         %tc16-false)
   ((eq? x #nil)       %tc16-nil)
   ((eq? x '())        %tc16-null)
   ((eq? x #t)         %tc16-true)
   ((unspecified? x)   %tc16-unspecified)
   ;; FIXME: %tc16-undefined.
   ((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 (name) (eqv? (logand imm mask) tag)))
  (visit-immediate-tags define-predicate)
  (cond
   ((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)
  (case (ash x (- 1 bits))
    ((0) x)
    ((1) (- x (ash 1 bits)))
    (else (error "value does not fit in bits" x bits))))

(define (truncate-bits x bits signed?)
  (define-syntax-rule (bits-case bits)
    (let ((umax (1- (ash 1 bits))))
      (and (if signed?
               (let ((smin (ash -1 (1- bits)))
                     (smax (1- (ash 1 (1- bits)))))
                 (<= smin x smax))
               (<= 0 x umax))
           (logand x umax))))
  (case bits
    ((16) (bits-case 16))
    ((32) (bits-case 32))
    ((64) (bits-case 64))
    (else (bits-case bits))))

;; 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)
      (exactly-one-bit-set? (logand x (1- x))))
    (define (bits-differ-in-exactly-one-bit-position? a b)
      (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-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-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?"))))))