mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +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

9
module/language/cps/compile-bytecode.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -476,13 +476,8 @@
(#('fixnum? #f (a)) (unary emit-fixnum? a)) (#('fixnum? #f (a)) (unary emit-fixnum? a))
(#('heap-object? #f (a)) (unary emit-heap-object? a)) (#('heap-object? #f (a)) (unary emit-heap-object? a))
(#('char? #f (a)) (unary emit-char? a)) (#('char? #f (a)) (unary emit-char? a))
(#('eq-false? #f (a)) (unary emit-eq-false? a)) (#('eq-constant? imm (a)) (binary-test/imm emit-eq-immediate? a imm))
(#('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))
(#('undefined? #f (a)) (unary emit-undefined? a)) (#('undefined? #f (a)) (unary emit-undefined? a))
(#('eof-object? #f (a)) (unary emit-eof-object? a))
(#('null? #f (a)) (unary emit-null? a)) (#('null? #f (a)) (unary emit-null? a))
(#('false? #f (a)) (unary emit-false? a)) (#('false? #f (a)) (unary emit-false? a))
(#('nil? #f (a)) (unary emit-nil? a)) (#('nil? #f (a)) (unary emit-nil? a))

7
module/language/cps/effects-analysis.scm
View file

@ -301,13 +301,8 @@ the LABELS that are clobbered by the effects of LABEL."
((equal? x y)) ((equal? x y))
((fixnum? arg)) ((fixnum? arg))
((char? arg)) ((char? arg))
((eq-null? arg)) ((eq-constant? arg))
((eq-nil? arg))
((eq-false? arg))
((eq-true? arg))
((unspecified? arg))
((undefined? arg)) ((undefined? arg))
((eof-object? arg))
((null? arg)) ((null? arg))
((false? arg)) ((false? arg))
((nil? arg)) ((nil? arg))

20
module/language/cps/reify-primitives.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -557,8 +557,19 @@
(define (u11? val) (<= 0 val #x7ff)) (define (u11? val) (<= 0 val #x7ff))
(define (u12? val) (<= 0 val #xfff)) (define (u12? val) (<= 0 val #xfff))
(define (s12? val) (<= (- #x800) val #x7ff)) (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 ...) (define-syntax-rule (reify-constants ((op (pred? c) in ...)
wrap-op (op* out ...)) wrap (op* out ...))
... ...
(_ default)) (_ default))
(match name (match name
@ -573,9 +584,7 @@
($kargs ('c) (c) ($kargs ('c) (c)
($branch kf kt src 'op* #f (out ...)))) ($branch kf kt src 'op* #f (out ...))))
(setk label (setk label
($kargs names vars ($kargs names vars ,(wrap kconst param))))))))
($continue kconst src
($primcall 'wrap-op param ())))))))))
... ...
(_ default))) (_ default)))
(reify-constants (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))
((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)) ((imm-s64-< (s12? a) b) load-s64 (s64-< a b))
((eq-constant? (imm16? b) a) load-const (eq? a b))
(_ cps)))) (_ cps))))
(($ $kargs names vars ($ $continue k src ($ $call proc args))) (($ $kargs names vars ($ $continue k src ($ $call proc args)))
(with-cps cps (with-cps cps

172
module/language/cps/type-fold.scm
View file

@ -43,6 +43,28 @@
(define &scalar-types (define &scalar-types
(logior &fixnum &bignum &flonum &char &special-immediate)) (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 *branch-folders* (make-hash-table))
(define-syntax-rule (define-branch-folder op f) (define-syntax-rule (define-branch-folder op f)
@ -63,7 +85,25 @@
body ...) body ...)
(define-branch-folder op (lambda (param arg0 min0 max0 arg1 min1 max1) 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) (define-unary-branch-folder (op type min max)
(let ((type* (logand type &special-immediate))) (let ((type* (logand type &special-immediate)))
(cond (cond
@ -75,16 +115,9 @@
(else (values #f #f)))) (else (values #f #f))))
(else (values #f #f)))))) (else (values #f #f))))))
(define-special-immediate-predicate-folder eq-nil? &nil &nil) (define-nullish-predicate-folder null? &null &nil)
(define-special-immediate-predicate-folder eq-eol? &null &null) (define-nullish-predicate-folder false? &nil &false)
(define-special-immediate-predicate-folder eq-false? &false &false) (define-nullish-predicate-folder nil? &null &false) ;; &nil in middle
(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-syntax-rule (define-unary-type-predicate-folder op &type) (define-syntax-rule (define-unary-type-predicate-folder op &type)
(define-unary-branch-folder (op type min max) (define-unary-branch-folder (op type min max)
@ -217,6 +250,41 @@
(define-branch-folder-alias s64-= u64-=) (define-branch-folder-alias s64-= u64-=)
(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. ;; Convert e.g. rsh to rsh/immediate.
@ -535,45 +603,24 @@
;;
(define (local-type-fold start end cps) (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))) (let ((types (infer-types cps start)))
(define (fold-primcall cps label names vars k src op param args def) (define (fold-primcall cps label names vars k src op param args def)
(call-with-values (lambda () (lookup-post-type types label def 0)) (call-with-values (lambda () (lookup-post-type types label def 0))
(lambda (type min max) (lambda (type min max)
(and (not (zero? type)) (materialize-constant
(zero? (logand type (1- type))) type min max
(zero? (logand type (lognot &scalar-types))) (lambda (val)
(eqv? min max) ;; (pk 'folded src op args val)
(let ((val (scalar-value type min))) (with-cps cps
;; (pk 'folded src op args val) (letv v*)
(with-cps cps (letk k* ($kargs (#f) (v*)
(letv v*) ($continue k src ($const val))))
(letk k* ($kargs (#f) (v*) ;; Rely on DCE to elide this expression, if possible.
($continue k src ($const val)))) (setk label
;; Rely on DCE to elide this expression, if ($kargs names vars
;; possible. ($continue k* src ($primcall op param args))))))
(setk label (lambda () #f)))))
($kargs names vars
($continue k* src ($primcall op param args))))))))))
(define (transform-primcall f cps label names vars k src op param args) (define (transform-primcall f cps label names vars k src op param args)
(and f (and f
(match args (match args
@ -611,6 +658,25 @@
((transform-primcall (hashq-ref *primcall-reducers* op) ((transform-primcall (hashq-ref *primcall-reducers* op)
cps label names vars k src op param args)) cps label names vars k src op param args))
(else cps))) (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) (define (fold-unary-branch cps label names vars kf kt src op param arg)
(and=> (and=>
(hashq-ref *branch-folders* op) (hashq-ref *branch-folders* op)
@ -644,6 +710,12 @@
($kargs names vars ($kargs names vars
($continue (if v kt kf) src ($continue (if v kt kf) src
($values ()))))))))))))))) ($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) (define (visit-primcall cps label names vars k src op param args)
;; We might be able to fold primcalls that define a value. ;; We might be able to fold primcalls that define a value.
(match (intmap-ref cps k) (match (intmap-ref cps k)
@ -654,13 +726,9 @@
(reduce-primcall cps label names vars k src op param args)))) (reduce-primcall cps label names vars k src op param args))))
(define (visit-branch cps label names vars kf kt 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. ;; We might be able to fold primcalls that branch.
(match args (or (fold-branch cps label names vars kf kt src op param args)
((x) (reduce-branch cps label names vars kf kt src op param args)
(or (fold-unary-branch cps label names vars kf kt src op param x) cps))
cps))
((x y)
(or (fold-binary-branch cps label names vars kf kt src op param x y)
cps))))
(let lp ((label start) (cps cps)) (let lp ((label start) (cps cps))
(if (<= label end) (if (<= label end)
(lp (1+ label) (lp (1+ label)

57
module/language/cps/types.scm
View file

@ -127,6 +127,7 @@
type<=? type<=?
;; Interface for type inference. ;; Interface for type inference.
constant-type
infer-types infer-types
lookup-pre-type lookup-pre-type
lookup-post-type lookup-post-type
@ -342,8 +343,8 @@
minimum, and maximum." minimum, and maximum."
(define (return type val) (define (return type val)
(if val (if val
(make-type-entry type val val) (values type val val)
(make-type-entry type -inf.0 +inf.0))) (values type -inf.0 +inf.0)))
(cond (cond
((number? val) ((number? val)
(cond (cond
@ -356,8 +357,8 @@ minimum, and maximum."
val)) val))
((eqv? (imag-part val) 0) ((eqv? (imag-part val) 0)
(if (nan? val) (if (nan? val)
(make-type-entry &flonum -inf.0 +inf.0) (values &flonum -inf.0 +inf.0)
(make-type-entry (values
(if (exact? val) &fraction &flonum) (if (exact? val) &fraction &flonum)
(if (rational? val) (inexact->exact (floor val)) val) (if (rational? val) (inexact->exact (floor val)) val)
(if (rational? val) (inexact->exact (ceiling val)) val)))) (if (rational? val) (inexact->exact (ceiling val)) val))))
@ -382,6 +383,13 @@ minimum, and maximum."
(else (error "unhandled constant" val)))) (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-checkers* (make-hash-table))
(define *type-inferrers* (make-hash-table)) (define *type-inferrers* (make-hash-table))
@ -570,25 +578,28 @@ minimum, and maximum."
;;; Generic effect-free predicates. ;;; Generic effect-free predicates.
;;; ;;;
(define-syntax-rule (define-special-immediate-predicate-inferrer pred imm) (define-syntax-rule (infer-constant-comparison ctype cval val true?)
(define-predicate-inferrer (pred val true?) (let ()
(define (range-subtract lo hi x) (define (range-subtract lo hi x)
(values (if (eqv? lo x) (1+ lo) lo) (values (if (eqv? lo x) (1+ lo) lo)
(if (eqv? hi x) (1- hi) hi))) (if (eqv? hi x) (1- hi) hi)))
(cond (cond
(true? (restrict! val &special-immediate imm imm)) (true? (restrict! val ctype cval cval))
(else (else
(when (eqv? (&type val) &special-immediate) (when (eqv? (&type val) ctype)
(let-values (((lo hi) (range-subtract (&min val) (&max val) imm))) (let-values (((lo hi) (range-subtract (&min val) (&max val) cval)))
(restrict! val &special-immediate lo hi))))))) (restrict! val ctype lo hi)))))))
(define-special-immediate-predicate-inferrer eq-nil? &nil) (define-predicate-inferrer/param (eq-constant? c val true?)
(define-special-immediate-predicate-inferrer eq-eol? &null) (call-with-values (lambda () (constant-type c))
(define-special-immediate-predicate-inferrer eq-false? &false) (lambda (ctype cval cval*)
(define-special-immediate-predicate-inferrer eq-true? &true) ;; Either (= cval cval*), or the value is meaningless for this type.
(define-special-immediate-predicate-inferrer unspecified? &unspecified) (infer-constant-comparison ctype cval val true?))))
(define-special-immediate-predicate-inferrer undefined? &undefined)
(define-special-immediate-predicate-inferrer eof-object? &eof) ;; 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. ;; Various inferrers rely on these having contiguous values starting from 0.
(eval-when (expand) (eval-when (expand)
@ -702,7 +713,7 @@ minimum, and maximum."
(define-type-inferrer/param (load-const/unlikely param result) (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) (define! result (type-entry-type ent)
(type-entry-min ent) (type-entry-max ent)))) (type-entry-min ent) (type-entry-max ent))))
@ -1099,7 +1110,7 @@ minimum, and maximum."
(+ (&min a) (&min b)) (+ (&min a) (&min b))
(+ (&max a) (&max b)))) (+ (&max a) (&max b))))
(define-type-inferrer/param (add/immediate param a result) (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 (define-binary-result! (&type a) b-type result #t
(+ (&min a) param) (+ (&min a) param)
(+ (&max a) param)))) (+ (&max a) param))))
@ -1143,7 +1154,7 @@ minimum, and maximum."
(- (&min a) (&max b)) (- (&min a) (&max b))
(- (&max a) (&min b)))) (- (&max a) (&min b))))
(define-type-inferrer/param (sub/immediate param a result) (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 (define-binary-result! (&type a) b-type result #t
(- (&min a) param) (- (&min a) param)
(- (&max a) param)))) (- (&max a) param))))
@ -2027,7 +2038,7 @@ maximum, where type is a bitset as a fixnum."
(($ $kargs (_) (var)) (($ $kargs (_) (var))
(let ((entry (match exp (let ((entry (match exp
(($ $const val) (($ $const val)
(constant-type val)) (constant-type-entry val))
((or ($ $prim) ($ $fun) ($ $const-fun) ($ $code)) ((or ($ $prim) ($ $fun) ($ $const-fun) ($ $code))
;; Could be more precise here. ;; Could be more precise here.
(make-type-entry &procedure -inf.0 +inf.0))))) (make-type-entry &procedure -inf.0 +inf.0)))))

11
module/language/tree-il/compile-bytecode.scm
View file

@ -300,7 +300,7 @@
(and=> (and=>
(scm->immediate-bits x) (scm->immediate-bits x)
(lambda (bits) (lambda (bits)
(truncate-bits bits 16 x)))) (truncate-bits bits 16 #t))))
#:emit/immediate (lambda (asm a b kf) #:emit/immediate (lambda (asm a b kf)
(emit-eq-immediate? asm a b) (emit-eq-immediate? asm a b)
(emit-jne asm kf))) (emit-jne asm kf)))
@ -326,9 +326,12 @@
#`(lambda (asm a kf) #`(lambda (asm a kf)
(#,(id-prepend 'emit- #'pred) asm a) (#,(id-prepend 'emit- #'pred) asm a)
(emit-jne asm kf)))))) (emit-jne asm kf))))))
(define-syntax-rule (define-immediate-type-predicate name pred mask tag) (define-syntax define-immediate-type-predicate
(define-primitive pred #:nargs 1 #:predicate? #t (syntax-rules ()
#:emit (predicate-emitter pred))) ((_ 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-syntax-rule (define-heap-type-predicate name pred mask tag)
(define-primitive pred #:nargs 1 #:predicate? #t (define-primitive pred #:nargs 1 #:predicate? #t
#:emit (lambda (asm a kf) #:emit (lambda (asm a kf)

31
module/language/tree-il/compile-cps.scm
View file

@ -2107,6 +2107,18 @@
(($ <conditional> src test consequent alternate) (($ <conditional> src test consequent alternate)
(define (convert-test cps test kt kf) (define (convert-test cps test kt kf)
(match test (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) (($ <primcall> src (? branching-primitive? name) args)
(convert-args cps args (convert-args cps args
(lambda (cps args) (lambda (cps args)
@ -2365,25 +2377,6 @@ integer."
(make-const src #t) (make-const src #t)
(make-const src #f))) (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) (($ <primcall> src (? branching-primitive? name) args)
;; No need to reduce because test is not reducible: reifying ;; No need to reduce because test is not reducible: reifying
;; #t/#f is the right thing. ;; #t/#f is the right thing.

9
module/language/tree-il/cps-primitives.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -160,8 +160,11 @@
(define-syntax-rule (define-branching-primitive name nargs) (define-syntax-rule (define-branching-primitive name nargs)
(hashq-set! *branching-primitive-arities* 'name '(0 . nargs))) (hashq-set! *branching-primitive-arities* 'name '(0 . nargs)))
(define-syntax-rule (define-immediate-type-predicate name pred mask tag) (define-syntax define-immediate-type-predicate
(define-branching-primitive pred 1)) (syntax-rules ()
((_ name #f mask tag) #f)
((_ name pred mask tag)
(define-branching-primitive pred 1))))
(define *heap-type-predicates* (make-hash-table)) (define *heap-type-predicates* (make-hash-table))
(define-syntax-rule (define-heap-type-predicate name pred mask tag) (define-syntax-rule (define-heap-type-predicate name pred mask tag)
(begin (begin

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

@ -103,13 +103,16 @@
(fixnum fixnum? #b11 #b10) (fixnum fixnum? #b11 #b10)
(heap-object heap-object? #b111 #b000) (heap-object heap-object? #b111 #b000)
(char char? #b11111111 #b00001100) (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) (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) ;;(nil eq-nil? #b111111111111 #b000100000100)
;;(eol eq-null? #b111111111111 #b001100000100) ;;(eol eq-null? #b111111111111 #b001100000100)
@ -200,24 +203,24 @@ may not fit into a word on the target platform."
((eq? x #t) %tc16-true) ((eq? x #t) %tc16-true)
((unspecified? x) %tc16-unspecified) ((unspecified? x) %tc16-unspecified)
;; FIXME: %tc16-undefined. ;; FIXME: %tc16-undefined.
((eof-object? x) %tc16-eof) ((eof-object? x) %tc16-eof)
(else #f))) (else #f)))
(define (immediate-bits->scm imm) (define (immediate-bits->scm imm)
"Return the SCM object corresponding to the immediate encoding "Return the SCM object corresponding to the immediate encoding
@code{imm}. Note that this value should be sign-extended already." @code{imm}. Note that this value should be sign-extended already."
(define-syntax-rule (define-predicate name pred mask tag) (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) (visit-immediate-tags define-predicate)
(cond (cond
((fixnum?) (ash imm -2)) ((fixnum) (ash imm -2))
((char?) (integer->char (ash imm -8))) ((char) (integer->char (ash imm -8)))
((eq-false?) #f) ((false) #f)
((eq-nil?) #nil) ((nil) #nil)
((eq-null?) '()) ((null) '())
((eq-true?) #t) ((true) #t)
((unspecified?) (if #f #f)) ((unspecified) (if #f #f))
((eof-object?) the-eof-object) ((eof) the-eof-object)
(else (error "invalid immediate" imm))) ) (else (error "invalid immediate" imm))) )
(define (sign-extend x bits) (define (sign-extend x bits)

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

@ -95,14 +95,7 @@
emit-fixnum? emit-fixnum?
emit-heap-object? emit-heap-object?
emit-char? emit-char?
emit-eq-null?
emit-eq-nil?
emit-eq-false?
emit-eq-true?
emit-unspecified?
emit-undefined? emit-undefined?
emit-eof-object?
emit-null? emit-null?
emit-false? emit-false?
emit-nil? emit-nil?
@ -1390,9 +1383,12 @@ returned instead."
(let ((loc (intern-constant asm (make-static-procedure label)))) (let ((loc (intern-constant asm (make-static-procedure label))))
(emit-make-non-immediate asm dst loc))) (emit-make-non-immediate asm dst loc)))
(define-syntax-rule (define-immediate-tag=?-macro-assembler name pred mask tag) (define-syntax define-immediate-tag=?-macro-assembler
(define-macro-assembler (pred asm slot) (syntax-rules ()
(emit-immediate-tag=? asm slot mask tag))) ((_ 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) (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 immediate-tag-annotations '())
(define-syntax-rule (define-immediate-tag-annotation name pred mask tag) (define-syntax-rule (define-immediate-tag-annotation name pred mask tag)
(set! immediate-tag-annotations (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) (visit-immediate-tags define-immediate-tag-annotation)
(define heap-tag-annotations '()) (define heap-tag-annotations '())