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

$branch is now a distinct CPS term type

Browse source 
* module/language/cps.scm ($branch): Refactor to be its own CPS term
  type, not relying on $continue to specify a continuation (which before
  was only for the false case) or a source location.  Update allllllll
  callers.
This commit is contained in:
Andy Wingo 2018-01-03 14:15:35 +01:00
parent 108ade6b0e
commit afb0a92d50
26 changed files with 907 additions and 804 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

@ -33,6 +33,7 @@
(eval . (put '$letk* 'scheme-indent-function 1)) (eval . (put '$letk* 'scheme-indent-function 1))
(eval . (put '$letconst 'scheme-indent-function 1)) (eval . (put '$letconst 'scheme-indent-function 1))
(eval . (put '$continue 'scheme-indent-function 2)) (eval . (put '$continue 'scheme-indent-function 2))
(eval . (put '$branch 'scheme-indent-function 3))
(eval . (put '$kargs 'scheme-indent-function 2)) (eval . (put '$kargs 'scheme-indent-function 2))
(eval . (put '$kfun 'scheme-indent-function 4)) (eval . (put '$kfun 'scheme-indent-function 4))
(eval . (put '$letrec 'scheme-indent-function 3)) (eval . (put '$letrec 'scheme-indent-function 3))

35
module/language/cps.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -127,10 +127,10 @@
$kreceive $kargs $kfun $ktail $kclause $kreceive $kargs $kfun $ktail $kclause
;; Terms. ;; Terms.
$continue $continue $branch
;; Expressions. ;; Expressions.
$const $prim $fun $rec $closure $branch $const $prim $fun $rec $closure
$call $callk $primcall $values $prompt $call $callk $primcall $values $prompt
;; Building macros. ;; Building macros.
@ -179,6 +179,7 @@
;; Terms. ;; Terms.
(define-cps-type $continue k src exp) (define-cps-type $continue k src exp)
(define-cps-type $branch kf kt src op param args)
;; Expressions. ;; Expressions.
(define-cps-type $const val) (define-cps-type $const val)
@ -186,7 +187,6 @@
(define-cps-type $fun body) ; Higher-order. (define-cps-type $fun body) ; Higher-order.
(define-cps-type $rec names syms funs) ; Higher-order. (define-cps-type $rec names syms funs) ; Higher-order.
(define-cps-type $closure label nfree) ; First-order. (define-cps-type $closure label nfree) ; First-order.
(define-cps-type $branch kt exp)
(define-cps-type $call proc args) (define-cps-type $call proc args)
(define-cps-type $callk k proc args) ; First-order. (define-cps-type $callk k proc args) ; First-order.
(define-cps-type $primcall name param args) (define-cps-type $primcall name param args)
@ -223,11 +223,17 @@
((_ (unquote exp)) ((_ (unquote exp))
exp) exp)
((_ ($continue k src exp)) ((_ ($continue k src exp))
(make-$continue k src (build-exp exp))))) (make-$continue k src (build-exp exp)))
((_ ($branch kf kt src op param (unquote args)))
(make-$branch kf kt src op param args))
((_ ($branch kf kt src op param (arg ...)))
(make-$branch kf kt src op param (list arg ...)))
((_ ($branch kf kt src op param args))
(make-$branch kf kt src op param args))))
(define-syntax build-exp (define-syntax build-exp
(syntax-rules (unquote (syntax-rules (unquote
$const $prim $fun $rec $closure $branch $const $prim $fun $rec $closure
$call $callk $primcall $values $prompt) $call $callk $primcall $values $prompt)
((_ (unquote exp)) exp) ((_ (unquote exp)) exp)
((_ ($const val)) (make-$const val)) ((_ ($const val)) (make-$const val))
@ -247,7 +253,6 @@
((_ ($values (unquote args))) (make-$values args)) ((_ ($values (unquote args))) (make-$values args))
((_ ($values (arg ...))) (make-$values (list arg ...))) ((_ ($values (arg ...))) (make-$values (list arg ...)))
((_ ($values args)) (make-$values args)) ((_ ($values args)) (make-$values args))
((_ ($branch kt exp)) (make-$branch kt (build-exp exp)))
((_ ($prompt escape? tag handler)) ((_ ($prompt escape? tag handler))
(make-$prompt escape? tag handler)))) (make-$prompt escape? tag handler))))
@ -280,9 +285,13 @@
(('kclause (req opt rest kw allow-other-keys?) kbody kalt) (('kclause (req opt rest kw allow-other-keys?) kbody kalt)
(build-cont ($kclause (req opt rest kw allow-other-keys?) kbody kalt))) (build-cont ($kclause (req opt rest kw allow-other-keys?) kbody kalt)))
;; Calls. ;; Terms.
(('continue k exp) (('continue k exp)
(build-term ($continue k (src exp) ,(parse-cps exp)))) (build-term ($continue k (src exp) ,(parse-cps exp))))
(('branch kf kt op param arg ...)
(build-term ($branch kf kt (src exp) op param arg)))
;; Expressions.
(('unspecified) (('unspecified)
(build-exp ($const *unspecified*))) (build-exp ($const *unspecified*)))
(('const exp) (('const exp)
@ -301,8 +310,6 @@
(build-exp ($callk k proc arg))) (build-exp ($callk k proc arg)))
(('primcall name param arg ...) (('primcall name param arg ...)
(build-exp ($primcall name param arg))) (build-exp ($primcall name param arg)))
(('branch k exp)
(build-exp ($branch k ,(parse-cps exp))))
(('values arg ...) (('values arg ...)
(build-exp ($values arg))) (build-exp ($values arg)))
(('prompt escape? tag handler) (('prompt escape? tag handler)
@ -325,9 +332,13 @@
`(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,kbody `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,kbody
. ,(if kalternate (list kalternate) '()))) . ,(if kalternate (list kalternate) '())))
;; Calls. ;; Terms.
(($ $continue k src exp) (($ $continue k src exp)
`(continue ,k ,(unparse-cps exp))) `(continue ,k ,(unparse-cps exp)))
(($ $branch kf kt src op param args)
`(branch ,kf ,kt ,op ,param ,@args))
;; Expressions.
(($ $const val) (($ $const val)
(if (unspecified? val) (if (unspecified? val)
'(unspecified) '(unspecified)
@ -348,8 +359,6 @@
`(callk ,k ,proc ,@args)) `(callk ,k ,proc ,@args))
(($ $primcall name param args) (($ $primcall name param args)
`(primcall ,name ,param ,@args)) `(primcall ,name ,param ,@args))
(($ $branch k exp)
`(branch ,k ,(unparse-cps exp)))
(($ $values args) (($ $values args)
`(values ,@args)) `(values ,@args))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)

89
module/language/cps/closure-conversion.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -89,12 +89,12 @@ conts."
(add-uses args uses)) (add-uses args uses))
(($ $call proc args) (($ $call proc args)
(add-uses args uses)) (add-uses args uses))
(($ $branch kt ($ $primcall name param args))
(add-uses args uses))
(($ $primcall name param args) (($ $primcall name param args)
(add-uses args uses)) (add-uses args uses))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(add-use tag uses)))) (add-use tag uses))))
(($ $kargs _ _ ($ $branch kf kt src op param args))
(add-uses args uses))
(_ uses))) (_ uses)))
conts conts
empty-intset))) empty-intset)))
@ -117,8 +117,9 @@ conts."
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause)) (($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0)) (($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt)) (($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k src exp)) (($ $kargs _ _ ($ $continue k _ ($ $prompt _ _ h))) (ref2 k h))
(ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) (($ $kargs _ _ ($ $continue k)) (ref1 k))
(($ $kargs _ _ ($ $branch kf kt)) (ref2 kf kt))))
(let*-values (((single multiple) (values empty-intset empty-intset)) (let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intset-fold add-ref body single multiple))) ((single multiple) (intset-fold add-ref body single multiple)))
(intset-subtract (persistent-intset single) (intset-subtract (persistent-intset single)
@ -226,19 +227,14 @@ proc argument. For recursive calls, use the appropriate 'self'
variable, if possible. Also rewrite uses of the non-well-known but variable, if possible. Also rewrite uses of the non-well-known but
shared closures to use the appropriate 'self' variable, if possible." shared closures to use the appropriate 'self' variable, if possible."
;; env := var -> (var . label) ;; env := var -> (var . label)
(define (rewrite-fun kfun cps env) (define (visit-fun kfun cps env)
(define (subst var) (define (subst var)
(match (intmap-ref env var (lambda (_) #f)) (match (intmap-ref env var (lambda (_) #f))
(#f var) (#f var)
((var . label) var))) ((var . label) var)))
(define (rename-exp label cps names vars k src exp) (define (visit-exp exp)
(intmap-replace! (rewrite-exp exp
cps label
(build-cont
($kargs names vars
($continue k src
,(rewrite-exp exp
((or ($ $const) ($ $prim)) ,exp) ((or ($ $const) ($ $prim)) ,exp)
(($ $call proc args) (($ $call proc args)
,(let ((args (map subst args))) ,(let ((args (map subst args)))
@ -247,14 +243,19 @@ shared closures to use the appropriate 'self' variable, if possible."
((closure . label) ($callk label closure ,args))))) ((closure . label) ($callk label closure ,args)))))
(($ $primcall name param args) (($ $primcall name param args)
($primcall name param ,(map subst args))) ($primcall name param ,(map subst args)))
(($ $branch k ($ $primcall name param args))
($branch k ($primcall name param ,(map subst args))))
(($ $values args) (($ $values args)
($values ,(map subst args))) ($values ,(map subst args)))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler)))))))) ($prompt escape? (subst tag) handler))))
(define (visit-exp label cps names vars k src exp) (define (visit-term term)
(rewrite-term term
(($ $continue k src exp)
($continue k src ,(visit-exp exp)))
(($ $branch kf kt src op param args)
($branch kf kt src op param ,(map subst args)))))
(define (visit-rec labels vars cps)
(define (compute-env label bound self rec-bound rec-labels env) (define (compute-env label bound self rec-bound rec-labels env)
(define (add-bound-var bound label env) (define (add-bound-var bound label env)
(intmap-add env bound (cons self label) (lambda (old new) new))) (intmap-add env bound (cons self label) (lambda (old new) new)))
@ -265,26 +266,27 @@ shared closures to use the appropriate 'self' variable, if possible."
;; Otherwise be sure to use "self" references in any ;; Otherwise be sure to use "self" references in any
;; closure. ;; closure.
(add-bound-var bound label env))) (add-bound-var bound label env)))
(match exp
(($ $fun label)
(rewrite-fun label cps env))
(($ $rec names vars (($ $fun labels) ...))
(fold (lambda (label var cps) (fold (lambda (label var cps)
(match (intmap-ref cps label) (match (intmap-ref cps label)
(($ $kfun src meta self) (($ $kfun src meta self)
(rewrite-fun label cps (visit-fun label cps
(compute-env label var self vars labels (compute-env label var self vars labels env)))))
env)))))
cps labels vars)) cps labels vars))
(_ (rename-exp label cps names vars k src exp))))
(define (rewrite-cont label cps) (define (visit-cont label cps)
(match (intmap-ref cps label) (match (intmap-ref cps label)
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars
(visit-exp label cps names vars k src exp)) ($ $continue k src ($ $fun label)))
(visit-fun label cps env))
(($ $kargs _ _
($ $continue k src ($ $rec names vars (($ $fun labels) ...))))
(visit-rec labels vars cps))
(($ $kargs names vars term)
(with-cps cps
(setk label ($kargs names vars ,(visit-term term)))))
(_ cps))) (_ cps)))
(intset-fold rewrite-cont (intmap-ref functions kfun) cps)) (intset-fold visit-cont (intmap-ref functions kfun) cps))
;; Initial environment is bound-var -> (shared-var . label) map for ;; Initial environment is bound-var -> (shared-var . label) map for
;; functions with shared closures. ;; functions with shared closures.
@ -299,7 +301,7 @@ shared closures to use the appropriate 'self' variable, if possible."
env)) env))
shared shared
empty-intmap))) empty-intmap)))
(persistent-intmap (rewrite-fun kfun cps env)))) (persistent-intmap (visit-fun kfun cps env))))
(define (compute-free-vars conts kfun shared) (define (compute-free-vars conts kfun shared)
"Compute a FUN-LABEL->FREE-VAR... map describing all free variable "Compute a FUN-LABEL->FREE-VAR... map describing all free variable
@ -350,9 +352,11 @@ references."
(intset-fold (intset-fold
(lambda (label defs uses) (lambda (label defs uses)
(match (intmap-ref conts label) (match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(values (values
(add-defs vars defs) (add-defs vars defs)
(match term
(($ $continue k src exp)
(match exp (match exp
((or ($ $const) ($ $prim)) uses) ((or ($ $const) ($ $prim)) uses)
(($ $fun kfun) (($ $fun kfun)
@ -369,12 +373,12 @@ references."
(add-use proc (add-uses args uses))) (add-use proc (add-uses args uses)))
(($ $callk label proc args) (($ $callk label proc args)
(add-use proc (add-uses args uses))) (add-use proc (add-uses args uses)))
(($ $branch kt ($ $primcall name param args))
(add-uses args uses))
(($ $primcall name param args) (($ $primcall name param args)
(add-uses args uses)) (add-uses args uses))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(add-use tag uses))))) (add-use tag uses))))
(($ $branch kf kt src op param args)
(add-uses args uses)))))
(($ $kfun src meta self) (($ $kfun src meta self)
(values (add-def self defs) uses)) (values (add-def self defs) uses))
(_ (values defs uses)))) (_ (values defs uses))))
@ -715,14 +719,6 @@ bound to @var{var}, and continue to @var{k}."
(build-term (build-term
($continue k src ($primcall name param args))))))) ($continue k src ($primcall name param args)))))))
(($ $continue k src ($ $branch kt ($ $primcall name param args)))
(convert-args cps args
(lambda (cps args)
(with-cps cps
(build-term
($continue k src
($branch kt ($primcall name param args))))))))
(($ $continue k src ($ $values args)) (($ $continue k src ($ $values args))
(convert-args cps args (convert-args cps args
(lambda (cps args) (lambda (cps args)
@ -736,7 +732,14 @@ bound to @var{var}, and continue to @var{k}."
(with-cps cps (with-cps cps
(build-term (build-term
($continue k src ($continue k src
($prompt escape? tag handler))))))))) ($prompt escape? tag handler)))))))
(($ $branch kf kt src op param args)
(convert-args cps args
(lambda (cps args)
(with-cps cps
(build-term
($branch kf kt src op param args))))))))
(intset-fold (lambda (label cps) (intset-fold (lambda (label cps)
(match (intmap-ref cps label (lambda (_) #f)) (match (intmap-ref cps label (lambda (_) #f))

154
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, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -435,7 +435,7 @@
((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))))) (lookup-parallel-moves label allocation)))))
(define (compile-test label exp kt kf next-label) (define (compile-test label next-label kf kt op param args)
(define (prefer-true?) (define (prefer-true?)
(if (< (max kt kf) label) (if (< (max kt kf) label)
;; Two backwards branches. Prefer ;; Two backwards branches. Prefer
@ -474,71 +474,71 @@
(define (binary-</imm op a b) (define (binary-</imm op a b)
(op asm (from-sp (slot a)) b) (op asm (from-sp (slot a)) b)
(emit-branch emit-jl emit-jnl)) (emit-branch emit-jl emit-jnl))
(match exp (match (vector op param args)
;; Immediate type tag predicates. ;; Immediate type tag predicates.
(($ $primcall 'fixnum? #f (a)) (unary emit-fixnum? a)) (#('fixnum? #f (a)) (unary emit-fixnum? a))
(($ $primcall 'heap-object? #f (a)) (unary emit-heap-object? a)) (#('heap-object? #f (a)) (unary emit-heap-object? a))
(($ $primcall 'char? #f (a)) (unary emit-char? a)) (#('char? #f (a)) (unary emit-char? a))
(($ $primcall 'eq-false? #f (a)) (unary emit-eq-false? a)) (#('eq-false? #f (a)) (unary emit-eq-false? a))
(($ $primcall 'eq-nil? #f (a)) (unary emit-eq-nil? a)) (#('eq-nil? #f (a)) (unary emit-eq-nil? a))
(($ $primcall 'eq-null? #f (a)) (unary emit-eq-null? a)) (#('eq-null? #f (a)) (unary emit-eq-null? a))
(($ $primcall 'eq-true? #f (a)) (unary emit-eq-true? a)) (#('eq-true? #f (a)) (unary emit-eq-true? a))
(($ $primcall 'unspecified? #f (a)) (unary emit-unspecified? a)) (#('unspecified? #f (a)) (unary emit-unspecified? a))
(($ $primcall 'undefined? #f (a)) (unary emit-undefined? a)) (#('undefined? #f (a)) (unary emit-undefined? a))
(($ $primcall 'eof-object? #f (a)) (unary emit-eof-object? a)) (#('eof-object? #f (a)) (unary emit-eof-object? a))
(($ $primcall 'null? #f (a)) (unary emit-null? a)) (#('null? #f (a)) (unary emit-null? a))
(($ $primcall 'false? #f (a)) (unary emit-false? a)) (#('false? #f (a)) (unary emit-false? a))
(($ $primcall 'nil? #f (a)) (unary emit-nil? a)) (#('nil? #f (a)) (unary emit-nil? a))
;; Heap type tag predicates. ;; Heap type tag predicates.
(($ $primcall 'pair? #f (a)) (unary emit-pair? a)) (#('pair? #f (a)) (unary emit-pair? a))
(($ $primcall 'struct? #f (a)) (unary emit-struct? a)) (#('struct? #f (a)) (unary emit-struct? a))
(($ $primcall 'symbol? #f (a)) (unary emit-symbol? a)) (#('symbol? #f (a)) (unary emit-symbol? a))
(($ $primcall 'variable? #f (a)) (unary emit-variable? a)) (#('variable? #f (a)) (unary emit-variable? a))
(($ $primcall 'vector? #f (a)) (unary emit-vector? a)) (#('vector? #f (a)) (unary emit-vector? a))
(($ $primcall 'string? #f (a)) (unary emit-string? a)) (#('string? #f (a)) (unary emit-string? a))
(($ $primcall 'heap-number? #f (a)) (unary emit-heap-number? a)) (#('heap-number? #f (a)) (unary emit-heap-number? a))
(($ $primcall 'hash-table? #f (a)) (unary emit-hash-table? a)) (#('hash-table? #f (a)) (unary emit-hash-table? a))
(($ $primcall 'pointer? #f (a)) (unary emit-pointer? a)) (#('pointer? #f (a)) (unary emit-pointer? a))
(($ $primcall 'fluid? #f (a)) (unary emit-fluid? a)) (#('fluid? #f (a)) (unary emit-fluid? a))
(($ $primcall 'stringbuf? #f (a)) (unary emit-stringbuf? a)) (#('stringbuf? #f (a)) (unary emit-stringbuf? a))
(($ $primcall 'dynamic-state? #f (a)) (unary emit-dynamic-state? a)) (#('dynamic-state? #f (a)) (unary emit-dynamic-state? a))
(($ $primcall 'frame? #f (a)) (unary emit-frame? a)) (#('frame? #f (a)) (unary emit-frame? a))
(($ $primcall 'keyword? #f (a)) (unary emit-keyword? a)) (#('keyword? #f (a)) (unary emit-keyword? a))
(($ $primcall 'atomic-box? #f (a)) (unary emit-atomic-box? a)) (#('atomic-box? #f (a)) (unary emit-atomic-box? a))
(($ $primcall 'syntax? #f (a)) (unary emit-syntax? a)) (#('syntax? #f (a)) (unary emit-syntax? a))
(($ $primcall 'program? #f (a)) (unary emit-program? a)) (#('program? #f (a)) (unary emit-program? a))
(($ $primcall 'vm-continuation? #f (a)) (unary emit-vm-continuation? a)) (#('vm-continuation? #f (a)) (unary emit-vm-continuation? a))
(($ $primcall 'bytevector? #f (a)) (unary emit-bytevector? a)) (#('bytevector? #f (a)) (unary emit-bytevector? a))
(($ $primcall 'weak-set? #f (a)) (unary emit-weak-set? a)) (#('weak-set? #f (a)) (unary emit-weak-set? a))
(($ $primcall 'weak-table? #f (a)) (unary emit-weak-table? a)) (#('weak-table? #f (a)) (unary emit-weak-table? a))
(($ $primcall 'array? #f (a)) (unary emit-array? a)) (#('array? #f (a)) (unary emit-array? a))
(($ $primcall 'bitvector? #f (a)) (unary emit-bitvector? a)) (#('bitvector? #f (a)) (unary emit-bitvector? a))
(($ $primcall 'smob? #f (a)) (unary emit-smob? a)) (#('smob? #f (a)) (unary emit-smob? a))
(($ $primcall 'port? #f (a)) (unary emit-port? a)) (#('port? #f (a)) (unary emit-port? a))
(($ $primcall 'bignum? #f (a)) (unary emit-bignum? a)) (#('bignum? #f (a)) (unary emit-bignum? a))
(($ $primcall 'flonum? #f (a)) (unary emit-flonum? a)) (#('flonum? #f (a)) (unary emit-flonum? a))
(($ $primcall 'compnum? #f (a)) (unary emit-compnum? a)) (#('compnum? #f (a)) (unary emit-compnum? a))
(($ $primcall 'fracnum? #f (a)) (unary emit-fracnum? a)) (#('fracnum? #f (a)) (unary emit-fracnum? a))
;; Binary predicates. ;; Binary predicates.
(($ $primcall 'eq? #f (a b)) (binary-test emit-eq? a b)) (#('eq? #f (a b)) (binary-test emit-eq? a b))
(($ $primcall 'heap-numbers-equal? #f (a b)) (#('heap-numbers-equal? #f (a b))
(binary-test emit-heap-numbers-equal? a b)) (binary-test emit-heap-numbers-equal? a b))
(($ $primcall '< #f (a b)) (binary-< emit-<? a b)) (#('< #f (a b)) (binary-< emit-<? a b))
(($ $primcall '<= #f (a b)) (binary-<= emit-<? a b)) (#('<= #f (a b)) (binary-<= emit-<? a b))
(($ $primcall '= #f (a b)) (binary-test emit-=? a b)) (#('= #f (a b)) (binary-test emit-=? a b))
(($ $primcall 'u64-< #f (a b)) (binary-< emit-u64<? a b)) (#('u64-< #f (a b)) (binary-< emit-u64<? a b))
(($ $primcall 'u64-imm-< b (a)) (binary-</imm emit-u64-imm<? a b)) (#('u64-imm-< b (a)) (binary-</imm emit-u64-imm<? a b))
(($ $primcall 'imm-u64-< b (a)) (binary-</imm emit-imm-u64<? a b)) (#('imm-u64-< b (a)) (binary-</imm emit-imm-u64<? a b))
(($ $primcall 'u64-= #f (a b)) (binary-test emit-u64=? a b)) (#('u64-= #f (a b)) (binary-test emit-u64=? a b))
(($ $primcall 'u64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b)) (#('u64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
(($ $primcall 's64-= #f (a b)) (binary-test emit-u64=? a b)) (#('s64-= #f (a b)) (binary-test emit-u64=? a b))
(($ $primcall 's64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b)) (#('s64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
(($ $primcall 's64-< #f (a b)) (binary-< emit-s64<? a b)) (#('s64-< #f (a b)) (binary-< emit-s64<? a b))
(($ $primcall 's64-imm-< b (a)) (binary-</imm emit-s64-imm<? a b)) (#('s64-imm-< b (a)) (binary-</imm emit-s64-imm<? a b))
(($ $primcall 'imm-s64-< b (a)) (binary-</imm emit-imm-s64<? a b)) (#('imm-s64-< b (a)) (binary-</imm emit-imm-s64<? a b))
(($ $primcall 'f64-< #f (a b)) (binary-< emit-f64<? a b)) (#('f64-< #f (a b)) (binary-< emit-f64<? a b))
(($ $primcall 'f64-<= #f (a b)) (binary-<= emit-f64<? a b)) (#('f64-<= #f (a b)) (binary-<= emit-f64<? a b))
(($ $primcall 'f64-= #f (a b)) (binary-test emit-f64=? a b)))) (#('f64-= #f (a b)) (binary-test emit-f64=? a b))))
(define (compile-trunc label k exp nreq rest-var) (define (compile-trunc label k exp nreq rest-var)
(define (do-call proc args emit-call) (define (do-call proc args emit-call)
@ -599,13 +599,8 @@
(compile-value label exp dst))) (compile-value label exp dst)))
(maybe-emit-jump)) (maybe-emit-jump))
(($ $kargs () ()) (($ $kargs () ())
(match exp
(($ $branch kt exp)
(compile-test label exp (forward-label kt) forwarded-k
(skip-elided-conts (1+ label))))
(_
(compile-effect label exp k) (compile-effect label exp k)
(maybe-emit-jump)))) (maybe-emit-jump))
(($ $kargs names syms) (($ $kargs names syms)
(compile-values label exp syms) (compile-values label exp syms)
(maybe-emit-jump)) (maybe-emit-jump))
@ -620,6 +615,20 @@
(unless fallthrough? (unless fallthrough?
(emit-j asm kargs))))))) (emit-j asm kargs)))))))
(define (compile-term label term)
(match term
(($ $continue k src exp)
(when src
(emit-source asm src))
(unless (elide-cont? label)
(compile-expression label k exp)))
(($ $branch kf kt src op param args)
(when src
(emit-source asm src))
(compile-test label (skip-elided-conts (1+ label))
(forward-label kf) (forward-label kt)
op param args))))
(define (compile-cont label cont) (define (compile-cont label cont)
(match cont (match cont
(($ $kfun src meta self tail clause) (($ $kfun src meta self tail clause)
@ -646,7 +655,7 @@
(let ((body (forward-label body))) (let ((body (forward-label body)))
(unless (= body (skip-elided-conts (1+ label))) (unless (= body (skip-elided-conts (1+ label)))
(emit-j asm body))))) (emit-j asm body)))))
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(emit-label asm label) (emit-label asm label)
(for-each (lambda (name var) (for-each (lambda (name var)
(let ((slot (maybe-slot var))) (let ((slot (maybe-slot var)))
@ -654,10 +663,7 @@
(let ((repr (lookup-representation var allocation))) (let ((repr (lookup-representation var allocation)))
(emit-definition asm name slot repr))))) (emit-definition asm name slot repr)))))
names vars) names vars)
(when src (compile-term label term))
(emit-source asm src))
(unless (elide-cont? label)
(compile-expression label k exp)))
(($ $kreceive arity kargs) (($ $kreceive arity kargs)
(emit-label asm label)) (emit-label asm label))
(($ $ktail) (($ $ktail)

22
module/language/cps/contification.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -60,8 +60,12 @@ predecessor."
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause)) (($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0)) (($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt)) (($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $branch kf kt))
(ref2 kf kt))
(($ $kargs names syms ($ $continue k src exp)) (($ $kargs names syms ($ $continue k src exp))
(ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) (match exp
(($ $prompt escape-only? tag handler) (ref2 k handler))
(_ (ref1 k))))))
(let*-values (((single multiple) (values empty-intset empty-intset)) (let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intmap-fold add-ref conts single multiple))) ((single multiple) (intmap-fold add-ref conts single multiple)))
(intset-subtract (persistent-intset single) (intset-subtract (persistent-intset single)
@ -187,12 +191,12 @@ $call, and are always called with a compatible arity."
(restrict-arity functions proc (length args)))) (restrict-arity functions proc (length args))))
(($ $callk k proc args) (($ $callk k proc args)
(exclude-vars functions (cons proc args))) (exclude-vars functions (cons proc args)))
(($ $branch kt ($ $primcall name param args))
(exclude-vars functions args))
(($ $primcall name param args) (($ $primcall name param args)
(exclude-vars functions args)) (exclude-vars functions args))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(exclude-var functions tag)))) (exclude-var functions tag))))
(($ $kargs _ _ ($ $branch kf kt src op param args))
(exclude-vars functions args))
(_ functions))) (_ functions)))
(intmap-fold visit-cont conts functions))) (intmap-fold visit-cont conts functions)))
@ -451,6 +455,12 @@ function set."
(((names vars funs) ...) (((names vars funs) ...)
(continue cps k src (build-exp ($rec names vars funs)))))) (continue cps k src (build-exp ($rec names vars funs))))))
(_ (continue cps k src exp)))) (_ (continue cps k src exp))))
(define (visit-term cps term)
(match term
(($ $continue k src exp)
(visit-exp cps k src exp))
(($ $branch)
(with-cps cps term))))
;; Renumbering is not strictly necessary but some passes may not be ;; Renumbering is not strictly necessary but some passes may not be
;; equipped to deal with stale $kfun nodes whose bodies have been ;; equipped to deal with stale $kfun nodes whose bodies have been
@ -460,13 +470,13 @@ function set."
(intmap-fold (intmap-fold
(lambda (label cont out) (lambda (label cont out)
(match cont (match cont
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
;; Remove bindings for functions that have been contified. ;; Remove bindings for functions that have been contified.
(match (filter (match-lambda ((name var) (not (call-subst var)))) (match (filter (match-lambda ((name var) (not (call-subst var))))
(map list names vars)) (map list names vars))
(((names vars) ...) (((names vars) ...)
(with-cps out (with-cps out
(let$ term (visit-exp k src exp)) (let$ term (visit-term term))
(setk label ($kargs names vars ,term)))))) (setk label ($kargs names vars ,term))))))
(_ out))) (_ out)))
conts conts

97
module/language/cps/cse.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -114,11 +114,13 @@ false. It could be that both true and false proofs are available."
(values (append changed0 changed1) boolv))) (values (append changed0 changed1) boolv)))
(match (intmap-ref conts label) (match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(match term
(($ $continue k src exp)
(match exp (match exp
(($ $branch kt) (propagate-branch k kt))
(($ $prompt escape? tag handler) (propagate2 k handler)) (($ $prompt escape? tag handler) (propagate2 k handler))
(_ (propagate1 k)))) (_ (propagate1 k))))
(($ $branch kf kt) (propagate-branch kf kt))))
(($ $kreceive arity k) (($ $kreceive arity k)
(propagate1 k)) (propagate1 k))
(($ $kfun src meta self tail clause) (($ $kfun src meta self tail clause)
@ -160,10 +162,14 @@ false. It could be that both true and false proofs are available."
(($ $kargs names vars) vars))) (($ $kargs names vars) vars)))
(($ $ktail) (($ $ktail)
'()) '())
(($ $kargs names vars ($ $continue k)) (($ $kargs names vars term)
(match term
(($ $continue k)
(match (intmap-ref conts k) (match (intmap-ref conts k)
(($ $kargs names vars) vars) (($ $kargs names vars) vars)
(_ #f))))) (_ #f)))
(($ $branch)
'())))))
(compute-function-body conts kfun))) (compute-function-body conts kfun)))
(define (compute-singly-referenced succs) (define (compute-singly-referenced succs)
@ -199,7 +205,9 @@ false. It could be that both true and false proofs are available."
(() '()) (() '())
((var . vars) (cons (subst-var var-substs var) (lp vars)))))) ((var . vars) (cons (subst-var var-substs var) (lp vars))))))
(define (compute-exp-key var-substs exp) (define (compute-term-key var-substs term)
(match term
(($ $continue k src exp)
(match exp (match exp
(($ $const val) (cons 'const val)) (($ $const val) (cons 'const val))
(($ $prim name) (cons 'prim name)) (($ $prim name) (cons 'prim name))
@ -210,12 +218,12 @@ false. It could be that both true and false proofs are available."
(($ $callk k proc args) #f) (($ $callk k proc args) #f)
(($ $primcall name param args) (($ $primcall name param args)
(cons* name param (subst-vars var-substs args))) (cons* name param (subst-vars var-substs args)))
(($ $branch _ ($ $primcall name param args))
(cons* name param (subst-vars var-substs args)))
(($ $values args) #f) (($ $values args) #f)
(($ $prompt escape? tag handler) #f))) (($ $prompt escape? tag handler) #f)))
(($ $branch kf kt src op param args)
(cons* op param (subst-vars var-substs args)))))
(define (add-auxiliary-definitions! label var-substs exp-key) (define (add-auxiliary-definitions! label var-substs term-key)
(let ((defs (and=> (intmap-ref defs label) (let ((defs (and=> (intmap-ref defs label)
(lambda (defs) (subst-vars var-substs defs))))) (lambda (defs) (subst-vars var-substs defs)))))
(define (add-def! aux-key var) (define (add-def! aux-key var)
@ -229,7 +237,7 @@ false. It could be that both true and false proofs are available."
((add-definitions ((add-definitions
((def <- op arg ...) (aux <- op* arg* ...) ...) ((def <- op arg ...) (aux <- op* arg* ...) ...)
. clauses) . clauses)
(match exp-key (match term-key
(('op arg ...) (('op arg ...)
(match defs (match defs
((def) (add-def! (list 'op* arg* ...) aux) ...))) ((def) (add-def! (list 'op* arg* ...) aux) ...)))
@ -237,7 +245,7 @@ false. It could be that both true and false proofs are available."
((add-definitions ((add-definitions
((op arg ...) (aux <- op* arg* ...) ...) ((op arg ...) (aux <- op* arg* ...) ...)
. clauses) . clauses)
(match exp-key (match term-key
(('op arg ...) (('op arg ...)
(add-def! (list 'op* arg* ...) aux) ...) (add-def! (list 'op* arg* ...) aux) ...)
(_ (add-definitions . clauses)))))) (_ (add-definitions . clauses))))))
@ -282,12 +290,18 @@ false. It could be that both true and false proofs are available."
((u <- s64->u64 #f s) (s <- u64->s64 #f u))))) ((u <- s64->u64 #f s) (s <- u64->s64 #f u)))))
(define (visit-label label equiv-labels var-substs) (define (visit-label label equiv-labels var-substs)
(define (term-defs term)
(match term
(($ $continue k)
(and (intset-ref singly-referenced k)
(intmap-ref defs label)))
(($ $branch) '())))
(match (intmap-ref conts label) (match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(match (compute-exp-key var-substs exp) (match (compute-term-key var-substs term)
(#f (values equiv-labels var-substs)) (#f (values equiv-labels var-substs))
(exp-key (term-key
(let* ((equiv (hash-ref equiv-set exp-key '())) (let* ((equiv (hash-ref equiv-set term-key '()))
(fx (intmap-ref effects label)) (fx (intmap-ref effects label))
(avail (intmap-ref avail label))) (avail (intmap-ref avail label)))
(define (finish equiv-labels var-substs) (define (finish equiv-labels var-substs)
@ -296,7 +310,7 @@ false. It could be that both true and false proofs are available."
;; define those. Do so after finding equivalent ;; define those. Do so after finding equivalent
;; expressions, so that we can take advantage of ;; expressions, so that we can take advantage of
;; subst'd output vars. ;; subst'd output vars.
(add-auxiliary-definitions! label var-substs exp-key) (add-auxiliary-definitions! label var-substs term-key)
(values equiv-labels var-substs)) (values equiv-labels var-substs))
(let lp ((candidates equiv)) (let lp ((candidates equiv))
(match candidates (match candidates
@ -310,10 +324,9 @@ false. It could be that both true and false proofs are available."
;; allocation case). ;; allocation case).
(when (and (not (causes-effect? fx &allocation)) (when (and (not (causes-effect? fx &allocation))
(not (effect-clobbers? fx (&read-object &fluid)))) (not (effect-clobbers? fx (&read-object &fluid))))
(let ((defs (and (intset-ref singly-referenced k) (let ((defs (term-defs term)))
(intmap-ref defs label))))
(when defs (when defs
(hash-set! equiv-set exp-key (hash-set! equiv-set term-key
(acons label defs equiv))))) (acons label defs equiv)))))
(finish equiv-labels var-substs)) (finish equiv-labels var-substs))
(((and head (candidate . vars)) . candidates) (((and head (candidate . vars)) . candidates)
@ -327,8 +340,7 @@ false. It could be that both true and false proofs are available."
;; we provide the definitions for the successor, mark ;; we provide the definitions for the successor, mark
;; the vars for substitution. ;; the vars for substitution.
(finish (intmap-add equiv-labels label head) (finish (intmap-add equiv-labels label head)
(let ((defs (and (intset-ref singly-referenced k) (let ((defs (term-defs term)))
(intmap-ref defs label))))
(if defs (if defs
(fold (lambda (def var var-substs) (fold (lambda (def var var-substs)
(intmap-add var-substs def var)) (intmap-add var-substs def var))
@ -364,44 +376,41 @@ false. It could be that both true and false proofs are available."
($callk k (subst-var proc) ,(map subst-var args))) ($callk k (subst-var proc) ,(map subst-var args)))
(($ $primcall name param args) (($ $primcall name param args)
($primcall name param ,(map subst-var args))) ($primcall name param ,(map subst-var args)))
(($ $branch k exp)
($branch k ,(visit-exp exp)))
(($ $values args) (($ $values args)
($values ,(map subst-var args))) ($values ,(map subst-var args)))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
($prompt escape? (subst-var tag) handler)))) ($prompt escape? (subst-var tag) handler))))
(intmap-map (define (visit-term label term)
(lambda (label cont) (match term
(match cont (($ $branch kf kt src op param args)
(($ $kargs names vars ($ $continue k src exp)) (match (intmap-ref equiv-labels label (lambda (_) #f))
(build-cont ((equiv) ; A branch defines no values.
($kargs names vars
,(match (intmap-ref equiv-labels label (lambda (_) #f))
((equiv . vars)
(match exp
(($ $branch kt exp)
(let* ((bool (intmap-ref truthy-labels label)) (let* ((bool (intmap-ref truthy-labels label))
(t (intset-ref bool (true-idx equiv))) (t (intset-ref bool (true-idx equiv)))
(f (intset-ref bool (false-idx equiv)))) (f (intset-ref bool (false-idx equiv))))
(if (eqv? t f) (if (eqv? t f)
(build-term (build-term
($continue k src ($branch kf kt src op param ,(map subst-var args)))
($branch kt ,(visit-exp exp))))
(build-term (build-term
($continue (if t kt k) src ($values ())))))) ($continue (if t kt kf) src ($values ()))))))
(_ (#f
;; For better or for worse, we only replace primcalls
;; if they have an associated VM op, which allows
;; them to continue to $kargs and thus we know their
;; defs and can use a $values expression instead of a
;; values primcall.
(build-term (build-term
($continue k src ($values vars)))))) ($branch kf kt src op param ,(map subst-var args))))))
(($ $continue k src exp)
(match (intmap-ref equiv-labels label (lambda (_) #f))
((equiv . vars)
(build-term ($continue k src ($values vars))))
(#f (#f
(build-term (build-term
($continue k src ,(visit-exp exp)))))))) ($continue k src ,(visit-exp exp))))))))
(_ cont)))
(intmap-map
(lambda (label cont)
(rewrite-cont cont
(($ $kargs names vars term)
($kargs names vars ,(visit-term label term)))
(_ ,cont)))
conts)) conts))
(define (eliminate-common-subexpressions conts) (define (eliminate-common-subexpressions conts)

61
module/language/cps/dce.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -80,6 +80,10 @@ sites."
(causes-effect? fx &allocation)) (causes-effect? fx &allocation))
(values (intset-add! known k) unknown) (values (intset-add! known k) unknown)
(values known (intset-add! unknown k))))) (values known (intset-add! unknown k)))))
(($ $kargs _ _ ($ $branch))
;; Branches pass no values to their
;; continuations.
(values known unknown))
(($ $kreceive arity kargs) (($ $kreceive arity kargs)
(values known (intset-add! unknown kargs))) (values known (intset-add! unknown kargs)))
(($ $kfun src meta self tail clause) (($ $kfun src meta self tail clause)
@ -151,8 +155,6 @@ sites."
(adjoin-vars args (adjoin-var proc live-vars)))) (adjoin-vars args (adjoin-var proc live-vars))))
(($ $primcall name param args) (($ $primcall name param args)
(values live-labels (adjoin-vars args live-vars))) (values live-labels (adjoin-vars args live-vars)))
(($ $branch k ($ $primcall name param args))
(values live-labels (adjoin-vars args live-vars)))
(($ $values args) (($ $values args)
(values live-labels (values live-labels
(match (cont-defs k) (match (cont-defs k)
@ -164,17 +166,6 @@ sites."
live-vars args defs))))))) live-vars args defs)))))))
(define (visit-exp label k exp live-labels live-vars) (define (visit-exp label k exp live-labels live-vars)
(define (next-live-term k)
;; FIXME: For a chain of dead branches, this is quadratic.
(let lp ((seen empty-intset) (k k))
(cond
((intset-ref live-labels k) k)
((intset-ref seen k) k)
(else
(match (intmap-ref conts k)
(($ $kargs _ _ ($ $continue k*))
(lp (intset-add seen k) k*))
(_ k))))))
(cond (cond
((intset-ref live-labels label) ((intset-ref live-labels label)
;; Expression live already. ;; Expression live already.
@ -192,12 +183,6 @@ sites."
;; Does it cause a type check, but we weren't able to prove ;; Does it cause a type check, but we weren't able to prove
;; that the types check? ;; that the types check?
(causes-effect? fx &type-check) (causes-effect? fx &type-check)
;; We only remove branches if both continuations are the
;; same.
(match exp
(($ $branch kt)
(not (eqv? (next-live-term k) (next-live-term kt))))
(_ #f))
;; We might have a setter. If the object being assigned to ;; We might have a setter. If the object being assigned to
;; is live or was not created by us, then this expression is ;; is live or was not created by us, then this expression is
;; live. Otherwise the value is still dead. ;; live. Otherwise the value is still dead.
@ -219,6 +204,32 @@ sites."
;; Still dead. ;; Still dead.
(values live-labels live-vars)))) (values live-labels live-vars))))
(define (visit-branch label kf kt args live-labels live-vars)
(define (next-live-term k)
;; FIXME: For a chain of dead branches, this is quadratic.
(let lp ((seen empty-intset) (k k))
(cond
((intset-ref live-labels k) k)
((intset-ref seen k) k)
(else
(match (intmap-ref conts k)
(($ $kargs _ _ ($ $continue k*))
(lp (intset-add seen k) k*))
(_ k))))))
(cond
((intset-ref live-labels label)
;; Branch live already.
(values live-labels (adjoin-vars args live-vars)))
((or (causes-effect? (intmap-ref effects label) &type-check)
(not (eqv? (next-live-term kf) (next-live-term kt))))
;; The branch is live if its continuations are not the same, or
;; if the branch itself causes type checks.
(values (intset-add live-labels label)
(adjoin-vars args live-vars)))
(else
;; Still dead.
(values live-labels live-vars))))
(define (visit-fun label live-labels live-vars) (define (visit-fun label live-labels live-vars)
;; Visit uses before definitions. ;; Visit uses before definitions.
(postorder-fold-local-conts2 (postorder-fold-local-conts2
@ -226,6 +237,8 @@ sites."
(match cont (match cont
(($ $kargs _ _ ($ $continue k src exp)) (($ $kargs _ _ ($ $continue k src exp))
(visit-exp label k exp live-labels live-vars)) (visit-exp label k exp live-labels live-vars))
(($ $kargs _ _ ($ $branch kf kt src op param args))
(visit-branch label kf kt args live-labels live-vars))
(($ $kreceive arity kargs) (($ $kreceive arity kargs)
(values live-labels live-vars)) (values live-labels live-vars))
(($ $kclause arity kargs kalt) (($ $kclause arity kargs kalt)
@ -327,7 +340,13 @@ sites."
(values cps term))))) (values cps term)))))
(values cps (values cps
(build-term (build-term
($continue k src ($values ())))))))) ($continue k src ($values ()))))))
(($ $branch kf kt src op param args)
(if (label-live? label)
(values cps term)
;; Dead branches continue to the same continuation
;; (eventually).
(values cps (build-term ($continue kf src ($values ()))))))))
(define (visit-cont label cont cps) (define (visit-cont label cont cps)
(match cont (match cont
(($ $kargs names vars term) (($ $kargs names vars term)

120
module/language/cps/devirtualize-integers.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2017 Free Software Foundation, Inc. ;; Copyright (C) 2017, 2018 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
@ -59,7 +59,9 @@
(intmap-fold (intmap-fold
(lambda (label cont use-counts) (lambda (label cont use-counts)
(match cont (match cont
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(match term
(($ $continue k src exp)
(match exp (match exp
((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec)) ((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec))
use-counts) use-counts)
@ -69,12 +71,12 @@
(add-uses (add-use use-counts proc) args)) (add-uses (add-use use-counts proc) args))
(($ $callk kfun proc args) (($ $callk kfun proc args)
(add-uses (add-use use-counts proc) args)) (add-uses (add-use use-counts proc) args))
(($ $branch kt ($ $primcall name param args))
(add-uses use-counts args))
(($ $primcall name param args) (($ $primcall name param args)
(add-uses use-counts args)) (add-uses use-counts args))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(add-use use-counts tag)))) (add-use use-counts tag))))
(($ $branch kf kt src op param args)
(add-uses use-counts args))))
(_ use-counts))) (_ use-counts)))
cps cps
(transient-intmap)))) (transient-intmap))))
@ -124,7 +126,7 @@ the trace should be referenced outside of it."
;; graph to get to $kreceive etc, so we can stop with these two ;; graph to get to $kreceive etc, so we can stop with these two
;; continuation kinds. ;; continuation kinds.
(($ $ktail) (fail)) (($ $ktail) (fail))
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(let* ((vars-of-interest (let* ((vars-of-interest
(if defs-of-interest? (if defs-of-interest?
(fold1 (lambda (var set) (intset-add set var)) (fold1 (lambda (var set) (intset-add set var))
@ -134,7 +136,8 @@ the trace should be referenced outside of it."
(fresh-vars (fold (lambda (var fresh-vars) (fresh-vars (fold (lambda (var fresh-vars)
(intmap-add fresh-vars var (fresh-var))) (intmap-add fresh-vars var (fresh-var)))
fresh-vars vars)) fresh-vars vars))
(vars (map (lambda (var) (intmap-ref fresh-vars var)) vars))) (peeled-vars (map (lambda (var) (intmap-ref fresh-vars var))
vars)))
(define (rename-uses args) (define (rename-uses args)
(map (lambda (arg) (intmap-ref fresh-vars arg (lambda (arg) arg))) (map (lambda (arg) (intmap-ref fresh-vars arg (lambda (arg) arg)))
args)) args))
@ -142,10 +145,10 @@ the trace should be referenced outside of it."
(or-map (lambda (arg) (intset-ref vars-of-interest arg)) (or-map (lambda (arg) (intset-ref vars-of-interest arg))
args)) args))
(define (continue k live-vars defs-of-interest? can-terminate-trace? (define (continue k live-vars defs-of-interest? can-terminate-trace?
exp) make-term)
(define (stitch cps k) (define (stitch cps k)
(with-cps cps (with-cps cps
(letk label* ($kargs names vars ($continue k src ,exp))) (letk label* ($kargs names peeled-vars ,(make-term k)))
label*)) label*))
(define (terminate) (define (terminate)
(stitch cps k)) (stitch cps k))
@ -158,73 +161,71 @@ the trace should be referenced outside of it."
((and can-terminate-trace? (eq? live-vars empty-intmap)) ((and can-terminate-trace? (eq? live-vars empty-intmap))
(terminate)) (terminate))
(else (fail)))))))) (else (fail))))))))
(match term
(($ $branch kf kt src op param args)
;; kt or k is kf; var of interest is in args
(let* ((live-vars (subtract-uses live-vars args))
(uses-of-interest? (any-use-of-interest? args))
(defs-of-interest? #f) ;; Branches don't define values.
(can-terminate-trace? uses-of-interest?)
(peeled-args (rename-uses args)))
(cond
((not (any-use-of-interest? args))
(fail))
((bailout? kt)
(continue kf live-vars defs-of-interest? can-terminate-trace?
(lambda (kf)
(build-term
($branch kf kt src op param peeled-args)))))
((bailout? kf)
(continue kt live-vars defs-of-interest? can-terminate-trace?
(lambda (kt)
(build-term
($branch kf kt src op param peeled-args)))))
(else
(with-cps cps
(letk label*
($kargs names peeled-vars
($branch kf kt src op param peeled-args)))
label*)))))
(($ $continue k src exp)
(match exp (match exp
(($ $const) (($ $const)
;; fine. ;; fine.
(continue k live-vars #f #f exp)) (continue k live-vars #f #f
(lambda (k)
(build-term ($continue k src ,exp)))))
(($ $values args) (($ $values args)
(let ((live-vars (subtract-uses live-vars args))) (let ((uses-of-interest? (any-use-of-interest? args))
(live-vars (subtract-uses live-vars args))
(peeled-args (rename-uses args)))
(continue k live-vars (continue k live-vars
(any-use-of-interest? args) #f uses-of-interest? #f
(build-exp ($values ,(rename-uses args)))))) (lambda (k)
(build-term
($continue k src ($values peeled-args)))))))
(($ $primcall name param args) (($ $primcall name param args)
;; exp is effect-free or var of interest in args ;; exp is effect-free or var of interest in args
(let* ((fx (expression-effects exp)) (let* ((fx (expression-effects exp))
(uses-of-interest? (any-use-of-interest? args)) (uses-of-interest? (any-use-of-interest? args))
(live-vars (subtract-uses live-vars args))) (live-vars (subtract-uses live-vars args))
(peeled-args (rename-uses args)))
;; If the primcall uses a value of interest, ;; If the primcall uses a value of interest,
;; consider it for peeling even if it would cause a ;; consider it for peeling even if it would cause a
;; type check; perhaps the peeling causes the type ;; type check; perhaps the peeling causes the type
;; check to go away. ;; check to go away.
(if (or (eqv? fx &no-effects) (if (or (eqv? fx &no-effects)
(and uses-of-interest? (eqv? fx &type-check))) (and uses-of-interest? (eqv? fx &type-check)))
(continue k (subtract-uses live-vars args) (continue k live-vars
;; Primcalls that use values of interest ;; Primcalls that use values of interest
;; define values of interest. ;; define values of interest.
uses-of-interest? #t uses-of-interest? #t
(build-exp (lambda (k)
($primcall name param ,(rename-uses args)))) (build-term
($continue k src
($primcall name param ,peeled-args)))))
(fail)))) (fail))))
(($ $branch kt ($ $primcall name param args)) (_ (fail))))))))))
;; kt or k is kf; var of interest is in args
(let* ((live-vars (subtract-uses live-vars args))
(uses-of-interest? (any-use-of-interest? args))
(defs-of-interest? #f) ;; Branches don't define values.
(can-terminate-trace? uses-of-interest?)
(exp (build-exp
($primcall name param ,(rename-uses args)))))
(cond
((not (any-use-of-interest? args))
(fail))
((bailout? kt)
(continue k live-vars defs-of-interest? can-terminate-trace?
(build-exp ($branch kt ,exp))))
((bailout? k)
(let ()
(define (stitch cps kt)
(with-cps cps
(letk label*
($kargs names vars
($continue k src ($branch kt ,exp))))
label*))
(define (terminate)
(stitch cps kt))
(with-cps cps
(let$ kt* (peel-cont kt live-vars fresh-vars
vars-of-interest defs-of-interest?))
($ ((lambda (cps)
(cond
(kt* (stitch cps kt*))
((and can-terminate-trace? (eq? live-vars empty-intmap))
(terminate))
(else (fail)))))))))
(else
(with-cps cps
(letk label*
($kargs names vars
($continue k src ($branch kt ,exp))))
label*)))))
(_ (fail))))))))
(define (peel-traces-in-function cps body use-counts) (define (peel-traces-in-function cps body use-counts)
(intset-fold (intset-fold
@ -232,9 +233,7 @@ the trace should be referenced outside of it."
(match (intmap-ref cps label) (match (intmap-ref cps label)
;; Traces start with a fixnum? predicate. We could expand this ;; Traces start with a fixnum? predicate. We could expand this
;; in the future if we wanted to. ;; in the future if we wanted to.
(($ $kargs names vars (($ $kargs names vars ($ $branch kf kt src 'fixnum? #f (x)))
($ $continue kf src
($ $branch kt ($ $primcall 'fixnum? #f (x)))))
(with-cps cps (with-cps cps
(let$ kt (peel-trace kt x kf use-counts)) (let$ kt (peel-trace kt x kf use-counts))
($ ((lambda (cps) ($ ((lambda (cps)
@ -242,8 +241,7 @@ the trace should be referenced outside of it."
(with-cps cps (with-cps cps
(setk label (setk label
($kargs names vars ($kargs names vars
($continue kf src ($branch kf kt src 'fixnum? #f (x)))))
($branch kt ($primcall 'fixnum? #f (x)))))))
cps)))))) cps))))))
(_ cps))) (_ cps)))
body body

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

@ -1,6 +1,6 @@
;;; Effects analysis on CPS ;;; Effects analysis on CPS
;; Copyright (C) 2011-2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2011-2015, 2017, 2018 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
@ -603,8 +603,6 @@ the LABELS that are clobbered by the effects of LABEL."
&all-effects) &all-effects)
((or ($ $call) ($ $callk)) ((or ($ $call) ($ $callk))
&all-effects) &all-effects)
(($ $branch k exp)
(expression-effects exp))
(($ $primcall name param args) (($ $primcall name param args)
(primitive-effects param name args)))) (primitive-effects param name args))))
@ -614,6 +612,8 @@ the LABELS that are clobbered by the effects of LABEL."
(match cont (match cont
(($ $kargs names syms ($ $continue k src exp)) (($ $kargs names syms ($ $continue k src exp))
(expression-effects exp)) (expression-effects exp))
(($ $kargs names syms ($ $branch kf kt src op param args))
(primitive-effects param op args))
(($ $kreceive arity kargs) (($ $kreceive arity kargs)
(match arity (match arity
(($ $arity _ () #f () #f) &type-check) (($ $arity _ () #f () #f) &type-check)

20
module/language/cps/handle-interrupts.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2016, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2016, 2017, 2018 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
@ -34,12 +34,15 @@
#:export (add-handle-interrupts)) #:export (add-handle-interrupts))
(define (compute-safepoints cps) (define (compute-safepoints cps)
(define (maybe-add-safepoint label k safepoints)
"Add K to safepoints if it is a target of a backward branch."
(if (<= k label)
(intset-add! safepoints k)
safepoints))
(define (visit-cont label cont safepoints) (define (visit-cont label cont safepoints)
(match cont (match cont
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars ($ $continue k src exp))
(let ((safepoints (if (<= k label) (let ((safepoints (maybe-add-safepoint label k safepoints)))
(intset-add! safepoints k)
safepoints)))
(if (match exp (if (match exp
(($ $call) #t) (($ $call) #t)
(($ $callk) #t) (($ $callk) #t)
@ -50,18 +53,21 @@
(_ #f)) (_ #f))
(intset-add! safepoints label) (intset-add! safepoints label)
safepoints))) safepoints)))
(($ $kargs names vars ($ $branch kf kt))
(maybe-add-safepoint label kf
(maybe-add-safepoint label kt safepoints)))
(_ safepoints))) (_ safepoints)))
(persistent-intset (intmap-fold visit-cont cps empty-intset))) (persistent-intset (intmap-fold visit-cont cps empty-intset)))
(define (add-handle-interrupts cps) (define (add-handle-interrupts cps)
(define (add-safepoint label cps) (define (add-safepoint label cps)
(match (intmap-ref cps label) (match (intmap-ref cps label)
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(with-cps cps (with-cps cps
(letk k* ($kargs () () ($continue k src ,exp))) (letk k ($kargs () () ,term))
(setk label (setk label
($kargs names vars ($kargs names vars
($continue k* src ($continue k #f
($primcall 'handle-interrupts #f ())))))))) ($primcall 'handle-interrupts #f ()))))))))
(let* ((cps (renumber cps)) (let* ((cps (renumber cps))
(safepoints (compute-safepoints cps))) (safepoints (compute-safepoints cps)))

26
module/language/cps/licm.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -69,7 +69,6 @@
(match exp (match exp
((or ($ $const) ($ $prim) ($ $closure)) #t) ((or ($ $const) ($ $prim) ($ $closure)) #t)
(($ $prompt) #f) ;; ? (($ $prompt) #f) ;; ?
(($ $branch) #f)
(($ $primcall name param args) (($ $primcall name param args)
(and-map (lambda (arg) (not (intset-ref loop-vars arg))) (and-map (lambda (arg) (not (intset-ref loop-vars arg)))
args)) args))
@ -127,9 +126,11 @@
pre-header-label pre-header-cont) pre-header-label pre-header-cont)
pre-header-label))) pre-header-label)))
(match cont (match cont
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
;; If k is a loop exit, it will be nullary.
(let-values (((names vars) (filter-loop-vars names vars))) (let-values (((names vars) (filter-loop-vars names vars)))
(match term
(($ $continue k src exp)
;; If k is a loop exit, it will be nullary.
(match (intmap-ref cps k) (match (intmap-ref cps k)
(($ $kargs def-names def-vars) (($ $kargs def-names def-vars)
(cond (cond
@ -149,10 +150,8 @@
($continue k src ,exp)))) ($continue k src ,exp))))
(always-reached? (always-reached?
(and always-reached? (and always-reached?
(match exp (not (causes-effect? (intmap-ref loop-effects label)
(($ $branch) #f) &type-check)))))
(_ (not (causes-effect? (intmap-ref loop-effects label)
&type-check)))))))
(values cps cont loop-vars loop-effects (values cps cont loop-vars loop-effects
pre-header-label always-reached?))) pre-header-label always-reached?)))
((trivial-intset (intmap-ref preds k)) ((trivial-intset (intmap-ref preds k))
@ -213,7 +212,12 @@
($continue kargs src ($continue kargs src
($values fresh-vars)))))) ($values fresh-vars))))))
(values cps cont loop-vars loop-effects (values cps cont loop-vars loop-effects
pre-header-label always-reached?)))))))))) pre-header-label always-reached?)))))))))
(($ $branch)
(let* ((cont (build-cont ($kargs names vars ,term)))
(always-reached? #f))
(values cps cont loop-vars loop-effects
pre-header-label always-reached?))))))
(($ $kreceive ($ $arity req () rest) kargs) (($ $kreceive ($ $arity req () rest) kargs)
(values cps cont loop-vars loop-effects pre-header-label (values cps cont loop-vars loop-effects pre-header-label
always-reached?)))) always-reached?))))
@ -252,9 +256,9 @@
(define (rename-back-edges cont) (define (rename-back-edges cont)
(define (rename label) (if (eqv? label entry) header-label label)) (define (rename label) (if (eqv? label entry) header-label label))
(rewrite-cont cont (rewrite-cont cont
(($ $kargs names vars ($ $continue kf src ($ $branch kt exp))) (($ $kargs names vars ($ $branch kf kt src op param args))
($kargs names vars ($kargs names vars
($continue (rename kf) src ($branch (rename kt) ,exp)))) ($branch (rename kf) (rename kt) src op param args)))
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars ($ $continue k src exp))
($kargs names vars ($kargs names vars
($continue (rename k) src ,exp))) ($continue (rename k) src ,exp)))

16
module/language/cps/peel-loops.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -141,16 +141,20 @@
($call (rename-var proc) ,(map rename-var args))) ($call (rename-var proc) ,(map rename-var args)))
(($ $callk k proc args) (($ $callk k proc args)
($callk k (rename-var proc) ,(map rename-var args))) ($callk k (rename-var proc) ,(map rename-var args)))
(($ $branch kt ($ $primcall name param args))
($branch (rename-label kt) ($primcall name param ,(map rename-var args))))
(($ $primcall name param args) (($ $primcall name param args)
($primcall name param ,(map rename-var args))) ($primcall name param ,(map rename-var args)))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) (rename-label handler))))) ($prompt escape? (rename-var tag) (rename-label handler)))))
(define (rename-term term)
(rewrite-term term
(($ $continue k src exp)
($continue (rename-label k) src ,(rename-exp exp)))
(($ $branch kf kt src op param args)
($branch (rename-label kf) (rename-label kt) src
op param ,(map rename-var args)))))
(rewrite-cont cont (rewrite-cont cont
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
($kargs names (map rename-var vars) ($kargs names (map rename-var vars) ,(rename-term term)))
($continue (rename-label k) src ,(rename-exp exp))))
(($ $kreceive ($ $arity req () rest) kargs) (($ $kreceive ($ $arity req () rest) kargs)
($kreceive req rest (rename-label kargs))))) ($kreceive req rest (rename-label kargs)))))

8
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, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -384,8 +384,7 @@
($continue krecv src ($call proc args)))) ($continue krecv src ($call proc args))))
(let$ body (resolve-prim name kproc src)) (let$ body (resolve-prim name kproc src))
(setk label ($kargs names vars ,body)))))) (setk label ($kargs names vars ,body))))))
(($ $kargs names vars (($ $kargs names vars ($ $branch kf kt src name param args))
($ $continue kf src ($ $branch kt ($ $primcall name param args))))
(let () (let ()
(define (u11? val) (<= 0 val #x7ff)) (define (u11? val) (<= 0 val #x7ff))
(define (u12? val) (<= 0 val #xfff)) (define (u12? val) (<= 0 val #xfff))
@ -404,8 +403,7 @@
(letv c) (letv c)
(letk kconst (letk kconst
($kargs ('c) (c) ($kargs ('c) (c)
($continue kf src ($branch kf kt src 'op* #f (out ...))))
($branch kt ($primcall 'op* #f (out ...))))))
(setk label (setk label
($kargs names vars ($kargs names vars
($continue kconst src ($continue kconst src

25
module/language/cps/renumber.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -85,16 +85,18 @@
(call-with-values (call-with-values
(lambda () (lambda ()
(match (intmap-ref conts k) (match (intmap-ref conts k)
(($ $kargs names syms ($ $continue k src exp)) (($ $kargs names syms term)
(match term
(($ $continue k src exp)
(match exp (match exp
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(visit2 k handler order visited)) (visit2 k handler order visited))
(($ $branch kt)
(if (visit-kf-first? k kt)
(visit2 k kt order visited)
(visit2 kt k order visited)))
(_ (_
(visit k order visited)))) (visit k order visited))))
(($ $branch kf kt)
(if (visit-kf-first? kf kt)
(visit2 kf kt order visited)
(visit2 kt kf order visited)))))
(($ $kreceive arity k) (visit k order visited)) (($ $kreceive arity k) (visit k order visited))
(($ $kclause arity kbody kalt) (($ $kclause arity kbody kalt)
(if kalt (if kalt
@ -177,8 +179,6 @@
($call (rename-var proc) ,(map rename-var args))) ($call (rename-var proc) ,(map rename-var args)))
(($ $callk k proc args) (($ $callk k proc args)
($callk (rename-label k) (rename-var proc) ,(map rename-var args))) ($callk (rename-label k) (rename-var proc) ,(map rename-var args)))
(($ $branch kt exp)
($branch (rename-label kt) ,(rename-exp exp)))
(($ $primcall name param args) (($ $primcall name param args)
($primcall name param ,(map rename-var args))) ($primcall name param ,(map rename-var args)))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
@ -200,9 +200,14 @@
out out
new-k new-k
(rewrite-cont (intmap-ref conts old-k) (rewrite-cont (intmap-ref conts old-k)
(($ $kargs names syms ($ $continue k src exp)) (($ $kargs names syms term)
($kargs names (map rename-var syms) ($kargs names (map rename-var syms)
($continue (rename-label k) src ,(rename-exp exp)))) ,(rewrite-term term
(($ $continue k src exp)
($continue (rename-label k) src ,(rename-exp exp)))
(($ $branch kf kt src op param args)
($branch (rename-label kf) (rename-label kt) src
op param ,(map rename-var args))))))
(($ $kreceive ($ $arity req () rest () #f) k) (($ $kreceive ($ $arity req () rest () #f) k)
($kreceive req rest (rename-label k))) ($kreceive req rest (rename-label k)))
(($ $ktail) (($ $ktail)

115
module/language/cps/rotate-loops.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -55,6 +55,7 @@
#: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 with-cps)
#:export (rotate-loops)) #:export (rotate-loops))
(define (loop-successors scc succs) (define (loop-successors scc succs)
@ -79,7 +80,8 @@
(match (intmap-ref cps entry-label) (match (intmap-ref cps entry-label)
((and entry-cont ((and entry-cont
($ $kargs entry-names entry-vars ($ $kargs entry-names entry-vars
($ $continue entry-kf entry-src ($ $branch entry-kt entry-exp)))) ($ $branch entry-kf entry-kt entry-src
entry-op entry-param entry-args)))
(let* ((exit-if-true? (intset-ref body-labels entry-kf)) (let* ((exit-if-true? (intset-ref body-labels entry-kf))
(loop-exits (find-exits body-labels succs)) (loop-exits (find-exits body-labels succs))
(exit (if exit-if-true? entry-kt entry-kf)) (exit (if exit-if-true? entry-kt entry-kf))
@ -93,49 +95,50 @@
(map (lambda (_) (fresh-var)) entry-vars)) (map (lambda (_) (fresh-var)) entry-vars))
(define (make-trampoline k src values) (define (make-trampoline k src values)
(build-cont ($kargs () () ($continue k src ($values values))))) (build-cont ($kargs () () ($continue k src ($values values)))))
(define (replace-exit k trampoline) (define (rename-var var replacements)
(if (eqv? k exit) trampoline k)) "If VAR refers to a member of ENTRY-VARS, replace with a
(define (rename-exp exp vars) corresponding var from REPLACEMENTS; otherwise return VAR."
(define (rename-var var)
(match (list-index entry-vars var) (match (list-index entry-vars var)
(#f var) (#f var)
(idx (list-ref vars idx)))) (idx (list-ref replacements idx))))
(rewrite-exp exp (define (rename-vars vars replacements)
(map (lambda (var) (rename-var var replacements)) vars))
(define (rename-term term replacements)
(define (rename arg) (rename-var arg replacements))
(define (rename* arg) (rename-vars arg replacements))
(rewrite-term term
(($ $continue k src exp)
($continue k src
,(rewrite-exp exp
((or ($ $const) ($ $prim) ($ $closure)) ,exp) ((or ($ $const) ($ $prim) ($ $closure)) ,exp)
(($ $values args) (($ $values args)
($values ,(map rename-var args))) ($values ,(rename* args)))
(($ $call proc args) (($ $call proc args)
($call (rename-var proc) ,(map rename-var args))) ($call (rename proc) ,(rename* args)))
(($ $callk k proc args) (($ $callk k proc args)
($callk k (rename-var proc) ,(map rename-var args))) ($callk k (rename proc) ,(rename* args)))
(($ $branch kt ($ $primcall name param args))
($branch kt ($primcall name param ,(map rename-var args))))
(($ $primcall name param args) (($ $primcall name param args)
($primcall name param ,(map rename-var args))) ($primcall name param ,(rename* args)))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) handler)))) ($prompt escape? (rename tag) handler)))))
(define (attach-trampoline label src names vars args) (($ $branch kf kt src op param args)
(let* ((trampoline-out-label (fresh-label)) ($branch kf kt src op param ,(rename* args)))))
(trampoline-out-cont (define (attach-trampoline cps label src names vars args)
(make-trampoline join-label src args)) (with-cps cps
(trampoline-in-label (fresh-label)) (letk ktramp-out ,(make-trampoline join-label src args))
(trampoline-in-cont (letk ktramp-in ,(make-trampoline new-entry-label src args))
(make-trampoline new-entry-label src args)) (setk label
(kf (if exit-if-true? trampoline-in-label trampoline-out-label))
(kt (if exit-if-true? trampoline-out-label trampoline-in-label))
(cont (build-cont
($kargs names vars ($kargs names vars
($continue kf entry-src ($branch (if exit-if-true? ktramp-in ktramp-out)
($branch kt ,(rename-exp entry-exp args)))))) (if exit-if-true? ktramp-out ktramp-in)
(cps (intmap-replace! cps label cont)) entry-src
(cps (intmap-add! cps trampoline-in-label trampoline-in-cont))) entry-op entry-param ,(rename-vars entry-args args))))))
(intmap-add! cps trampoline-out-label trampoline-out-cont)))
;; Rewrite the targets of the entry branch to go to ;; Rewrite the targets of the entry branch to go to
;; trampolines. One will pass values out of the loop, and ;; trampolines. One will pass values out of the loop, and
;; one will pass values into the loop. ;; one will pass values into the loop.
(let* ((pre-header-vars (make-fresh-vars)) (let* ((pre-header-vars (make-fresh-vars))
(body-vars (make-fresh-vars)) (body-vars (make-fresh-vars))
(cps (attach-trampoline entry-label entry-src (cps (attach-trampoline cps entry-label entry-src
entry-names pre-header-vars entry-names pre-header-vars
pre-header-vars)) pre-header-vars))
(new-entry-cont (build-cont (new-entry-cont (build-cont
@ -148,44 +151,38 @@
(cond (cond
((intset-ref back-edges label) ((intset-ref back-edges label)
(match (intmap-ref cps label) (match (intmap-ref cps label)
(($ $kargs names vars ($ $continue _ src exp)) (($ $kargs names vars term)
(match (rename-exp exp body-vars) (match (rename-term term body-vars)
(($ $values args) (($ $continue _ src ($ $values args))
(attach-trampoline label src names vars args)) (attach-trampoline cps label src names vars args))
(exp (($ $continue _ src exp)
(let* ((args (make-fresh-vars)) (let* ((args (make-fresh-vars))
(bind-label (fresh-label)) (bind-label (fresh-label))
(edge* (build-cont (edge* (build-cont
($kargs names vars ($kargs names vars
($continue bind-label src ,exp)))) ($continue bind-label src ,exp))))
(cps (intmap-replace! cps label edge*)) (cps (intmap-replace! cps label edge*))
;; attach-trampoline uses intmap-replace!. ;; attach-trampoline uses setk.
(cps (intmap-add! cps bind-label #f))) (cps (intmap-add! cps bind-label #f)))
(attach-trampoline bind-label src (attach-trampoline cps bind-label src
entry-names args args))))))) entry-names args args)))))))
((intset-ref loop-exits label) ((intset-ref loop-exits label)
(match (intmap-ref cps label) (match (intmap-ref cps label)
(($ $kargs names vars (($ $kargs names vars ($ $branch kf kt src op param args))
($ $continue kf src ($ $branch kt exp))) (with-cps cps
(let* ((trampoline-out-label (fresh-label)) (letk ktramp-out ,(make-trampoline join-label src body-vars))
(trampoline-out-cont (setk label
(make-trampoline join-label src body-vars))
(kf (if (eqv? kf exit) trampoline-out-label kf))
(kt (if (eqv? kt exit) trampoline-out-label kt))
(cont (build-cont
($kargs names vars ($kargs names vars
($continue kf src ($branch (if (eqv? kf exit) ktramp-out kf)
($branch kt ,(rename-exp exp body-vars)))))) (if (eqv? kt exit) ktramp-out kt)
(cps (intmap-replace! cps label cont))) src
(intmap-add! cps trampoline-out-label trampoline-out-cont))))) op param ,(rename-vars args body-vars))))))))
(else (else
(match (intmap-ref cps label) (match (intmap-ref cps label)
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(let ((cont (build-cont (with-cps cps
($kargs names vars (setk label ($kargs names vars
($continue k src ,(rename-term term body-vars)))))
,(rename-exp exp body-vars))))))
(intmap-replace! cps label cont)))
(($ $kreceive) cps))))) (($ $kreceive) cps)))))
(intset-remove body-labels entry-label) (intset-remove body-labels entry-label)
cps)))))) cps))))))
@ -195,10 +192,8 @@
(intset-fold (lambda (label rotate?) (intset-fold (lambda (label rotate?)
(match (intmap-ref cps label) (match (intmap-ref cps label)
(($ $kreceive) #f) (($ $kreceive) #f)
(($ $kargs _ _ ($ $continue _ _ exp)) (($ $kargs _ _ ($ $branch)) #f)
(match exp (($ $kargs _ _ ($ $continue)) rotate?)))
(($ $branch) #f)
(_ rotate?)))))
edges #t)) edges #t))
(let* ((succs (compute-successors cps kfun)) (let* ((succs (compute-successors cps kfun))
(preds (invert-graph succs))) (preds (invert-graph succs)))

42
module/language/cps/self-references.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -36,8 +36,8 @@
(define (subst var) (define (subst var)
(intmap-ref env var (lambda (var) var))) (intmap-ref env var (lambda (var) var)))
(define (rename-exp label cps names vars k src exp) (define (rename-exp exp)
(let ((exp (rewrite-exp exp (rewrite-exp exp
((or ($ $const) ($ $prim)) ,exp) ((or ($ $const) ($ $prim)) ,exp)
(($ $call proc args) (($ $call proc args)
($call (subst proc) ,(map subst args))) ($call (subst proc) ,(map subst args)))
@ -45,33 +45,33 @@
($callk k (subst proc) ,(map subst args))) ($callk k (subst proc) ,(map subst args)))
(($ $primcall name param args) (($ $primcall name param args)
($primcall name param ,(map subst args))) ($primcall name param ,(map subst args)))
(($ $branch k ($ $primcall name param args))
($branch k ($primcall name param ,(map subst args))))
(($ $values args) (($ $values args)
($values ,(map subst args))) ($values ,(map subst args)))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler))))) ($prompt escape? (subst tag) handler))))
(intmap-replace! cps label
(build-cont
($kargs names vars ($continue k src ,exp))))))
(define (visit-exp cps label names vars k src exp) (define (rename-term term)
(match exp (rewrite-term term
(($ $fun label) (($ $continue k src exp)
($continue k src ,(rename-exp exp)))
(($ $branch kf kt src op param args)
($branch kf kt src op param ,(map subst args)))))
(define (visit-label label cps)
(match (intmap-ref cps label)
(($ $kargs _ _ ($ $continue k src ($ $fun label)))
(resolve-self-references cps label env)) (resolve-self-references cps label env))
(($ $rec names vars (($ $fun labels) ...)) (($ $kargs _ _ ($ $continue k src
($ $rec names vars (($ $fun labels) ...))))
(fold (lambda (label var cps) (fold (lambda (label var cps)
(match (intmap-ref cps label) (match (intmap-ref cps label)
(($ $kfun src meta self) (($ $kfun src meta self)
(resolve-self-references cps label (resolve-self-references cps label
(intmap-add env var self))))) (intmap-add env var self)))))
cps labels vars)) cps labels vars))
(_ (rename-exp label cps names vars k src exp)))) (($ $kargs names vars term)
(intmap-replace! cps label
(intset-fold (lambda (label cps) (build-cont ($kargs names vars ,(rename-term term)))))
(match (intmap-ref cps label)
(($ $kargs names vars ($ $continue k src exp))
(visit-exp cps label names vars k src exp))
(_ cps))) (_ cps)))
(compute-function-body cps label)
cps)) (intset-fold visit-label (compute-function-body cps label) cps))

44
module/language/cps/simplify.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -78,10 +78,10 @@
(ref* args)) (ref* args))
(($ $values args) (($ $values args)
(ref* args)) (ref* args))
(($ $branch kt ($ $primcall name param args))
(ref* args))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(ref tag)))) (ref tag))))
(($ $kargs _ _ ($ $branch kf kt src op param args))
(ref* args))
(_ (_
(values single multiple)))) (values single multiple))))
(let*-values (((single multiple) (values empty-intset empty-intset)) (let*-values (((single multiple) (values empty-intset empty-intset))
@ -144,15 +144,15 @@
(lambda (label cont) (lambda (label cont)
(and (not (intset-ref label-set label)) (and (not (intset-ref label-set label))
(rewrite-cont cont (rewrite-cont cont
(($ $kargs names syms ($ $continue kf src ($ $branch kt exp))) (($ $kargs names syms ($ $branch kf kt src op param args))
($kargs names syms ($kargs names syms
($continue (subst kf) src ($branch (subst kt) ,exp)))) ($branch (subst kf) (subst kt) src op param args)))
(($ $kargs names syms ($ $continue k src ($ $const val))) (($ $kargs names syms ($ $continue k src ($ $const val)))
,(match (intmap-ref conts k) ,(match (intmap-ref conts k)
(($ $kargs (_) (($ $kargs (_)
((? (lambda (var) (intset-ref singly-used var)) ((? (lambda (var) (intset-ref singly-used var))
var)) var))
($ $continue kf _ ($ $branch kt ($ $primcall 'false? #f (var))))) ($ $branch kf kt _ 'false? #f (var)))
(build-cont (build-cont
($kargs names syms ($kargs names syms
($continue (subst (if val kf kt)) src ($values ()))))) ($continue (subst (if val kf kt)) src ($values ())))))
@ -189,7 +189,11 @@
(($ $ktail) (ref0)) (($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt)) (($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k src exp)) (($ $kargs names syms ($ $continue k src exp))
(ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) (match exp
(($ $prompt _ _ handler) (ref2 k handler))
(_ (ref1 k))))
(($ $kargs names syms ($ $branch kf kt))
(ref2 kf kt))))
(let*-values (((single multiple) (values empty-intset empty-intset)) (let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intset-fold add-ref body single multiple))) ((single multiple) (intset-fold add-ref body single multiple)))
(intset-subtract (persistent-intset single) (intset-subtract (persistent-intset single)
@ -235,12 +239,15 @@
(match (intmap-ref var-map var (lambda (_) #f)) (match (intmap-ref var-map var (lambda (_) #f))
(#f var) (#f var)
(val (subst val)))) (val (subst val))))
(define (transform-exp label k src exp) (define (transform-term label term)
(if (intset-ref label-set label) (if (intset-ref label-set label)
(match term
(($ $continue k)
(match (intmap-ref conts k) (match (intmap-ref conts k)
(($ $kargs _ _ ($ $continue k* src* exp*)) (($ $kargs _ _ term)
(transform-exp k k* src* exp*))) (transform-term k term)))))
(build-term (rewrite-term term
(($ $continue k src exp)
($continue k src ($continue k src
,(rewrite-exp exp ,(rewrite-exp exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
@ -253,17 +260,16 @@
($primcall name param ,(map subst args))) ($primcall name param ,(map subst args)))
(($ $values args) (($ $values args)
($values ,(map subst args))) ($values ,(map subst args)))
(($ $branch kt ($ $primcall name param args))
($branch kt ($primcall name param ,(map subst args))))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler))))))) ($prompt escape? (subst tag) handler)))))
(($ $branch kf kt src op param args)
($branch kf kt src op param ,(map subst args))))))
(transform-conts (transform-conts
(lambda (label cont) (lambda (label cont)
(match cont (rewrite-cont cont
(($ $kargs names syms ($ $continue k src exp)) (($ $kargs names syms term)
(build-cont ($kargs names syms ,(transform-term label term)))
($kargs names syms ,(transform-exp label k src exp)))) (_ ,cont)))
(_ cont)))
conts))) conts)))
(define (simplify conts) (define (simplify conts)

36
module/language/cps/slot-allocation.scm
View file

@ -1,6 +1,6 @@
;; Continuation-passing style (CPS) intermediate language (IL) ;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -154,12 +154,12 @@ by a label, respectively."
(return (get-defs k) (intset-add (vars->intset args) proc))) (return (get-defs k) (intset-add (vars->intset args) proc)))
(($ $primcall name param args) (($ $primcall name param args)
(return (get-defs k) (vars->intset args))) (return (get-defs k) (vars->intset args)))
(($ $branch kt ($ $primcall name param args))
(return empty-intset (vars->intset args)))
(($ $values args) (($ $values args)
(return (get-defs k) (vars->intset args))) (return (get-defs k) (vars->intset args)))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(return empty-intset (intset tag))))) (return empty-intset (intset tag)))))
(($ $kargs _ _ ($ $branch kf kt src op param args))
(return empty-intset (vars->intset args)))
(($ $kclause arity body alt) (($ $kclause arity body alt)
(return (get-defs body) empty-intset)) (return (get-defs body) empty-intset))
(($ $kreceive arity kargs) (($ $kreceive arity kargs)
@ -238,10 +238,10 @@ body continuation in the prompt."
(visit-cont handler level (visit-cont k (1+ level) labels))) (visit-cont handler level (visit-cont k (1+ level) labels)))
(($ $kargs names syms ($ $continue k src ($ $primcall 'unwind))) (($ $kargs names syms ($ $continue k src ($ $primcall 'unwind)))
(visit-cont k (1- level) labels)) (visit-cont k (1- level) labels))
(($ $kargs names syms ($ $continue k src ($ $branch kt)))
(visit-cont k level (visit-cont kt level labels)))
(($ $kargs names syms ($ $continue k src exp)) (($ $kargs names syms ($ $continue k src exp))
(visit-cont k level labels))))))))))) (visit-cont k level labels))
(($ $kargs names syms ($ $branch kf kt))
(visit-cont kf level (visit-cont kt level labels))))))))))))
(define (visit-prompt label handler succs) (define (visit-prompt label handler succs)
(let ((body (compute-prompt-body label))) (let ((body (compute-prompt-body label)))
(define (out-or-back-edge? label) (define (out-or-back-edge? label)
@ -629,14 +629,14 @@ are comparable with eqv?. A tmp slot may be used."
(max (+ (get-proc-slot label) nargs) size))) (max (+ (get-proc-slot label) nargs) size)))
(define (measure-cont label cont size) (define (measure-cont label cont size)
(match cont (match cont
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(let ((size (max-size* vars size))) (let ((size (max-size* vars size)))
(match exp (match term
(($ $call proc args) (($ $continue _ _ ($ $call proc args))
(call-size label (1+ (length args)) size)) (call-size label (1+ (length args)) size))
(($ $callk _ proc args) (($ $continue _ _ ($ $callk _ proc args))
(call-size label (1+ (length args)) size)) (call-size label (1+ (length args)) size))
(($ $values args) (($ $continue _ _ ($ $values args))
(shuffle-size (get-shuffles label) size)) (shuffle-size (get-shuffles label) size))
(_ size)))) (_ size))))
(($ $kreceive) (($ $kreceive)
@ -744,6 +744,8 @@ are comparable with eqv?. A tmp slot may be used."
(intmap-fold (intmap-fold
(lambda (label cont representations) (lambda (label cont representations)
(match cont (match cont
(($ $kargs _ _ ($ $branch))
representations)
(($ $kargs _ _ ($ $continue k _ exp)) (($ $kargs _ _ ($ $continue k _ exp))
(match (get-defs k) (match (get-defs k)
(() representations) (() representations)
@ -970,16 +972,16 @@ are comparable with eqv?. A tmp slot may be used."
(define (allocate-cont label cont slots call-allocs) (define (allocate-cont label cont slots call-allocs)
(match cont (match cont
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(let-values (((slots live) (allocate-defs label vars slots))) (let-values (((slots live) (allocate-defs label vars slots)))
(match exp (match term
(($ $call proc args) (($ $continue k src ($ $call proc args))
(allocate-call label k (cons proc args) slots call-allocs live)) (allocate-call label k (cons proc args) slots call-allocs live))
(($ $callk _ proc args) (($ $continue k src ($ $callk _ proc args))
(allocate-call label k (cons proc args) slots call-allocs live)) (allocate-call label k (cons proc args) slots call-allocs live))
(($ $values args) (($ $continue k src ($ $values args))
(allocate-values label k args slots call-allocs)) (allocate-values label k args slots call-allocs))
(($ $prompt escape? tag handler) (($ $continue k src ($ $prompt escape? tag handler))
(allocate-prompt label k handler slots call-allocs)) (allocate-prompt label k handler slots call-allocs))
(_ (_
(values slots call-allocs))))) (values slots call-allocs)))))

68
module/language/cps/specialize-numbers.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2015, 2016, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2015, 2016, 2017, 2018 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
@ -146,9 +146,7 @@
(define (specialize-comparison cps kf kt src op a b unbox-a unbox-b) (define (specialize-comparison cps kf kt src op a b unbox-a unbox-b)
(with-cps cps (with-cps cps
(letv a* b*) (letv a* b*)
(letk kop ($kargs ('b) (b*) (letk kop ($kargs ('b) (b*) ($branch kf kt src op #f (a* b*))))
($continue kf src
($branch kt ($primcall op #f (a* b*))))))
(let$ unbox-b-body (unbox-b kop src b)) (let$ unbox-b-body (unbox-b kop src b))
(letk kunbox-b ($kargs ('a) (a*) ,unbox-b-body)) (letk kunbox-b ($kargs ('a) (a*) ,unbox-b-body))
($ (unbox-a kunbox-b src a)))) ($ (unbox-a kunbox-b src a))))
@ -157,9 +155,7 @@
unbox-a) unbox-a)
(with-cps cps (with-cps cps
(letv ia) (letv ia)
(letk kop ($kargs ('ia) (ia) (letk kop ($kargs ('ia) (ia) ($branch kf kt src op imm (ia))))
($continue kf src
($branch kt ($primcall op imm (ia))))))
($ (unbox-a kop src a)))) ($ (unbox-a kop src a))))
(define (specialize-comparison/s64-integer cps kf kt src op a-s64 b-int (define (specialize-comparison/s64-integer cps kf kt src op a-s64 b-int
@ -168,23 +164,19 @@
(with-cps cps (with-cps cps
(letv a b sunk) (letv a b sunk)
(letk kheap ($kargs ('sunk) (sunk) (letk kheap ($kargs ('sunk) (sunk)
($continue kf src ($branch kf kt src op #f (sunk b-int))))
($branch kt ($primcall op #f (sunk b-int))))))
;; Re-box the variable. FIXME: currently we use a specially ;; Re-box the variable. FIXME: currently we use a specially
;; marked s64->scm to avoid CSE from hoisting the allocation ;; marked s64->scm to avoid CSE from hoisting the allocation
;; again. Instead we should just use a-s64 directly and implement ;; again. Instead we should just use a-s64 directly and implement
;; an allocation sinking pass that should handle this.. ;; an allocation sinking pass that should handle this..
(let$ rebox-a-body (rebox-a kheap src a)) (let$ rebox-a-body (rebox-a kheap src a))
(letk kretag ($kargs () () ,rebox-a-body)) (letk kretag ($kargs () () ,rebox-a-body))
(letk kb ($kargs ('b) (b) (letk kb ($kargs ('b) (b) ($branch kf kt src s64-op #f (a b))))
($continue kf src
($branch kt ($primcall s64-op #f (a b))))))
(letk kfix ($kargs () () (letk kfix ($kargs () ()
($continue kb src ($continue kb src
($primcall 'untag-fixnum #f (b-int))))) ($primcall 'untag-fixnum #f (b-int)))))
(letk ka ($kargs ('a) (a) (letk ka ($kargs ('a) (a)
($continue kretag src ($branch kretag kfix src 'fixnum? #f (b-int))))
($branch kfix ($primcall 'fixnum? #f (b-int))))))
($ (unbox-a ka src a-s64))))) ($ (unbox-a ka src a-s64)))))
(define (specialize-comparison/integer-s64 cps kf kt src op a-int b-s64 (define (specialize-comparison/integer-s64 cps kf kt src op a-int b-s64
@ -196,8 +188,7 @@
(with-cps cps (with-cps cps
(letv a b sunk) (letv a b sunk)
(letk kheap ($kargs ('sunk) (sunk) (letk kheap ($kargs ('sunk) (sunk)
($continue kf src ($branch kf kt src '< #f (a-int sunk))))
($branch kt ($primcall '< #f (a-int sunk))))))
;; FIXME: We should just use b-s64 directly and implement an ;; FIXME: We should just use b-s64 directly and implement an
;; allocation sinking pass so that the box op that creates b-64 ;; allocation sinking pass so that the box op that creates b-64
;; should float down here. Instead, for now we just rebox the ;; should float down here. Instead, for now we just rebox the
@ -205,25 +196,19 @@
;; CSE. ;; CSE.
(let$ rebox-b-body (rebox-b kheap src b)) (let$ rebox-b-body (rebox-b kheap src b))
(letk kretag ($kargs () () ,rebox-b-body)) (letk kretag ($kargs () () ,rebox-b-body))
(letk ka ($kargs ('a) (a) (letk ka ($kargs ('a) (a) ($branch kf kt src 's64-< #f (a b))))
($continue kf src
($branch kt ($primcall 's64-< #f (a b))))))
(letk kfix ($kargs () () (letk kfix ($kargs () ()
($continue ka src ($continue ka src
($primcall 'untag-fixnum #f (a-int))))) ($primcall 'untag-fixnum #f (a-int)))))
(letk kb ($kargs ('b) (b) (letk kb ($kargs ('b) (b)
($continue kretag src ($branch kretag kfix src 'fixnum? #f (a-int))))
($branch kfix ($primcall 'fixnum? #f (a-int))))))
($ (unbox-b kb src b-s64)))))) ($ (unbox-b kb src b-s64))))))
(define (specialize-comparison/immediate-s64-integer cps kf kt src op a b-int (define (specialize-comparison/immediate-s64-integer cps kf kt src op a b-int
compare-integers) compare-integers)
(with-cps cps (with-cps cps
(letv b sunk) (letv b sunk)
(let$ sunk-compare-exp (compare-integers sunk)) (letk kheap ($kargs ('sunk) (sunk) ,(compare-integers kf kt src sunk)))
(letk kheap ($kargs ('sunk) (sunk)
($continue kf src
($branch kt ,sunk-compare-exp))))
;; Re-box the variable. FIXME: currently we use a specially marked ;; Re-box the variable. FIXME: currently we use a specially marked
;; load-const to avoid CSE from hoisting the constant. Instead we ;; load-const to avoid CSE from hoisting the constant. Instead we
;; should just use a $const directly and implement an allocation ;; should just use a $const directly and implement an allocation
@ -232,14 +217,11 @@
($continue kheap src ($continue kheap src
($primcall 'load-const/unlikely a ())))) ($primcall 'load-const/unlikely a ()))))
(letk kb ($kargs ('b) (b) (letk kb ($kargs ('b) (b)
($continue kf src ($branch kf kt src op a (b))))
($branch kt ($primcall op a (b))))))
(letk kfix ($kargs () () (letk kfix ($kargs () ()
($continue kb src ($continue kb src
($primcall 'untag-fixnum #f (b-int))))) ($primcall 'untag-fixnum #f (b-int)))))
(build-term (build-term ($branch kretag kfix src 'fixnum? #f (b-int)))))
($continue kretag src
($branch kfix ($primcall 'fixnum? #f (b-int)))))))
(define (sigbits-union x y) (define (sigbits-union x y)
(and x y (logior x y))) (and x y (logior x y)))
@ -324,8 +306,10 @@ BITS indicating the significant bits needed for a variable. BITS may be
(match (intmap-ref cps label) (match (intmap-ref cps label)
(($ $kfun src meta self) (($ $kfun src meta self)
(add-def out self)) (add-def out self))
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(let ((out (add-defs out vars))) (let ((out (add-defs out vars)))
(match term
(($ $continue k src exp)
(match exp (match exp
((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec)) ((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec))
;; No uses, so no info added to sigbits. ;; No uses, so no info added to sigbits.
@ -345,8 +329,6 @@ BITS indicating the significant bits needed for a variable. BITS may be
(add-unknown-use (add-unknown-uses out args) proc)) (add-unknown-use (add-unknown-uses out args) proc))
(($ $callk label proc args) (($ $callk label proc args)
(add-unknown-use (add-unknown-uses out args) proc)) (add-unknown-use (add-unknown-uses out args) proc))
(($ $branch kt ($ $primcall name param args))
(add-unknown-uses out args))
(($ $primcall name param args) (($ $primcall name param args)
(let ((h (significant-bits-handler name))) (let ((h (significant-bits-handler name)))
(if h (if h
@ -355,7 +337,9 @@ BITS indicating the significant bits needed for a variable. BITS may be
(h label types out param args defs))) (h label types out param args defs)))
(add-unknown-uses out args)))) (add-unknown-uses out args))))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(add-unknown-use out tag))))) (add-unknown-use out tag))))
(($ $branch kf kt src op param args)
(add-unknown-uses out args)))))
(_ out))))))))) (_ out)))))))))
(define (specialize-operations cps) (define (specialize-operations cps)
@ -623,9 +607,8 @@ BITS indicating the significant bits needed for a variable. BITS may be
(let ((imm-op (match op ('= 's64-imm-=) ('< 'imm-s64-<)))) (let ((imm-op (match op ('= 's64-imm-=) ('< 'imm-s64-<))))
(specialize-comparison/immediate-s64-integer (specialize-comparison/immediate-s64-integer
cps kf kt src imm-op a b cps kf kt src imm-op a b
(lambda (cps a) (lambda (kf kt src a)
(with-cps cps (build-term ($branch kf kt src op #f (a b))))))))
(build-exp ($primcall op #f (a b)))))))))
(else (else
(specialize-comparison/s64-integer cps kf kt src op a b (specialize-comparison/s64-integer cps kf kt src op a b
(unbox-s64 a) (unbox-s64 a)
@ -637,9 +620,8 @@ BITS indicating the significant bits needed for a variable. BITS may be
(let ((imm-op (match op ('= 's64-imm-=) ('< 's64-imm-<)))) (let ((imm-op (match op ('= 's64-imm-=) ('< 's64-imm-<))))
(specialize-comparison/immediate-s64-integer (specialize-comparison/immediate-s64-integer
cps kf kt src imm-op b a cps kf kt src imm-op b a
(lambda (cps b) (lambda (kf kt src b)
(with-cps cps (build-term ($branch kf kt src op #f (a b))))))))
(build-exp ($primcall op #f (a b)))))))))
(else (else
(specialize-comparison/integer-s64 cps kf kt src op a b (specialize-comparison/integer-s64 cps kf kt src op a b
(unbox-s64 b) (unbox-s64 b)
@ -654,8 +636,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
(sigbits (compute-significant-bits cps types label))) (sigbits (compute-significant-bits cps types label)))
(values cps types sigbits))) (values cps types sigbits)))
(($ $kargs names vars (($ $kargs names vars ($ $continue k src ($ $primcall op param args)))
($ $continue k src ($ $primcall op param args)))
(call-with-values (call-with-values
(lambda () (specialize-primcall cps k src op param args)) (lambda () (specialize-primcall cps k src op param args))
(lambda (cps term) (lambda (cps term)
@ -665,8 +646,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
cps) cps)
types sigbits)))) types sigbits))))
(($ $kargs names vars (($ $kargs names vars ($ $branch kf kt src op param args))
($ $continue kf src ($ $branch kt ($ $primcall op param args))))
(call-with-values (call-with-values
(lambda () (specialize-branch cps kf kt src op param args)) (lambda () (specialize-branch cps kf kt src op param args))
(lambda (cps term) (lambda (cps term)

12
module/language/cps/split-rec.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -70,9 +70,11 @@ references."
(intset-fold (intset-fold
(lambda (label defs uses) (lambda (label defs uses)
(match (intmap-ref conts label) (match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(values (values
(add-defs vars defs) (add-defs vars defs)
(match term
(($ $continue k src exp)
(match exp (match exp
((or ($ $const) ($ $prim)) uses) ((or ($ $const) ($ $prim)) uses)
(($ $fun kfun) (($ $fun kfun)
@ -87,12 +89,12 @@ references."
(add-uses args uses)) (add-uses args uses))
(($ $call proc args) (($ $call proc args)
(add-use proc (add-uses args uses))) (add-use proc (add-uses args uses)))
(($ $branch kt ($ $primcall name param args))
(add-uses args uses))
(($ $primcall name param args) (($ $primcall name param args)
(add-uses args uses)) (add-uses args uses))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(add-use tag uses))))) (add-use tag uses))))
(($ $branch kf kt src op param args)
(add-uses args uses)))))
(($ $kfun src meta self) (($ $kfun src meta self)
(values (add-def self defs) uses)) (values (add-def self defs) uses))
(_ (values defs uses)))) (_ (values defs uses))))

12
module/language/cps/type-checks.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -50,15 +50,13 @@ KFUN where we can prove that no assertion will be raised at run-time."
((causes-all-effects? fx) effects) ((causes-all-effects? fx) effects)
((causes-effect? fx &type-check) ((causes-effect? fx &type-check)
(match (intmap-ref conts label) (match (intmap-ref conts label)
(($ $kargs _ _ exp) (($ $kargs names vars
(match exp ($ $continue k src ($ $primcall name param args)))
(($ $continue k src ($ $primcall name param args))
(visit-primcall effects fx label name param args)) (visit-primcall effects fx label name param args))
(($ $continue k src (($ $kargs names vars
($ $branch _ ($ $primcall name param args))) ($ $branch kf kt src name param args))
(visit-primcall effects fx label name param args)) (visit-primcall effects fx label name param args))
(_ effects))) (_ effects)))
(_ effects)))
(else effects)))) (else effects))))
types types
effects)))) effects))))

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

@ -1,5 +1,5 @@
;;; Abstract constant folding on CPS ;;; Abstract constant folding on CPS
;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc. ;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
;;; ;;;
;;; This library is free software: you can redistribute it and/or modify ;;; This library is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as ;;; it under the terms of the GNU Lesser General Public License as
@ -355,8 +355,7 @@
(letk kt ($kargs () () ($continue k src ($const #t)))) (letk kt ($kargs () () ($continue k src ($const #t))))
(letk kf ($kargs () () ($continue k src ($const #f)))) (letk kf ($kargs () () ($continue k src ($const #f))))
(letk ku64 ($kargs (#f) (u64) (letk ku64 ($kargs (#f) (u64)
($continue kt src ($branch kt kf src 's64-imm-= 0 (u64))))
($branch kf ($primcall 's64-imm-= 0 (u64))))))
(letk kand ($kargs (#f) (res) (letk kand ($kargs (#f) (res)
($continue ku64 src ($primcall 'untag-fixnum #f (res))))) ($continue ku64 src ($primcall 'untag-fixnum #f (res)))))
(letk kmask ($kargs (#f) (mask) (letk kmask ($kargs (#f) (mask)
@ -527,9 +526,7 @@
($kargs names vars ($kargs names vars
($continue (if v kt kf) src ($continue (if v kt kf) src
($values ()))))))))))))))) ($values ())))))))))))))))
(define (visit-expression cps label names vars k src exp) (define (visit-primcall cps label names vars k src name param args)
(match exp
(($ $primcall name 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)
(($ $kargs (_) (def)) (($ $kargs (_) (def))
@ -537,22 +534,24 @@
(reduce-primcall cps label names vars k src name param args))) (reduce-primcall cps label names vars k src name param args)))
(_ (_
(reduce-primcall cps label names vars k src name param args)))) (reduce-primcall cps label names vars k src name param args))))
(($ $branch kt ($ $primcall name param args)) (define (visit-branch cps label names vars kf kt src name param args)
;; We might be able to fold primcalls that branch. ;; We might be able to fold primcalls that branch.
(match args (match args
((x) ((x)
(or (fold-unary-branch cps label names vars k kt src name param x) (or (fold-unary-branch cps label names vars kf kt src name param x)
cps)) cps))
((x y) ((x y)
(or (fold-binary-branch cps label names vars k kt src name param x y) (or (fold-binary-branch cps label names vars kf kt src name param x y)
cps)))) cps))))
(_ 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)
(match (intmap-ref cps label) (match (intmap-ref cps label)
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars ($ $continue k src
(visit-expression cps label names vars k src exp)) ($ $primcall op param args)))
(visit-primcall cps label names vars k src op param args))
(($ $kargs names vars ($ $branch kf kt src op param args))
(visit-branch cps label names vars kf kt src op param args))
(_ cps))) (_ cps)))
cps)))) cps))))

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

@ -1,5 +1,5 @@
;;; Type analysis on CPS ;;; Type analysis on CPS
;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc. ;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
;;; ;;;
;;; This library is free software: you can redistribute it and/or modify ;;; This library is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as ;;; it under the terms of the GNU Lesser General Public License as
@ -1777,8 +1777,9 @@ minimum, and maximum."
(match cont (match cont
(($ $kargs _ _ ($ $continue k src exp)) (($ $kargs _ _ ($ $continue k src exp))
(match exp (match exp
((or ($ $branch) ($ $prompt)) 2) (($ $prompt) 2)
(_ 1))) (_ 1)))
(($ $kargs _ _ ($ $branch)) 2)
(($ $kfun src meta self tail clause) (if clause 1 0)) (($ $kfun src meta self tail clause) (if clause 1 0))
(($ $kclause arity body alt) (if alt 2 1)) (($ $kclause arity body alt) (if alt 2 1))
(($ $kreceive) 1) (($ $kreceive) 1)
@ -1915,11 +1916,6 @@ maximum, where type is a bitset as a fixnum."
(values (append changed0 changed1) typev))) (values (append changed0 changed1) typev)))
;; Each of these branches must propagate to its successors. ;; Each of these branches must propagate to its successors.
(match exp (match exp
(($ $branch kt ($ $primcall name param args))
;; The "normal" continuation is the #f branch.
(let ((kf-types (infer-primcall types 0 name param args #f))
(kt-types (infer-primcall types 1 name param args #f)))
(propagate2 k kf-types kt kt-types)))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
;; The "normal" continuation enters the prompt. ;; The "normal" continuation enters the prompt.
(propagate2 k types handler types)) (propagate2 k types handler types))
@ -1979,6 +1975,10 @@ maximum, where type is a bitset as a fixnum."
(match (intmap-ref conts label) (match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars ($ $continue k src exp))
(visit-exp label typev k types exp)) (visit-exp label typev k types exp))
(($ $kargs names vars ($ $branch kf kt src op param args))
;; The "normal" continuation is the #f branch.
(propagate2 kf (infer-primcall types 0 op param args #f)
kt (infer-primcall types 1 op param args #f)))
(($ $kreceive arity k) (($ $kreceive arity k)
(match (intmap-ref conts k) (match (intmap-ref conts k)
(($ $kargs names vars) (($ $kargs names vars)

30
module/language/cps/utils.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -198,13 +198,14 @@ disjoint, an error will be signalled."
(if kalt (if kalt
(visit-cont kalt (visit-cont kbody labels)) (visit-cont kalt (visit-cont kbody labels))
(visit-cont kbody labels))) (visit-cont kbody labels)))
(($ $kargs names syms ($ $continue k src exp)) (($ $kargs names syms term)
(visit-cont k (match exp (match term
(($ $branch k) (($ $continue k src ($ $prompt escape? tag handler))
(visit-cont k (visit-cont handler labels)))
(($ $continue k)
(visit-cont k labels)) (visit-cont k labels))
(($ $prompt escape? tag k) (($ $branch kf kt)
(visit-cont k labels)) (visit-cont kf (visit-cont kt labels))))))))))))
(_ labels)))))))))))
(define* (compute-reachable-functions conts #:optional (kfun 0)) (define* (compute-reachable-functions conts #:optional (kfun 0))
"Compute a mapping LABEL->LABEL..., where each key is a reachable "Compute a mapping LABEL->LABEL..., where each key is a reachable
@ -257,11 +258,13 @@ intset."
(if (intmap-ref succs label (lambda (_) #f)) (if (intmap-ref succs label (lambda (_) #f))
succs succs
(match (intmap-ref conts label) (match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(match term
(($ $continue k src exp)
(match exp (match exp
(($ $branch kt) (propagate2 k kt))
(($ $prompt escape? tag handler) (propagate2 k handler)) (($ $prompt escape? tag handler) (propagate2 k handler))
(_ (propagate1 k)))) (_ (propagate1 k))))
(($ $branch kf kt) (propagate2 kf kt))))
(($ $kreceive arity k) (($ $kreceive arity k)
(propagate1 k)) (propagate1 k))
(($ $kfun src meta self tail clause) (($ $kfun src meta self tail clause)
@ -291,12 +294,15 @@ intset."
preds) preds)
(($ $kclause arity kbody kalt) (($ $kclause arity kbody kalt)
(add-pred kbody (if kalt (add-pred kalt preds) preds))) (add-pred kbody (if kalt (add-pred kalt preds) preds)))
(($ $kargs names syms ($ $continue k src exp)) (($ $kargs names syms term)
(match term
(($ $continue k src exp)
(add-pred k (add-pred k
(match exp (match exp
(($ $branch k) (add-pred k preds))
(($ $prompt _ _ k) (add-pred k preds)) (($ $prompt _ _ k) (add-pred k preds))
(_ preds)))))) (_ preds))))
(($ $branch kf kt)
(add-pred kf (add-pred kt preds)))))))
(persistent-intmap (persistent-intmap
(intset-fold add-preds labels (intset-fold add-preds labels
(intset->intmap (lambda (label) '()) labels)))) (intset->intmap (lambda (label) '()) labels))))

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

@ -1,5 +1,5 @@
;;; Diagnostic checker for CPS ;;; Diagnostic checker for CPS
;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc. ;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
;;; ;;;
;;; This library is free software: you can redistribute it and/or modify ;;; This library is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as ;;; it under the terms of the GNU Lesser General Public License as
@ -62,7 +62,7 @@
(intmap-fold (intmap-fold
(lambda (label cont seen) (lambda (label cont seen)
(match (intmap-ref conts label) (match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(fold1 adjoin-def vars seen)) (fold1 adjoin-def vars seen))
(($ $kfun src meta self tail clause) (($ $kfun src meta self tail clause)
(adjoin-def self seen)) (adjoin-def self seen))
@ -99,12 +99,15 @@ definitions that are available at LABEL."
(values (append changed0 changed1) defs))) (values (append changed0 changed1) defs)))
(match (intmap-ref conts label) (match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(let ((out (fold1 adjoin-def vars in))) (let ((out (fold1 adjoin-def vars in)))
(match term
(($ $continue k src exp)
(match exp (match exp
(($ $branch kt) (propagate2 k kt out))
(($ $prompt escape? tag handler) (propagate2 k handler out)) (($ $prompt escape? tag handler) (propagate2 k handler out))
(_ (propagate1 k out))))) (_ (propagate1 k out))))
(($ $branch kf kt)
(propagate2 kf kt out)))))
(($ $kreceive arity k) (($ $kreceive arity k)
(propagate1 k in)) (propagate1 k in))
(($ $kfun src meta self tail clause) (($ $kfun src meta self tail clause)
@ -159,21 +162,60 @@ definitions that are available at LABEL."
(check-use proc) (check-use proc)
(for-each check-use args) (for-each check-use args)
(visit-first-order kfun)) (visit-first-order kfun))
(($ $branch kt ($ $primcall name param args))
(for-each check-use args)
first-order)
(($ $primcall name param args) (($ $primcall name param args)
(for-each check-use args) (for-each check-use args)
first-order) first-order)
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(check-use tag) (check-use tag)
first-order))) first-order)))
(define (visit-term term bound first-order)
(define (check-use var)
(unless (intset-ref bound var)
(error "unbound var" var)))
(define (visit-first-order kfun)
(if (intset-ref first-order kfun)
first-order
(visit-fun kfun empty-intset (intset-add first-order kfun))))
(match term
(($ $continue k src exp)
(match exp
((or ($ $const) ($ $prim)) first-order)
;; todo: $closure
(($ $fun kfun)
(visit-fun kfun bound first-order))
(($ $closure kfun)
(visit-first-order kfun))
(($ $rec names vars (($ $fun kfuns) ...))
(let ((bound (fold1 adjoin-def vars bound)))
(fold1 (lambda (kfun first-order)
(visit-fun kfun bound first-order))
kfuns first-order)))
(($ $values args)
(for-each check-use args)
first-order)
(($ $call proc args)
(check-use proc)
(for-each check-use args)
first-order)
(($ $callk kfun proc args)
(check-use proc)
(for-each check-use args)
(visit-first-order kfun))
(($ $primcall name param args)
(for-each check-use args)
first-order)
(($ $prompt escape? tag handler)
(check-use tag)
first-order)))
(($ $branch kf kt src name param args)
(for-each check-use args)
first-order)))
(intmap-fold (intmap-fold
(lambda (label bound first-order) (lambda (label bound first-order)
(let ((bound (intset-union free bound))) (let ((bound (intset-union free bound)))
(match (intmap-ref conts label) (match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(visit-exp exp (fold1 adjoin-def vars bound) first-order)) (visit-term term (fold1 adjoin-def vars bound) first-order))
(_ first-order)))) (_ first-order))))
(compute-available-definitions conts kfun) (compute-available-definitions conts kfun)
first-order))) first-order)))
@ -236,11 +278,6 @@ definitions that are available at LABEL."
(assert-kreceive-or-ktail)) (assert-kreceive-or-ktail))
(($ $callk k proc args) (($ $callk k proc args)
(assert-kreceive-or-ktail)) (assert-kreceive-or-ktail))
(($ $branch kt exp)
(assert-nullary)
(match (intmap-ref conts kt)
(($ $kargs () ()) #t)
(cont (error "bad kt" cont))))
(($ $primcall name param args) (($ $primcall name param args)
(match cont (match cont
(($ $kargs) #t) (($ $kargs) #t)
@ -254,15 +291,26 @@ definitions that are available at LABEL."
(match (intmap-ref conts handler) (match (intmap-ref conts handler)
(($ $kreceive) #t) (($ $kreceive) #t)
(cont (error "bad handler" cont)))))) (cont (error "bad handler" cont))))))
(define (check-term term)
(match term
(($ $continue k src exp)
(check-arity exp (intmap-ref conts k)))
(($ $branch kf kt src op param args)
(match (intmap-ref conts kf)
(($ $kargs () ()) #t)
(cont (error "bad kf" cont)))
(match (intmap-ref conts kt)
(($ $kargs () ()) #t)
(cont (error "bad kt" cont))))))
(let ((reachable (compute-reachable-labels conts kfun))) (let ((reachable (compute-reachable-labels conts kfun)))
(intmap-for-each (intmap-for-each
(lambda (label cont) (lambda (label cont)
(when (intset-ref reachable label) (when (intset-ref reachable label)
(match cont (match cont
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars term)
(unless (= (length names) (length vars)) (unless (= (length names) (length vars))
(error "broken $kargs" label names vars)) (error "broken $kargs" label names vars))
(check-arity exp (intmap-ref conts k))) (check-term term))
(_ #t)))) (_ #t))))
conts))) conts)))

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -310,9 +310,8 @@
(let$ init (convert init kreceive subst)) (let$ init (convert init kreceive subst))
(letk kunbound ($kargs () () ,init)) (letk kunbound ($kargs () () ,init))
(build-term (build-term
($continue kbound src ($branch kbound kunbound src
($branch kunbound 'undefined? #f (orig-var))))))))))))
($primcall 'undefined? #f (orig-var))))))))))))))
(define (build-list cps k src vals) (define (build-list cps k src vals)
(match vals (match vals
@ -914,14 +913,11 @@
(if (heap-type-predicate? name) (if (heap-type-predicate? name)
(with-cps cps (with-cps cps
(letk kt* ($kargs () () (letk kt* ($kargs () ()
($continue kf src ($branch kf kt src name #f args)))
($branch kt ($primcall name #f args)))))
(build-term (build-term
($continue kf src ($branch kf kt* src 'heap-object? #f args)))
($branch kt* ($primcall 'heap-object? #f args)))))
(with-cps cps (with-cps cps
(build-term ($continue kf src (build-term ($branch kf kt src name #f args)))))))
($branch kt ($primcall name #f args)))))))))
(($ <conditional> src test consequent alternate) (($ <conditional> src test consequent alternate)
(with-cps cps (with-cps cps
(let$ t (convert-test consequent kt kf)) (let$ t (convert-test consequent kt kf))
@ -935,8 +931,7 @@
(_ (convert-arg cps test (_ (convert-arg cps test
(lambda (cps test) (lambda (cps test)
(with-cps cps (with-cps cps
(build-term ($continue kt src (build-term ($branch kt kf src 'false? #f (test)))))))))
($branch kf ($primcall 'false? #f (test)))))))))))
(with-cps cps (with-cps cps
(let$ t (convert consequent k subst)) (let$ t (convert consequent k subst))
(let$ f (convert alternate k subst)) (let$ f (convert alternate k subst))