[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/04: CPS compiler reduces eq? on constant to eq-consta
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 04/04: CPS compiler reduces eq? on constant to eq-constant? |
|
Date: |
Tue, 4 Aug 2020 03:50:25 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit d238566d0e6b36706c33d22c19b5c86d2e60640f
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Mon Aug 3 21:49:50 2020 +0200
CPS compiler reduces eq? on constant to eq-constant?
* 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.
---
module/language/cps/compile-bytecode.scm | 9 +-
module/language/cps/effects-analysis.scm | 7 +-
module/language/cps/reify-primitives.scm | 20 +++-
module/language/cps/type-fold.scm | 172 +++++++++++++++++++--------
module/language/cps/types.scm | 59 +++++----
module/language/tree-il/compile-bytecode.scm | 11 +-
module/language/tree-il/compile-cps.scm | 31 ++---
module/language/tree-il/cps-primitives.scm | 9 +-
module/system/base/types/internal.scm | 35 +++---
module/system/vm/assembler.scm | 16 +--
module/system/vm/disassembler.scm | 6 +-
11 files changed, 228 insertions(+), 147 deletions(-)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 51938a0..edf338d 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013-2019 Free Software Foundation, Inc.
+;; Copyright (C) 2013-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
@@ -476,13 +476,8 @@
(#('fixnum? #f (a)) (unary emit-fixnum? a))
(#('heap-object? #f (a)) (unary emit-heap-object? a))
(#('char? #f (a)) (unary emit-char? a))
- (#('eq-false? #f (a)) (unary emit-eq-false? a))
- (#('eq-nil? #f (a)) (unary emit-eq-nil? a))
- (#('eq-null? #f (a)) (unary emit-eq-null? a))
- (#('eq-true? #f (a)) (unary emit-eq-true? a))
- (#('unspecified? #f (a)) (unary emit-unspecified? a))
+ (#('eq-constant? imm (a)) (binary-test/imm emit-eq-immediate? a imm))
(#('undefined? #f (a)) (unary emit-undefined? a))
- (#('eof-object? #f (a)) (unary emit-eof-object? a))
(#('null? #f (a)) (unary emit-null? a))
(#('false? #f (a)) (unary emit-false? a))
(#('nil? #f (a)) (unary emit-nil? a))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 59f4191..f5021c8 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -301,13 +301,8 @@ the LABELS that are clobbered by the effects of LABEL."
((equal? x y))
((fixnum? arg))
((char? arg))
- ((eq-null? arg))
- ((eq-nil? arg))
- ((eq-false? arg))
- ((eq-true? arg))
- ((unspecified? arg))
+ ((eq-constant? arg))
((undefined? arg))
- ((eof-object? arg))
((null? arg))
((false? arg))
((nil? arg))
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index 5fc86cc..494f1ca 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013-2019 Free Software Foundation, Inc.
+;; Copyright (C) 2013-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
@@ -557,8 +557,19 @@
(define (u11? val) (<= 0 val #x7ff))
(define (u12? val) (<= 0 val #xfff))
(define (s12? val) (<= (- #x800) val #x7ff))
+ (define (imm16? val)
+ (and=> (scm->immediate-bits val)
+ (lambda (bits)
+ (truncate-bits bits 16 #t))))
+ (define (load-u64 k param)
+ (build-term ($continue k src ($primcall 'load-u64 param ()))))
+ (define (load-s64 k param)
+ (build-term ($continue k src ($primcall 'load-s64 param ()))))
+ (define (load-const k param)
+ (build-term ($continue k src ($const param))))
+
(define-syntax-rule (reify-constants ((op (pred? c) in ...)
- wrap-op (op* out ...))
+ wrap (op* out ...))
...
(_ default))
(match name
@@ -573,9 +584,7 @@
($kargs ('c) (c)
($branch kf kt src 'op* #f (out ...))))
(setk label
- ($kargs names vars
- ($continue kconst src
- ($primcall 'wrap-op param ())))))))))
+ ($kargs names vars ,(wrap kconst param))))))))
...
(_ default)))
(reify-constants
@@ -585,6 +594,7 @@
((s64-imm-= (s12? b) a) load-s64 (s64-= a b))
((s64-imm-< (s12? b) a) load-s64 (s64-< a b))
((imm-s64-< (s12? a) b) load-s64 (s64-< a b))
+ ((eq-constant? (imm16? b) a) load-const (eq? a b))
(_ cps))))
(($ $kargs names vars ($ $continue k src ($ $call proc args)))
(with-cps cps
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index 7cefbd2..b87730c 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -43,6 +43,28 @@
(define &scalar-types
(logior &fixnum &bignum &flonum &char &special-immediate))
+(define (materialize-constant type min max kt kf)
+ (cond
+ ((zero? type) (kf))
+ ((not (and (zero? (logand type (1- type)))
+ (zero? (logand type (lognot &scalar-types)))
+ (eqv? min max))) (kf))
+ ((eqv? type &fixnum) (kt min))
+ ((eqv? type &bignum) (kt min))
+ ((eqv? type &flonum) (kt (exact->inexact min)))
+ ((eqv? type &char) (kt (integer->char min)))
+ ((eqv? type &special-immediate)
+ (cond
+ ((eqv? min &null) (kt '()))
+ ((eqv? min &nil) (kt #nil))
+ ((eqv? min &false) (kt #f))
+ ((eqv? min &true) (kt #t))
+ ((eqv? min &unspecified) (kt *unspecified*))
+ ;; FIXME: &undefined here
+ ((eqv? min &eof) (kt the-eof-object))
+ (else (kf))))
+ (else (kf))))
+
(define *branch-folders* (make-hash-table))
(define-syntax-rule (define-branch-folder op f)
@@ -63,7 +85,25 @@
body ...)
(define-branch-folder op (lambda (param arg0 min0 max0 arg1 min1 max1) body
...)))
-(define-syntax-rule (define-special-immediate-predicate-folder op imin imax)
+(define (fold-eq-constant? ctype cval type min max)
+ (cond
+ ((zero? (logand type ctype)) (values #t #f))
+ ((eqv? type ctype)
+ (cond
+ ((or (< cval min) (< max cval)) (values #t #f))
+ ((= cval min max) (values #t #t))
+ (else (values #f #f))))
+ (else (values #f #f))))
+(define-unary-branch-folder* (eq-constant? param type min max)
+ (call-with-values (lambda () (constant-type param))
+ (lambda (ctype cval cval*)
+ ;; cval either equals cval* or is meaningless.
+ (fold-eq-constant? ctype cval type min max))))
+
+(define-unary-branch-folder (undefined? type min max)
+ (fold-eq-constant? &special-immediate &undefined type min max))
+
+(define-syntax-rule (define-nullish-predicate-folder op imin imax)
(define-unary-branch-folder (op type min max)
(let ((type* (logand type &special-immediate)))
(cond
@@ -75,16 +115,9 @@
(else (values #f #f))))
(else (values #f #f))))))
-(define-special-immediate-predicate-folder eq-nil? &nil &nil)
-(define-special-immediate-predicate-folder eq-eol? &null &null)
-(define-special-immediate-predicate-folder eq-false? &false &false)
-(define-special-immediate-predicate-folder eq-true? &true &true)
-(define-special-immediate-predicate-folder unspecified? &unspecified
&unspecified)
-(define-special-immediate-predicate-folder undefined? &undefined &undefined)
-(define-special-immediate-predicate-folder eof-object? &eof &eof)
-(define-special-immediate-predicate-folder null? &null &nil)
-(define-special-immediate-predicate-folder false? &nil &false)
-(define-special-immediate-predicate-folder nil? &null &false) ;; &nil in middle
+(define-nullish-predicate-folder null? &null &nil)
+(define-nullish-predicate-folder false? &nil &false)
+(define-nullish-predicate-folder nil? &null &false) ;; &nil in middle
(define-syntax-rule (define-unary-type-predicate-folder op &type)
(define-unary-branch-folder (op type min max)
@@ -219,6 +252,41 @@
+(define *branch-reducers* (make-hash-table))
+
+(define-syntax-rule (define-branch-reducer op f)
+ (hashq-set! *branch-reducers* 'op f))
+
+(define-syntax-rule (define-binary-branch-reducer
+ (op cps kf kt src
+ arg0 type0 min0 max0
+ arg1 type1 min1 max1)
+ body ...)
+ (define-branch-reducer op
+ (lambda (cps kf kt src param arg0 type0 min0 max0 arg1 type1 min1 max1)
+ body ...)))
+
+(define-binary-branch-reducer (eq? cps kf kt src
+ arg0 type0 min0 max0
+ arg1 type1 min1 max1)
+ (materialize-constant
+ type0 min0 max0
+ (lambda (const)
+ (with-cps cps
+ (build-term
+ ($branch kf kt src 'eq-constant? const (arg1)))))
+ (lambda ()
+ (materialize-constant
+ type1 min1 max1
+ (lambda (const)
+ (with-cps cps
+ (build-term
+ ($branch kf kt src 'eq-constant? const (arg0)))))
+ (lambda () (with-cps cps #f))))))
+
+
+
+
;; Convert e.g. rsh to rsh/immediate.
(define *primcall-macro-reducers* (make-hash-table))
@@ -535,45 +603,24 @@
-;;
-
(define (local-type-fold start end cps)
- (define (scalar-value type val)
- (cond
- ((eqv? type &fixnum) val)
- ((eqv? type &bignum) val)
- ((eqv? type &flonum) (exact->inexact val))
- ((eqv? type &char) (integer->char val))
- ((eqv? type &special-immediate)
- (cond
- ((eqv? val &null) '())
- ((eqv? val &nil) #nil)
- ((eqv? val &false) #f)
- ((eqv? val &true) #t)
- ((eqv? val &unspecified) *unspecified*)
- ;; FIXME: &undefined here
- ((eqv? val &eof) the-eof-object)
- (else (error "unhandled immediate" val))))
- (else (error "unhandled type" type val))))
(let ((types (infer-types cps start)))
(define (fold-primcall cps label names vars k src op param args def)
(call-with-values (lambda () (lookup-post-type types label def 0))
(lambda (type min max)
- (and (not (zero? type))
- (zero? (logand type (1- type)))
- (zero? (logand type (lognot &scalar-types)))
- (eqv? min max)
- (let ((val (scalar-value type min)))
- ;; (pk 'folded src op args val)
- (with-cps cps
- (letv v*)
- (letk k* ($kargs (#f) (v*)
- ($continue k src ($const val))))
- ;; Rely on DCE to elide this expression, if
- ;; possible.
- (setk label
- ($kargs names vars
- ($continue k* src ($primcall op param args))))))))))
+ (materialize-constant
+ type min max
+ (lambda (val)
+ ;; (pk 'folded src op args val)
+ (with-cps cps
+ (letv v*)
+ (letk k* ($kargs (#f) (v*)
+ ($continue k src ($const val))))
+ ;; Rely on DCE to elide this expression, if possible.
+ (setk label
+ ($kargs names vars
+ ($continue k* src ($primcall op param args))))))
+ (lambda () #f)))))
(define (transform-primcall f cps label names vars k src op param args)
(and f
(match args
@@ -611,6 +658,25 @@
((transform-primcall (hashq-ref *primcall-reducers* op)
cps label names vars k src op param args))
(else cps)))
+ (define (reduce-branch cps label names vars kf kt src op param args)
+ (and=>
+ (hashq-ref *branch-reducers* op)
+ (lambda (reducer)
+ (match args
+ ((arg0 arg1)
+ (call-with-values (lambda () (lookup-pre-type types label arg0))
+ (lambda (type0 min0 max0)
+ (call-with-values (lambda () (lookup-pre-type types label
arg1))
+ (lambda (type1 min1 max1)
+ (call-with-values (lambda ()
+ (reducer cps kf kt src param
+ arg0 type0 min0 max0
+ arg1 type1 min1 max1))
+ (lambda (cps term)
+ (and term
+ (with-cps cps
+ (setk label
+ ($kargs names vars ,term)))))))))))))))
(define (fold-unary-branch cps label names vars kf kt src op param arg)
(and=>
(hashq-ref *branch-folders* op)
@@ -644,6 +710,12 @@
($kargs names vars
($continue (if v kt kf) src
($values ())))))))))))))))
+ (define (fold-branch cps label names vars kf kt src op param args)
+ (match args
+ ((x)
+ (fold-unary-branch cps label names vars kf kt src op param x))
+ ((x y)
+ (fold-binary-branch cps label names vars kf kt src op param x y))))
(define (visit-primcall cps label names vars k src op param args)
;; We might be able to fold primcalls that define a value.
(match (intmap-ref cps k)
@@ -654,13 +726,9 @@
(reduce-primcall cps label names vars k src op param args))))
(define (visit-branch cps label names vars kf kt src op param args)
;; We might be able to fold primcalls that branch.
- (match args
- ((x)
- (or (fold-unary-branch cps label names vars kf kt src op param x)
- cps))
- ((x y)
- (or (fold-binary-branch cps label names vars kf kt src op param x y)
- cps))))
+ (or (fold-branch cps label names vars kf kt src op param args)
+ (reduce-branch cps label names vars kf kt src op param args)
+ cps))
(let lp ((label start) (cps cps))
(if (<= label end)
(lp (1+ label)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 88301ba..1c85da1 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -127,6 +127,7 @@
type<=?
;; Interface for type inference.
+ constant-type
infer-types
lookup-pre-type
lookup-post-type
@@ -342,8 +343,8 @@
minimum, and maximum."
(define (return type val)
(if val
- (make-type-entry type val val)
- (make-type-entry type -inf.0 +inf.0)))
+ (values type val val)
+ (values type -inf.0 +inf.0)))
(cond
((number? val)
(cond
@@ -356,8 +357,8 @@ minimum, and maximum."
val))
((eqv? (imag-part val) 0)
(if (nan? val)
- (make-type-entry &flonum -inf.0 +inf.0)
- (make-type-entry
+ (values &flonum -inf.0 +inf.0)
+ (values
(if (exact? val) &fraction &flonum)
(if (rational? val) (inexact->exact (floor val)) val)
(if (rational? val) (inexact->exact (ceiling val)) val))))
@@ -382,6 +383,13 @@ minimum, and maximum."
(else (error "unhandled constant" val))))
+(define (constant-type-entry val)
+ "Compute the type and range of VAL. Return three values: the type,
+minimum, and maximum."
+ (call-with-values (lambda () (constant-type val))
+ (lambda (type min max)
+ (make-type-entry type min max))))
+
(define *type-checkers* (make-hash-table))
(define *type-inferrers* (make-hash-table))
@@ -570,25 +578,28 @@ minimum, and maximum."
;;; Generic effect-free predicates.
;;;
-(define-syntax-rule (define-special-immediate-predicate-inferrer pred imm)
- (define-predicate-inferrer (pred val true?)
+(define-syntax-rule (infer-constant-comparison ctype cval val true?)
+ (let ()
(define (range-subtract lo hi x)
(values (if (eqv? lo x) (1+ lo) lo)
(if (eqv? hi x) (1- hi) hi)))
- (cond
- (true? (restrict! val &special-immediate imm imm))
- (else
- (when (eqv? (&type val) &special-immediate)
- (let-values (((lo hi) (range-subtract (&min val) (&max val) imm)))
- (restrict! val &special-immediate lo hi)))))))
-
-(define-special-immediate-predicate-inferrer eq-nil? &nil)
-(define-special-immediate-predicate-inferrer eq-eol? &null)
-(define-special-immediate-predicate-inferrer eq-false? &false)
-(define-special-immediate-predicate-inferrer eq-true? &true)
-(define-special-immediate-predicate-inferrer unspecified? &unspecified)
-(define-special-immediate-predicate-inferrer undefined? &undefined)
-(define-special-immediate-predicate-inferrer eof-object? &eof)
+ (cond
+ (true? (restrict! val ctype cval cval))
+ (else
+ (when (eqv? (&type val) ctype)
+ (let-values (((lo hi) (range-subtract (&min val) (&max val) cval)))
+ (restrict! val ctype lo hi)))))))
+
+(define-predicate-inferrer/param (eq-constant? c val true?)
+ (call-with-values (lambda () (constant-type c))
+ (lambda (ctype cval cval*)
+ ;; Either (= cval cval*), or the value is meaningless for this type.
+ (infer-constant-comparison ctype cval val true?))))
+
+;; Can't usefully pass undefined as a parameter to eq-constant?, so we
+;; keep its special predicate.
+(define-predicate-inferrer (undefined? val true?)
+ (infer-constant-comparison &special-immediate &undefined val true?))
;; Various inferrers rely on these having contiguous values starting from 0.
(eval-when (expand)
@@ -702,7 +713,7 @@ minimum, and maximum."
(define-type-inferrer/param (load-const/unlikely param result)
- (let ((ent (constant-type param)))
+ (let ((ent (constant-type-entry param)))
(define! result (type-entry-type ent)
(type-entry-min ent) (type-entry-max ent))))
@@ -1099,7 +1110,7 @@ minimum, and maximum."
(+ (&min a) (&min b))
(+ (&max a) (&max b))))
(define-type-inferrer/param (add/immediate param a result)
- (let ((b-type (type-entry-type (constant-type param))))
+ (let ((b-type (type-entry-type (constant-type-entry param))))
(define-binary-result! (&type a) b-type result #t
(+ (&min a) param)
(+ (&max a) param))))
@@ -1143,7 +1154,7 @@ minimum, and maximum."
(- (&min a) (&max b))
(- (&max a) (&min b))))
(define-type-inferrer/param (sub/immediate param a result)
- (let ((b-type (type-entry-type (constant-type param))))
+ (let ((b-type (type-entry-type (constant-type-entry param))))
(define-binary-result! (&type a) b-type result #t
(- (&min a) param)
(- (&max a) param))))
@@ -2027,7 +2038,7 @@ maximum, where type is a bitset as a fixnum."
(($ $kargs (_) (var))
(let ((entry (match exp
(($ $const val)
- (constant-type val))
+ (constant-type-entry val))
((or ($ $prim) ($ $fun) ($ $const-fun) ($ $code))
;; Could be more precise here.
(make-type-entry &procedure -inf.0 +inf.0)))))
diff --git a/module/language/tree-il/compile-bytecode.scm
b/module/language/tree-il/compile-bytecode.scm
index b6569c7..419f5c8 100644
--- a/module/language/tree-il/compile-bytecode.scm
+++ b/module/language/tree-il/compile-bytecode.scm
@@ -300,7 +300,7 @@
(and=>
(scm->immediate-bits x)
(lambda (bits)
- (truncate-bits bits 16 x))))
+ (truncate-bits bits 16 #t))))
#:emit/immediate (lambda (asm a b kf)
(emit-eq-immediate? asm a b)
(emit-jne asm kf)))
@@ -326,9 +326,12 @@
#`(lambda (asm a kf)
(#,(id-prepend 'emit- #'pred) asm a)
(emit-jne asm kf))))))
-(define-syntax-rule (define-immediate-type-predicate name pred mask tag)
- (define-primitive pred #:nargs 1 #:predicate? #t
- #:emit (predicate-emitter pred)))
+(define-syntax define-immediate-type-predicate
+ (syntax-rules ()
+ ((_ name #f mask tag) #f)
+ ((_ name pred mask tag)
+ (define-primitive pred #:nargs 1 #:predicate? #t
+ #:emit (predicate-emitter pred)))))
(define-syntax-rule (define-heap-type-predicate name pred mask tag)
(define-primitive pred #:nargs 1 #:predicate? #t
#:emit (lambda (asm a kf)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 9484e84..f0c7de6 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -2107,6 +2107,18 @@
(($ <conditional> src test consequent alternate)
(define (convert-test cps test kt kf)
(match test
+ (($ <primcall> src 'eq? (a ($ <const> _ b)))
+ (convert-arg cps a
+ (lambda (cps a)
+ (with-cps cps
+ (build-term ($branch kf kt src 'eq-constant? b (a)))))))
+
+ (($ <primcall> src 'eq? (($ <const> _ a) b))
+ (convert-arg cps b
+ (lambda (cps b)
+ (with-cps cps
+ (build-term ($branch kf kt src 'eq-constant? a (b)))))))
+
(($ <primcall> src (? branching-primitive? name) args)
(convert-args cps args
(lambda (cps args)
@@ -2365,25 +2377,6 @@ integer."
(make-const src #t)
(make-const src #f)))
- ;; Specialize eq?.
- (($ <primcall> src 'eq? (a b))
- (define (reify-branch test args)
- ;; No need to reduce as test is a branching primitive.
- (make-conditional src (make-primcall src test args)
- (make-const src #t)
- (make-const src #f)))
- (let ((a (if (const? b) a b))
- (b (if (const? b) b a)))
- (define (simplify test) (reify-branch test (list a)))
- (match b
- (($ <const> _ '()) (simplify 'eq-null?))
- (($ <const> _ #f) (simplify 'eq-false?))
- (($ <const> _ #t) (simplify 'eq-true?))
- (($ <const> _ #nil) (simplify 'eq-nil?))
- (($ <const> _ (? unspecified?)) (simplify 'unspecified?))
- (($ <const> _ (? eof-object?)) (simplify 'eof-object?))
- (_ (reify-branch 'eq? (list a b))))))
-
(($ <primcall> src (? branching-primitive? name) args)
;; No need to reduce because test is not reducible: reifying
;; #t/#f is the right thing.
diff --git a/module/language/tree-il/cps-primitives.scm
b/module/language/tree-il/cps-primitives.scm
index 8534599..1964619 100644
--- a/module/language/tree-il/cps-primitives.scm
+++ b/module/language/tree-il/cps-primitives.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013-2015, 2017-2019 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015, 2017-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
@@ -160,8 +160,11 @@
(define-syntax-rule (define-branching-primitive name nargs)
(hashq-set! *branching-primitive-arities* 'name '(0 . nargs)))
-(define-syntax-rule (define-immediate-type-predicate name pred mask tag)
- (define-branching-primitive pred 1))
+(define-syntax define-immediate-type-predicate
+ (syntax-rules ()
+ ((_ name #f mask tag) #f)
+ ((_ name pred mask tag)
+ (define-branching-primitive pred 1))))
(define *heap-type-predicates* (make-hash-table))
(define-syntax-rule (define-heap-type-predicate name pred mask tag)
(begin
diff --git a/module/system/base/types/internal.scm
b/module/system/base/types/internal.scm
index 768deae..c75ca3b 100644
--- a/module/system/base/types/internal.scm
+++ b/module/system/base/types/internal.scm
@@ -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)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 8f67cac..698d44d 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -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)
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index 28f4338..cc05549 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -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 '())