mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Rework the way immediate encodings are calculated.

Browse source 
* module/system/base/types/internal.scm (scm->immediate-bits):
  (immediate-bits->scm, sign-extend, truncate-bits): New public
  routines.
* module/system/vm/assembler.scm (immediate-bits): Reimplement in terms
  of scm->immediate-bits and similar.
  (X8_S8_I16, X8_S8_ZI16): Rework operand encodings.
  (load-constant): Use truncate-bits to determine which cases apply.
This commit is contained in:
Andy Wingo 2020-08-01 15:24:59 +02:00
parent 8366634db7
commit daf3e88a81
2 changed files with 67 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

53
module/system/base/types/internal.scm
View file

@ -1,5 +1,5 @@
;;; Details on internal value representation.
;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
;;; Copyright (C) 2014, 2015, 2017, 2018, 2020 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
@ -61,7 +61,12 @@
%tc16-flonum
%tc16-complex
%tc16-fraction
visit-heap-tags))
visit-heap-tags
scm->immediate-bits
immediate-bits->scm
truncate-bits
sign-extend))
;;; Commentary:
;;;
@ -182,6 +187,50 @@
(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 (pred) (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)
(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?)
(let ((x' (logand x (1- (ash 1 bits)))))
(and (eq? x (if signed? (sign-extend x' bits) x'))
x')))
;; See discussion in tags.h and boolean.h.
(eval-when (expand)
(let ()

67
module/system/vm/assembler.scm
View file

@ -640,6 +640,10 @@ later by the linker."
(reloc (make-reloc 's32 label start (- pos start))))
(set-asm-relocs! asm (cons reloc (asm-relocs asm)))))
(define (immediate-bits asm x)
(let ((bits (scm->immediate-bits x)))
(and bits (truncate-bits bits (* 8 (asm-word-size asm)) #t))))
@ -682,11 +686,11 @@ later by the linker."
(record-label-reference asm label)
(emit asm opcode))
((X8_S8_I16 a imm)
(emit asm (pack-u8-u8-u16 opcode a (immediate-bits asm imm))))
(let ((bits (truncate-bits (scm->immediate-bits imm) 16 #f)))
(emit asm (pack-u8-u8-u16 opcode a bits))))
((X8_S8_ZI16 a imm)
(emit asm (pack-u8-u8-u16 opcode a
(signed-bits asm (immediate-bits asm imm)
16))))
(let ((bits (truncate-bits (scm->immediate-bits imm) 16 #t)))
(emit asm (pack-u8-u8-u16 opcode a bits))))
((X8_S12_S12 a b)
(emit asm (pack-u8-u12-u12 opcode a b)))
((X8_S12_C12 a b)
@ -1207,48 +1211,6 @@ lists. This procedure can be called many times before calling
;;; to the table.
;;;
(define (immediate-bits asm x)
"Return the bit pattern to write into the buffer if @var{x} is
immediate, and @code{#f} otherwise."
(define tc2-int 2)
(if (exact-integer? x)
;; Object is an immediate if it is a fixnum on the target.
(call-with-values (lambda ()
(case (asm-word-size asm)
((4) (values (- #x20000000)
#x1fffffff))
((8) (values (- #x2000000000000000)
#x1fffffffFFFFFFFF))
(else (error "unexpected word size"))))
(lambda (fixnum-min fixnum-max)
(and (<= fixnum-min x fixnum-max)
(let ((fixnum-bits (if (negative? x)
(+ fixnum-max 1 (logand x fixnum-max))
x)))
(logior (ash fixnum-bits 2) tc2-int)))))
;; Otherwise, the object will be immediate on the target if and
;; only if it is immediate on the host. Except for integers,
;; which we handle specially above, any immediate value is an
;; immediate on both 32-bit and 64-bit targets.
(let ((bits (object-address x)))
(and (not (zero? (logand bits 6)))
bits))))
(define (signed-bits asm uimm n)
"Given the immediate-bits encoding @var{uimm}, return its bit pattern
if it can be restricted to a sign-extended bitfield of @var{n} bits, or
@code{#f} otherwise."
(let* ((all-bits (1- (ash 1 (* (asm-word-size asm) 8))))
(fixed-bits (1- (ash 1 n)))
(sign-bits (lognot (ash fixed-bits -1))))
(cond
((eqv? (logand all-bits sign-bits) (logand uimm sign-bits))
(logand uimm fixed-bits))
((zero? (logand uimm sign-bits))
uimm)
(else
#f))))
(define-record-type <stringbuf>
(make-stringbuf string)
stringbuf?
@ -1405,17 +1367,20 @@ returned instead."
(define-macro-assembler (load-constant asm dst obj)
(cond
((immediate-bits asm obj)
((scm->immediate-bits obj)
=> (lambda (bits)
(cond
((and (< dst 256) (signed-bits asm bits 16))
((and (< dst 256) (truncate-bits bits 16 #t))
(emit-make-immediate asm dst obj))
((and (< dst 256) (zero? (ash bits -16)))
((and (< dst 256) (truncate-bits bits 16 #f))
(emit-make-short-immediate asm dst obj))
((zero? (ash bits -32))
((truncate-bits bits 32 (eqv? (asm-word-size asm) 4))
(emit-make-long-immediate asm dst obj))
((and (eqv? (asm-word-size asm) 8)
(truncate-bits bits 64 #t))
(emit-make-long-long-immediate asm dst obj))
(else
(emit-make-long-long-immediate asm dst obj)))))
(emit-static-ref asm dst (intern-non-immediate asm obj))))))
((statically-allocatable? obj)
(emit-make-non-immediate asm dst (intern-non-immediate asm obj)))
(else