mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Refactor lowering of Tree-IL primcalls to CPS

Browse source 
* module/language/tree-il/cps-primitives.scm: New file,
  replacing (language cps primitives).  Lists known primitives and their
  relation to Tree-IL explicitly, instead of assuming that any Tree-IL
  primcall that shares a name with a bytecode instruction is a CPS
  primcall.
* module/language/cps/verify.scm: Remove use of (language cps
  primitives) and primcall arity checking.  Would be nice to add this
  back at some point.
* module/language/tree-il/compile-cps.scm (convert): Refactor to use new
  tree-il-primitive->cps-primitive+nargs+nvalues helper.
* module/Makefile.am:
* am/bootstrap.am: Adapt.
This commit is contained in:
Andy Wingo 2017-12-26 10:18:59 +01:00
parent 549ad3ce8c
commit 36e6a3daca
6 changed files with 244 additions and 288 deletions
Download patch file Download diff file Expand all files Collapse all files

2
am/bootstrap.am
View file

@ -64,6 +64,7 @@ SOURCES = \
language/tree-il/analyze.scm \ language/tree-il/analyze.scm \
language/tree-il/canonicalize.scm \ language/tree-il/canonicalize.scm \
language/tree-il/compile-cps.scm \ language/tree-il/compile-cps.scm \
language/tree-il/cps-primitives.scm \
language/tree-il/debug.scm \ language/tree-il/debug.scm \
language/tree-il/effects.scm \ language/tree-il/effects.scm \
language/tree-il/fix-letrec.scm \ language/tree-il/fix-letrec.scm \
@ -85,7 +86,6 @@ SOURCES = \
language/cps/handle-interrupts.scm \ language/cps/handle-interrupts.scm \
language/cps/licm.scm \ language/cps/licm.scm \
language/cps/peel-loops.scm \ language/cps/peel-loops.scm \
language/cps/primitives.scm \
language/cps/prune-bailouts.scm \ language/cps/prune-bailouts.scm \
language/cps/prune-top-level-scopes.scm \ language/cps/prune-top-level-scopes.scm \
language/cps/reify-primitives.scm \ language/cps/reify-primitives.scm \

2
module/Makefile.am
View file

@ -144,7 +144,6 @@ SOURCES = \
language/cps/licm.scm \ language/cps/licm.scm \
language/cps/optimize.scm \ language/cps/optimize.scm \
language/cps/peel-loops.scm \ language/cps/peel-loops.scm \
language/cps/primitives.scm \
language/cps/prune-bailouts.scm \ language/cps/prune-bailouts.scm \
language/cps/prune-top-level-scopes.scm \ language/cps/prune-top-level-scopes.scm \
language/cps/reify-primitives.scm \ language/cps/reify-primitives.scm \
@ -191,6 +190,7 @@ SOURCES = \
language/tree-il/analyze.scm \ language/tree-il/analyze.scm \
language/tree-il/canonicalize.scm \ language/tree-il/canonicalize.scm \
language/tree-il/compile-cps.scm \ language/tree-il/compile-cps.scm \
language/tree-il/cps-primitives.scm \
language/tree-il/debug.scm \ language/tree-il/debug.scm \
language/tree-il/effects.scm \ language/tree-il/effects.scm \
language/tree-il/fix-letrec.scm \ language/tree-il/fix-letrec.scm \

199
module/language/cps/primitives.scm
View file

@ -1,199 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; Information about named primitives, as they appear in $prim and
;;; $primcall.
;;;
;;; Code:
(define-module (language cps primitives)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (srfi srfi-26)
#:use-module (language bytecode)
#:export (prim-instruction
branching-primitive?
heap-type-predicate?
prim-arity
))
(define *instruction-aliases*
'((+ . add)
(- . sub)
(* . mul)
(/ . div)
(quotient . quo) (remainder . rem)
(modulo . mod)
(variable-ref . box-ref)
(variable-set! . box-set!)
(bytevector-length . bv-length)
(bytevector-u8-ref . bv-u8-ref)
(bytevector-u16-native-ref . bv-u16-ref)
(bytevector-u32-native-ref . bv-u32-ref)
(bytevector-u64-native-ref . bv-u64-ref)
(bytevector-s8-ref . bv-s8-ref)
(bytevector-s16-native-ref . bv-s16-ref)
(bytevector-s32-native-ref . bv-s32-ref)
(bytevector-s64-native-ref . bv-s64-ref)
(bytevector-ieee-single-native-ref . bv-f32-ref)
(bytevector-ieee-double-native-ref . bv-f64-ref)
(bytevector-u8-set! . bv-u8-set!)
(bytevector-u16-native-set! . bv-u16-set!)
(bytevector-u32-native-set! . bv-u32-set!)
(bytevector-u64-native-set! . bv-u64-set!)
(bytevector-s8-set! . bv-s8-set!)
(bytevector-s16-native-set! . bv-s16-set!)
(bytevector-s32-native-set! . bv-s32-set!)
(bytevector-s64-native-set! . bv-s64-set!)
(bytevector-ieee-single-native-set! . bv-f32-set!)
(bytevector-ieee-double-native-set! . bv-f64-set!)))
(define *macro-instruction-arities*
'((u64->s64 . (1 . 1))
(s64->u64 . (1 . 1))
(sadd . (2 . 1))
(ssub . (2 . 1))
(smul . (2 . 1))
(sadd/immediate . (1 . 1))
(ssub/immediate . (1 . 1))
(smul/immediate . (1 . 1))
(slsh . (2 . 1))
(slsh/immediate . (1 . 1))
(u64->scm/unlikely . (1 . 1))
(s64->scm/unlikely . (1 . 1))
(tag-fixnum/unlikely . (1 . 1))
(load-const/unlikely . (0 . 1))
(cache-current-module! . (0 . 1))
(cached-toplevel-box . (1 . 0))
(cached-module-box . (1 . 0))))
(define *immediate-predicates*
'(fixnum?
char?
eq-nil?
eq-eol?
eq-false?
eq-true?
unspecified?
undefined?
eof-object?
null? ;; '() or #nil
false? ;; #f or #nil
nil? ;; #f or '() or #nil
heap-object?))
;; All of the following tests must be dominated by heap-object?.
(define *heap-type-predicates*
'(pair?
struct?
symbol?
variable?
vector?
string?
keyword?
bytevector?
bitvector?
heap-number?
bignum?))
;; FIXME: Support these.
(define *other-predicates*
'(weak-vector?
hash-table?
pointer?
fluid?
stringbuf?
dynamic-state?
frame?
syntax?
program?
vm-continuation?
weak-set?
weak-table?
array?
port?
smob?
flonum?
complex?
fraction?))
(define (heap-type-predicate? name)
"Is @var{name} a predicate that needs guarding by @code{heap-object?}
before it is lowered to CPS?"
(and (memq name *heap-type-predicates*) #t))
(define *comparisons*
'(eq?
heap-numbers-equal?
<
<=
=
u64-<
u64-=
s64-<
f64-<
f64-<=
f64-=))
(define *branching-primcall-arities* (make-hash-table))
(for-each (lambda (x) (hashq-set! *branching-primcall-arities* x '(1 . 1)))
*immediate-predicates*)
(for-each (lambda (x) (hashq-set! *branching-primcall-arities* x '(1 . 1)))
*heap-type-predicates*)
(for-each (lambda (x) (hashq-set! *branching-primcall-arities* x '(1 . 2)))
*comparisons*)
(define (compute-prim-instructions)
(let ((table (make-hash-table)))
(for-each
(match-lambda ((inst . _) (hashq-set! table inst inst)))
(instruction-list))
(for-each
(match-lambda ((prim . inst) (hashq-set! table prim inst)))
*instruction-aliases*)
(for-each
(match-lambda ((inst . arity) (hashq-set! table inst inst)))
*macro-instruction-arities*)
table))
(define *prim-instructions* (delay (compute-prim-instructions)))
;; prim -> instruction | #f
(define (prim-instruction name)
(hashq-ref (force *prim-instructions*) name))
(define (branching-primitive? name)
(and (hashq-ref *branching-primcall-arities* name) #t))
(define *prim-arities* (make-hash-table))
(define (prim-arity name)
(or (hashq-ref *prim-arities* name)
(let ((arity (cond
((prim-instruction name) => instruction-arity)
((hashq-ref *branching-primcall-arities* name))
(else
(error "Primitive of unknown arity" name)))))
(hashq-set! *prim-arities* name arity)
arity)))

14
module/language/cps/verify.scm
View file

@ -27,7 +27,6 @@
#:use-module (language cps utils) #:use-module (language cps utils)
#:use-module (language cps intmap) #:use-module (language cps intmap)
#:use-module (language cps intset) #:use-module (language cps intset)
#:use-module (language cps primitives)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:export (verify)) #:export (verify))
@ -244,16 +243,9 @@ definitions that are available at LABEL."
(cont (error "bad kt" cont)))) (cont (error "bad kt" cont))))
(($ $primcall name param args) (($ $primcall name param args)
(match cont (match cont
(($ $kargs names) (($ $kargs) #t)
(match (prim-arity name) ;; FIXME: Remove this case; instead use $prim and $call.
((out . in) (($ $kreceive) #t)
(unless (= in (length args))
(error "bad arity to primcall" name args in))
(unless (= out (length names))
(error "bad return arity from primcall" name names out)))))
(($ $kreceive)
(when (false-if-exception (prim-arity name))
(error "primitive should continue to $kargs, not $kreceive" name)))
(($ $ktail) (($ $ktail)
(unless (memv name '(throw throw/value throw/value+data)) (unless (memv name '(throw throw/value throw/value+data))
(error "primitive should continue to $kargs, not $ktail" name))))) (error "primitive should continue to $kargs, not $ktail" name)))))

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

@ -58,7 +58,7 @@
#:use-module (language cps) #:use-module (language cps)
#:use-module (language cps utils) #:use-module (language cps utils)
#:use-module (language cps with-cps) #:use-module (language cps with-cps)
#:use-module (language cps primitives) #:use-module (language tree-il cps-primitives)
#:use-module (language tree-il analyze) #:use-module (language tree-il analyze)
#:use-module (language tree-il optimize) #:use-module (language tree-il optimize)
#:use-module (language tree-il) #:use-module (language tree-il)
@ -443,13 +443,11 @@
(($ <let-values> src exp body) (zero-valued? body)) (($ <let-values> src exp body) (zero-valued? body))
(($ <seq> src head tail) (zero-valued? tail)) (($ <seq> src head tail) (zero-valued? tail))
(($ <primcall> src name args) (($ <primcall> src name args)
(match (prim-instruction name) (match (tree-il-primitive->cps-primitive+nargs+nvalues name)
(#f #f) (#f #f)
(inst (#(cps-prim nargs nvalues)
(match (prim-arity inst) (and (eqv? nvalues 0)
((out . in) (eqv? nargs (length args))))))
(and (eqv? out 0)
(eqv? in (length args))))))))
(_ #f))) (_ #f)))
(define (single-valued? exp) (define (single-valued? exp)
(match exp (match exp
@ -461,13 +459,11 @@
(($ <let-values> src exp body) (single-valued? body)) (($ <let-values> src exp body) (single-valued? body))
(($ <seq> src head tail) (single-valued? tail)) (($ <seq> src head tail) (single-valued? tail))
(($ <primcall> src name args) (($ <primcall> src name args)
(match (prim-instruction name) (match (tree-il-primitive->cps-primitive+nargs+nvalues name)
(#f #f) (#f #f)
(inst (#(cps-prim nargs nvalues)
(match (prim-arity inst) (and (eqv? nvalues 1)
((out . in) (eqv? nargs (length args))))))
(and (eqv? out 1)
(eqv? in (length args))))))))
(_ #f))) (_ #f)))
;; exp (v-name -> term) -> term ;; exp (v-name -> term) -> term
(define (convert-arg cps exp k) (define (convert-arg cps exp k)
@ -733,17 +729,19 @@
(specialize 'throw/value `#(,key ,subr ,msg) x)) (specialize 'throw/value `#(,key ,subr ,msg) x))
(_ (fallback))))) (_ (fallback)))))
(_ (fallback))))) (_ (fallback)))))
((prim-instruction name) ((tree-il-primitive->cps-primitive+nargs+nvalues name)
=> (lambda (instruction) =>
(define (cvt cps k src instruction args) (match-lambda
(#(cps-prim nargs nvalues)
(define (cvt cps k src op args)
(define (default) (define (default)
(convert-args cps args (convert-args cps args
(lambda (cps args) (lambda (cps args)
(with-cps cps (with-cps cps
($ (convert-primcall* k src instruction #f args)))))) ($ (convert-primcall* k src op #f args))))))
(define-syntax-rule (specialize-case (pat (op c (arg ...))) ... (define-syntax-rule (specialize-case (pat (op c (arg ...))) ...
(_ def)) (_ def))
(match (cons instruction args) (match (cons cps-prim args)
(pat (pat
(convert-args cps (list arg ...) (convert-args cps (list arg ...)
(lambda (cps args) (lambda (cps args)
@ -779,25 +777,21 @@
(rsh/immediate y (x))) (rsh/immediate y (x)))
(_ (_
(default)))) (default))))
(when (branching-primitive? name)
(error "branching primcall in bad context" name))
;; Tree-IL primcalls are sloppy, in that it could be that ;; Tree-IL primcalls are sloppy, in that it could be that
;; they are called with too many or too few arguments. In ;; they are called with too many or too few arguments. In
;; CPS we are more strict and only residualize a $primcall ;; CPS we are more strict and only residualize a $primcall
;; if the argument count matches. ;; if the argument count matches.
(match (prim-arity instruction) (if (= nargs (length args))
((out . in)
(if (= in (length args))
(with-cps cps (with-cps cps
(let$ k (adapt-arity k src out)) (let$ k (adapt-arity k src nvalues))
($ (cvt k src instruction args))) ($ (cvt k src cps-prim args)))
(convert-args cps args (convert-args cps args
(lambda (cps args) (lambda (cps args)
(with-cps cps (with-cps cps
(letv prim) (letv prim)
(letk kprim ($kargs ('prim) (prim) (letk kprim ($kargs ('prim) (prim)
($continue k src ($call prim args)))) ($continue k src ($call prim args))))
(build-term ($continue kprim src ($prim name))))))))))) (build-term ($continue kprim src ($prim name))))))))))
(else (else
;; We have something that's a primcall for Tree-IL but not for ;; We have something that's a primcall for Tree-IL but not for
;; CPS, which will get compiled as a call and so the right thing ;; CPS, which will get compiled as a call and so the right thing

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

@ -0,0 +1,169 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; Information about named primitives, as they appear in $prim and
;;; $primcall.
;;;
;;; Code:
(define-module (language tree-il cps-primitives)
#:use-module (ice-9 match)
#:use-module (language bytecode)
#:use-module (system base types internal)
#:export (tree-il-primitive->cps-primitive+nargs+nvalues
branching-primitive?
heap-type-predicate?))
(define *primitives* (make-hash-table))
(define-syntax define-cps-primitive
(syntax-rules ()
((_ (tree-il-primitive cps-primitive) nargs nvalues)
(hashq-set! *primitives* 'tree-il-primitive
'#(cps-primitive nargs nvalues)))
((_ primitive nargs nvalues)
(define-cps-primitive (primitive primitive) nargs nvalues))))
;; tree-il-prim -> #(cps-prim nargs nvalues) | #f
(define (tree-il-primitive->cps-primitive+nargs+nvalues name)
(hashq-ref *primitives* name))
(define-cps-primitive box 1 1)
(define-cps-primitive (variable-ref box-ref) 1 1)
(define-cps-primitive (variable-set! box-set!) 2 0)
(define-cps-primitive current-module 0 1)
(define-cps-primitive define! 1 1)
(define-cps-primitive wind 2 0)
(define-cps-primitive unwind 0 0)
(define-cps-primitive push-dynamic-state 1 0)
(define-cps-primitive pop-dynamic-state 0 0)
(define-cps-primitive push-fluid 2 0)
(define-cps-primitive pop-fluid 0 0)
(define-cps-primitive fluid-ref 1 1)
(define-cps-primitive fluid-set! 2 0)
(define-cps-primitive string-length 1 1)
(define-cps-primitive string-ref 2 1)
(define-cps-primitive string-set! 3 0)
(define-cps-primitive string->number 1 1)
(define-cps-primitive string->symbol 1 1)
(define-cps-primitive symbol->keyword 1 1)
(define-cps-primitive integer->char 1 1)
(define-cps-primitive char->integer 1 1)
(define-cps-primitive cons 2 1)
(define-cps-primitive car 1 1)
(define-cps-primitive cdr 1 1)
(define-cps-primitive set-car! 2 0)
(define-cps-primitive set-cdr! 2 0)
(define-cps-primitive (+ add) 2 1)
(define-cps-primitive (- sub) 2 1)
(define-cps-primitive (* mul) 2 1)
(define-cps-primitive (/ div) 2 1)
(define-cps-primitive (quotient quo) 2 1)
(define-cps-primitive (remainder rem) 2 1)
(define-cps-primitive (modulo mod) 2 1)
(define-cps-primitive lsh 2 1)
(define-cps-primitive rsh 2 1)
(define-cps-primitive logand 2 1)
(define-cps-primitive logior 2 1)
(define-cps-primitive logxor 2 1)
(define-cps-primitive logsub 2 1)
(define-cps-primitive make-vector 2 1)
(define-cps-primitive vector-length 1 1)
(define-cps-primitive vector-ref 2 1)
(define-cps-primitive vector-set! 3 0)
(define-cps-primitive struct-vtable 1 1)
(define-cps-primitive allocate-struct 2 1)
(define-cps-primitive struct-ref 2 1)
(define-cps-primitive struct-set! 3 0)
(define-cps-primitive class-of 1 1)
(define-cps-primitive (bytevector-length bv-length) 1 1)
(define-cps-primitive (bytevector-u8-ref bv-u8-ref) 2 1)
(define-cps-primitive (bytevector-u16-native-ref bv-u16-ref) 2 1)
(define-cps-primitive (bytevector-u32-native-ref bv-u32-ref) 2 1)
(define-cps-primitive (bytevector-u64-native-ref bv-u64-ref) 2 1)
(define-cps-primitive (bytevector-s8-ref bv-s8-ref) 2 1)
(define-cps-primitive (bytevector-s16-native-ref bv-s16-ref) 2 1)
(define-cps-primitive (bytevector-s32-native-ref bv-s32-ref) 2 1)
(define-cps-primitive (bytevector-s64-native-ref bv-s64-ref) 2 1)
(define-cps-primitive (bytevector-ieee-single-native-ref bv-f32-ref) 2 1)
(define-cps-primitive (bytevector-ieee-double-native-ref bv-f64-ref) 2 1)
(define-cps-primitive (bytevector-u8-set! bv-u8-set!) 3 0)
(define-cps-primitive (bytevector-u16-native-set! bv-u16-set!) 3 0)
(define-cps-primitive (bytevector-u32-native-set! bv-u32-set!) 3 0)
(define-cps-primitive (bytevector-u64-native-set! bv-u64-set!) 3 0)
(define-cps-primitive (bytevector-s8-set! bv-s8-set!) 3 0)
(define-cps-primitive (bytevector-s16-native-set! bv-s16-set!) 3 0)
(define-cps-primitive (bytevector-s32-native-set! bv-s32-set!) 3 0)
(define-cps-primitive (bytevector-s64-native-set! bv-s64-set!) 3 0)
(define-cps-primitive (bytevector-ieee-single-native-set! bv-f32-set!) 3 0)
(define-cps-primitive (bytevector-ieee-double-native-set! bv-f64-set!) 3 0)
(define-cps-primitive current-thread 0 1)
(define-cps-primitive make-atomic-box 1 1)
(define-cps-primitive atomic-box-ref 1 1)
(define-cps-primitive atomic-box-set! 2 0)
(define-cps-primitive atomic-box-swap! 2 1)
(define-cps-primitive atomic-box-compare-and-swap! 3 1)
(define *branching-primitive-arities* (make-hash-table))
(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 *heap-type-predicates* (make-hash-table))
(define-syntax-rule (define-heap-type-predicate name pred mask tag)
(begin
(hashq-set! *heap-type-predicates* 'pred #t)
(define-branching-primitive pred 1)))
(visit-immediate-tags define-immediate-type-predicate)
(visit-heap-tags define-heap-type-predicate)
(define (branching-primitive? name)
"Is @var{name} a primitive that can only appear in $branch CPS terms?"
(hashq-ref *branching-primitive-arities* name))
(define (heap-type-predicate? name)
"Is @var{name} a predicate that needs guarding by @code{heap-object?}
before it is lowered to CPS?"
(hashq-ref *heap-type-predicates* name))
;; We only need to define those branching primitives that are used as
;; Tree-IL primitives. There are others like u64-= which are emitted by
;; CPS code.
(define-branching-primitive eq? 2)
(define-branching-primitive heap-numbers-equal? 2)
(define-branching-primitive < 2)
(define-branching-primitive <= 2)
(define-branching-primitive = 2)