mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
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.
This commit is contained in:
Andy Wingo
parent
1ee99d97db
commit
d238566d0e
11 changed files with 227 additions and 146 deletions
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -217,6 +250,41 @@
|
|||
(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.
|
||||
|
|
@ -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)))
|
||||
(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.
|
||||
;; Rely on DCE to elide this expression, if possible.
|
||||
(setk label
|
||||
($kargs names vars
|
||||
($continue k* src ($primcall op param args))))))))))
|
||||
($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)
|
||||
(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))
|
||||
((x y)
|
||||
(or (fold-binary-branch cps label names vars kf kt src op param x y)
|
||||
cps))))
|
||||
(let lp ((label start) (cps cps))
|
||||
(if (<= label end)
|
||||
(lp (1+ label)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(true? (restrict! val ctype cval cval))
|
||||
(else
|
||||
(when (eqv? (&type val) &special-immediate)
|
||||
(let-values (((lo hi) (range-subtract (&min val) (&max val) imm)))
|
||||
(restrict! val &special-immediate lo hi)))))))
|
||||
(when (eqv? (&type val) ctype)
|
||||
(let-values (((lo hi) (range-subtract (&min val) (&max val) cval)))
|
||||
(restrict! val ctype 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)
|
||||
(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)))))
|
||||
|
|
|
|||
|
|
@ -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-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)))
|
||||
#: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)
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -207,17 +210,17 @@ may not fit into a word on the target platform."
|
|||
"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)
|
||||
|
|
|
|||
|
|
@ -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-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)))
|
||||
(emit-immediate-tag=? asm slot mask tag)))))
|
||||
|
||||
(visit-immediate-tags define-immediate-tag=?-macro-assembler)
|
||||
|
||||
|
|
|
|||
|
|
@ -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 '())
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue