diff --git a/module/system/base/types/internal.scm b/module/system/base/types/internal.scm index 9e4e4cc9c..768deae92 100644 --- a/module/system/base/types/internal.scm +++ b/module/system/base/types/internal.scm @@ -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 () diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index ae527ddda..8f67cac51 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -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 (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