mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 01:00:20 +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

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

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