mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-19 02:00:26 +02:00
Code Activity

CPS compiler reduces eq? on constant to eq-constant?

Browse source 
* module/language/cps/compile-bytecode.scm (compile-function): Expect
  eq-constant? instead of eq-null?, etc.
* module/language/cps/effects-analysis.scm: Likewise.
* module/language/cps/reify-primitives.scm (reify-primitives): For
  eq-constant?, reify a $const unless the constant is an immediate whose
  encoding fits in 16 bits.
* module/language/cps/type-fold.scm (materialize-constant): Helper to
  make a constant from a type, min, and max.
  (fold-eq-constant?): New helper.
  (eq-constant?): New folder.
  (undefined?): Define specifically.
  (define-nullish-predicate-folder): Renamd from
  define-special-immediate-predicate-folder.  Use only for null?, false,
  and nil?.
  (*branch-reducers*): New mechanism.  Reduce eq? to eq-constant? if
  possible.
  (local-type-fold): Refactor to use materialize-constant, and to allow
  reducing branches.
* module/language/cps/types.scm (constant-type): Return three values
  instead of a type entry.
  (constant-type-entry): New function that returns a type entry.  Adapt
  callers.
  (infer-constant-comparison): New helper.
  (eq-constant?): New inferrer.
  (undefined?): New inferrer.
* module/language/tree-il/compile-bytecode.scm (eq-constant?): Fix
  truncate-bits signed arg.
  (define-immediate-type-predicate): Adapt to visit-immediate-tags
  change.
* module/language/tree-il/compile-cps.scm (convert): Convert eq? to
  constant to eq-constant?.  Advantaged is that it gets fixnums and
  chars in addition to special immediates.
* module/language/tree-il/cps-primitives.scm (define-immediate-type-predicate):
  Adapt to allow #f as pred.
* module/system/base/types/internal.scm (immediate-tags): Use #f as pred
  for false, nil, etc.
  (immediate-bits->scm): Adapt.
* module/system/vm/assembler.scm (emit-eq-null?, emit-eq-nil?)
  (emit-eq-false?, emit-eq-true?, emit-unspecified?, emit-eof-object?):
  Remove specialized emitters.
* module/system/vm/assembler.scm (define-immediate-tag=?-macro-assembler):
  Allow for pred to be #f.
* module/system/vm/disassembler.scm (define-immediate-tag-annotation):
  Adapt to pred being #f.
This commit is contained in:
Andy Wingo 2020-08-03 21:49:50 +02:00
parent 1ee99d97db
commit d238566d0e
11 changed files with 227 additions and 146 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -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)

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

@ -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)

6
module/system/vm/disassembler.scm
View file

@ -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 '())