mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 03:30:27 +02:00
$branch is now a distinct CPS term type
* 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
parent
108ade6b0e
commit
afb0a92d50
26 changed files with 907 additions and 804 deletions
|
|
@ -33,6 +33,7 @@
|
|||
(eval . (put '$letk* 'scheme-indent-function 1))
|
||||
(eval . (put '$letconst 'scheme-indent-function 1))
|
||||
(eval . (put '$continue 'scheme-indent-function 2))
|
||||
(eval . (put '$branch 'scheme-indent-function 3))
|
||||
(eval . (put '$kargs 'scheme-indent-function 2))
|
||||
(eval . (put '$kfun 'scheme-indent-function 4))
|
||||
(eval . (put '$letrec 'scheme-indent-function 3))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -127,10 +127,10 @@
|
|||
$kreceive $kargs $kfun $ktail $kclause
|
||||
|
||||
;; Terms.
|
||||
$continue
|
||||
$continue $branch
|
||||
|
||||
;; Expressions.
|
||||
$const $prim $fun $rec $closure $branch
|
||||
$const $prim $fun $rec $closure
|
||||
$call $callk $primcall $values $prompt
|
||||
|
||||
;; Building macros.
|
||||
|
|
@ -179,6 +179,7 @@
|
|||
|
||||
;; Terms.
|
||||
(define-cps-type $continue k src exp)
|
||||
(define-cps-type $branch kf kt src op param args)
|
||||
|
||||
;; Expressions.
|
||||
(define-cps-type $const val)
|
||||
|
|
@ -186,7 +187,6 @@
|
|||
(define-cps-type $fun body) ; Higher-order.
|
||||
(define-cps-type $rec names syms funs) ; Higher-order.
|
||||
(define-cps-type $closure label nfree) ; First-order.
|
||||
(define-cps-type $branch kt exp)
|
||||
(define-cps-type $call proc args)
|
||||
(define-cps-type $callk k proc args) ; First-order.
|
||||
(define-cps-type $primcall name param args)
|
||||
|
|
@ -223,11 +223,17 @@
|
|||
((_ (unquote exp))
|
||||
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
|
||||
(syntax-rules (unquote
|
||||
$const $prim $fun $rec $closure $branch
|
||||
$const $prim $fun $rec $closure
|
||||
$call $callk $primcall $values $prompt)
|
||||
((_ (unquote exp)) exp)
|
||||
((_ ($const val)) (make-$const val))
|
||||
|
|
@ -247,7 +253,6 @@
|
|||
((_ ($values (unquote args))) (make-$values args))
|
||||
((_ ($values (arg ...))) (make-$values (list arg ...)))
|
||||
((_ ($values args)) (make-$values args))
|
||||
((_ ($branch kt exp)) (make-$branch kt (build-exp exp)))
|
||||
((_ ($prompt escape? tag handler))
|
||||
(make-$prompt escape? tag handler))))
|
||||
|
||||
|
|
@ -280,9 +285,13 @@
|
|||
(('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)
|
||||
(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)
|
||||
(build-exp ($const *unspecified*)))
|
||||
(('const exp)
|
||||
|
|
@ -301,8 +310,6 @@
|
|||
(build-exp ($callk k proc arg)))
|
||||
(('primcall name param arg ...)
|
||||
(build-exp ($primcall name param arg)))
|
||||
(('branch k exp)
|
||||
(build-exp ($branch k ,(parse-cps exp))))
|
||||
(('values arg ...)
|
||||
(build-exp ($values arg)))
|
||||
(('prompt escape? tag handler)
|
||||
|
|
@ -325,9 +332,13 @@
|
|||
`(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,kbody
|
||||
. ,(if kalternate (list kalternate) '())))
|
||||
|
||||
;; Calls.
|
||||
;; Terms.
|
||||
(($ $continue k src exp)
|
||||
`(continue ,k ,(unparse-cps exp)))
|
||||
(($ $branch kf kt src op param args)
|
||||
`(branch ,kf ,kt ,op ,param ,@args))
|
||||
|
||||
;; Expressions.
|
||||
(($ $const val)
|
||||
(if (unspecified? val)
|
||||
'(unspecified)
|
||||
|
|
@ -348,8 +359,6 @@
|
|||
`(callk ,k ,proc ,@args))
|
||||
(($ $primcall name param args)
|
||||
`(primcall ,name ,param ,@args))
|
||||
(($ $branch k exp)
|
||||
`(branch ,k ,(unparse-cps exp)))
|
||||
(($ $values args)
|
||||
`(values ,@args))
|
||||
(($ $prompt escape? tag handler)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -89,12 +89,12 @@ conts."
|
|||
(add-uses args uses))
|
||||
(($ $call proc args)
|
||||
(add-uses args uses))
|
||||
(($ $branch kt ($ $primcall name param args))
|
||||
(add-uses args uses))
|
||||
(($ $primcall name param args)
|
||||
(add-uses args uses))
|
||||
(($ $prompt escape? tag handler)
|
||||
(add-use tag uses))))
|
||||
(($ $kargs _ _ ($ $branch kf kt src op param args))
|
||||
(add-uses args uses))
|
||||
(_ uses)))
|
||||
conts
|
||||
empty-intset)))
|
||||
|
|
@ -117,8 +117,9 @@ conts."
|
|||
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
|
||||
(($ $ktail) (ref0))
|
||||
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
|
||||
(($ $kargs names syms ($ $continue k src exp))
|
||||
(ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
|
||||
(($ $kargs _ _ ($ $continue k _ ($ $prompt _ _ h))) (ref2 k h))
|
||||
(($ $kargs _ _ ($ $continue k)) (ref1 k))
|
||||
(($ $kargs _ _ ($ $branch kf kt)) (ref2 kf kt))))
|
||||
(let*-values (((single multiple) (values empty-intset empty-intset))
|
||||
((single multiple) (intset-fold add-ref body single multiple)))
|
||||
(intset-subtract (persistent-intset single)
|
||||
|
|
@ -226,35 +227,35 @@ proc argument. For recursive calls, use the appropriate 'self'
|
|||
variable, if possible. Also rewrite uses of the non-well-known but
|
||||
shared closures to use the appropriate 'self' variable, if possible."
|
||||
;; env := var -> (var . label)
|
||||
(define (rewrite-fun kfun cps env)
|
||||
(define (visit-fun kfun cps env)
|
||||
(define (subst var)
|
||||
(match (intmap-ref env var (lambda (_) #f))
|
||||
(#f var)
|
||||
((var . label) var)))
|
||||
|
||||
(define (rename-exp label cps names vars k src exp)
|
||||
(intmap-replace!
|
||||
cps label
|
||||
(build-cont
|
||||
($kargs names vars
|
||||
($continue k src
|
||||
,(rewrite-exp exp
|
||||
((or ($ $const) ($ $prim)) ,exp)
|
||||
(($ $call proc args)
|
||||
,(let ((args (map subst args)))
|
||||
(rewrite-exp (intmap-ref env proc (lambda (_) #f))
|
||||
(#f ($call proc ,args))
|
||||
((closure . label) ($callk label closure ,args)))))
|
||||
(($ $primcall name param args)
|
||||
($primcall name param ,(map subst args)))
|
||||
(($ $branch k ($ $primcall name param args))
|
||||
($branch k ($primcall name param ,(map subst args))))
|
||||
(($ $values args)
|
||||
($values ,(map subst args)))
|
||||
(($ $prompt escape? tag handler)
|
||||
($prompt escape? (subst tag) handler))))))))
|
||||
(define (visit-exp exp)
|
||||
(rewrite-exp exp
|
||||
((or ($ $const) ($ $prim)) ,exp)
|
||||
(($ $call proc args)
|
||||
,(let ((args (map subst args)))
|
||||
(rewrite-exp (intmap-ref env proc (lambda (_) #f))
|
||||
(#f ($call proc ,args))
|
||||
((closure . label) ($callk label closure ,args)))))
|
||||
(($ $primcall name param args)
|
||||
($primcall name param ,(map subst args)))
|
||||
(($ $values args)
|
||||
($values ,(map subst args)))
|
||||
(($ $prompt escape? 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 (add-bound-var bound label env)
|
||||
(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
|
||||
;; closure.
|
||||
(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)
|
||||
(match (intmap-ref cps label)
|
||||
(($ $kfun src meta self)
|
||||
(rewrite-fun label cps
|
||||
(compute-env label var self vars labels
|
||||
env)))))
|
||||
cps labels vars))
|
||||
(_ (rename-exp label cps names vars k src exp))))
|
||||
(fold (lambda (label var cps)
|
||||
(match (intmap-ref cps label)
|
||||
(($ $kfun src meta self)
|
||||
(visit-fun label cps
|
||||
(compute-env label var self vars labels env)))))
|
||||
cps labels vars))
|
||||
|
||||
(define (rewrite-cont label cps)
|
||||
(define (visit-cont label cps)
|
||||
(match (intmap-ref cps label)
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(visit-exp label cps names vars k src exp))
|
||||
(($ $kargs names vars
|
||||
($ $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)))
|
||||
|
||||
(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
|
||||
;; functions with shared closures.
|
||||
|
|
@ -299,7 +301,7 @@ shared closures to use the appropriate 'self' variable, if possible."
|
|||
env))
|
||||
shared
|
||||
empty-intmap)))
|
||||
(persistent-intmap (rewrite-fun kfun cps env))))
|
||||
(persistent-intmap (visit-fun kfun cps env))))
|
||||
|
||||
(define (compute-free-vars conts kfun shared)
|
||||
"Compute a FUN-LABEL->FREE-VAR... map describing all free variable
|
||||
|
|
@ -350,31 +352,33 @@ references."
|
|||
(intset-fold
|
||||
(lambda (label defs uses)
|
||||
(match (intmap-ref conts label)
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(($ $kargs names vars term)
|
||||
(values
|
||||
(add-defs vars defs)
|
||||
(match exp
|
||||
((or ($ $const) ($ $prim)) uses)
|
||||
(($ $fun kfun)
|
||||
(intset-union (persistent-intset uses)
|
||||
(intmap-ref free kfun)))
|
||||
(($ $rec names vars (($ $fun kfun) ...))
|
||||
(fold (lambda (kfun uses)
|
||||
(intset-union (persistent-intset uses)
|
||||
(intmap-ref free kfun)))
|
||||
uses kfun))
|
||||
(($ $values args)
|
||||
(add-uses args uses))
|
||||
(($ $call proc args)
|
||||
(add-use proc (add-uses args uses)))
|
||||
(($ $callk label proc args)
|
||||
(add-use proc (add-uses args uses)))
|
||||
(($ $branch kt ($ $primcall name param args))
|
||||
(add-uses args uses))
|
||||
(($ $primcall name param args)
|
||||
(add-uses args uses))
|
||||
(($ $prompt escape? tag handler)
|
||||
(add-use tag uses)))))
|
||||
(match term
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
((or ($ $const) ($ $prim)) uses)
|
||||
(($ $fun kfun)
|
||||
(intset-union (persistent-intset uses)
|
||||
(intmap-ref free kfun)))
|
||||
(($ $rec names vars (($ $fun kfun) ...))
|
||||
(fold (lambda (kfun uses)
|
||||
(intset-union (persistent-intset uses)
|
||||
(intmap-ref free kfun)))
|
||||
uses kfun))
|
||||
(($ $values args)
|
||||
(add-uses args uses))
|
||||
(($ $call proc args)
|
||||
(add-use proc (add-uses args uses)))
|
||||
(($ $callk label proc args)
|
||||
(add-use proc (add-uses args uses)))
|
||||
(($ $primcall name param args)
|
||||
(add-uses args uses))
|
||||
(($ $prompt escape? tag handler)
|
||||
(add-use tag uses))))
|
||||
(($ $branch kf kt src op param args)
|
||||
(add-uses args uses)))))
|
||||
(($ $kfun src meta self)
|
||||
(values (add-def self defs) uses))
|
||||
(_ (values defs uses))))
|
||||
|
|
@ -715,14 +719,6 @@ bound to @var{var}, and continue to @var{k}."
|
|||
(build-term
|
||||
($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))
|
||||
(convert-args cps args
|
||||
(lambda (cps args)
|
||||
|
|
@ -736,7 +732,14 @@ bound to @var{var}, and continue to @var{k}."
|
|||
(with-cps cps
|
||||
(build-term
|
||||
($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)
|
||||
(match (intmap-ref cps label (lambda (_) #f))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; 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))))
|
||||
(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?)
|
||||
(if (< (max kt kf) label)
|
||||
;; Two backwards branches. Prefer
|
||||
|
|
@ -474,71 +474,71 @@
|
|||
(define (binary-</imm op a b)
|
||||
(op asm (from-sp (slot a)) b)
|
||||
(emit-branch emit-jl emit-jnl))
|
||||
(match exp
|
||||
(match (vector op param args)
|
||||
;; Immediate type tag predicates.
|
||||
(($ $primcall 'fixnum? #f (a)) (unary emit-fixnum? a))
|
||||
(($ $primcall 'heap-object? #f (a)) (unary emit-heap-object? a))
|
||||
(($ $primcall 'char? #f (a)) (unary emit-char? a))
|
||||
(($ $primcall 'eq-false? #f (a)) (unary emit-eq-false? a))
|
||||
(($ $primcall 'eq-nil? #f (a)) (unary emit-eq-nil? a))
|
||||
(($ $primcall 'eq-null? #f (a)) (unary emit-eq-null? a))
|
||||
(($ $primcall 'eq-true? #f (a)) (unary emit-eq-true? a))
|
||||
(($ $primcall 'unspecified? #f (a)) (unary emit-unspecified? a))
|
||||
(($ $primcall 'undefined? #f (a)) (unary emit-undefined? a))
|
||||
(($ $primcall 'eof-object? #f (a)) (unary emit-eof-object? a))
|
||||
(($ $primcall 'null? #f (a)) (unary emit-null? a))
|
||||
(($ $primcall 'false? #f (a)) (unary emit-false? a))
|
||||
(($ $primcall 'nil? #f (a)) (unary emit-nil? a))
|
||||
(#('fixnum? #f (a)) (unary emit-fixnum? a))
|
||||
(#('heap-object? #f (a)) (unary emit-heap-object? a))
|
||||
(#('char? #f (a)) (unary emit-char? a))
|
||||
(#('eq-false? #f (a)) (unary emit-eq-false? a))
|
||||
(#('eq-nil? #f (a)) (unary emit-eq-nil? a))
|
||||
(#('eq-null? #f (a)) (unary emit-eq-null? a))
|
||||
(#('eq-true? #f (a)) (unary emit-eq-true? a))
|
||||
(#('unspecified? #f (a)) (unary emit-unspecified? a))
|
||||
(#('undefined? #f (a)) (unary emit-undefined? a))
|
||||
(#('eof-object? #f (a)) (unary emit-eof-object? a))
|
||||
(#('null? #f (a)) (unary emit-null? a))
|
||||
(#('false? #f (a)) (unary emit-false? a))
|
||||
(#('nil? #f (a)) (unary emit-nil? a))
|
||||
;; Heap type tag predicates.
|
||||
(($ $primcall 'pair? #f (a)) (unary emit-pair? a))
|
||||
(($ $primcall 'struct? #f (a)) (unary emit-struct? a))
|
||||
(($ $primcall 'symbol? #f (a)) (unary emit-symbol? a))
|
||||
(($ $primcall 'variable? #f (a)) (unary emit-variable? a))
|
||||
(($ $primcall 'vector? #f (a)) (unary emit-vector? a))
|
||||
(($ $primcall 'string? #f (a)) (unary emit-string? a))
|
||||
(($ $primcall 'heap-number? #f (a)) (unary emit-heap-number? a))
|
||||
(($ $primcall 'hash-table? #f (a)) (unary emit-hash-table? a))
|
||||
(($ $primcall 'pointer? #f (a)) (unary emit-pointer? a))
|
||||
(($ $primcall 'fluid? #f (a)) (unary emit-fluid? a))
|
||||
(($ $primcall 'stringbuf? #f (a)) (unary emit-stringbuf? a))
|
||||
(($ $primcall 'dynamic-state? #f (a)) (unary emit-dynamic-state? a))
|
||||
(($ $primcall 'frame? #f (a)) (unary emit-frame? a))
|
||||
(($ $primcall 'keyword? #f (a)) (unary emit-keyword? a))
|
||||
(($ $primcall 'atomic-box? #f (a)) (unary emit-atomic-box? a))
|
||||
(($ $primcall 'syntax? #f (a)) (unary emit-syntax? a))
|
||||
(($ $primcall 'program? #f (a)) (unary emit-program? a))
|
||||
(($ $primcall 'vm-continuation? #f (a)) (unary emit-vm-continuation? a))
|
||||
(($ $primcall 'bytevector? #f (a)) (unary emit-bytevector? a))
|
||||
(($ $primcall 'weak-set? #f (a)) (unary emit-weak-set? a))
|
||||
(($ $primcall 'weak-table? #f (a)) (unary emit-weak-table? a))
|
||||
(($ $primcall 'array? #f (a)) (unary emit-array? a))
|
||||
(($ $primcall 'bitvector? #f (a)) (unary emit-bitvector? a))
|
||||
(($ $primcall 'smob? #f (a)) (unary emit-smob? a))
|
||||
(($ $primcall 'port? #f (a)) (unary emit-port? a))
|
||||
(($ $primcall 'bignum? #f (a)) (unary emit-bignum? a))
|
||||
(($ $primcall 'flonum? #f (a)) (unary emit-flonum? a))
|
||||
(($ $primcall 'compnum? #f (a)) (unary emit-compnum? a))
|
||||
(($ $primcall 'fracnum? #f (a)) (unary emit-fracnum? a))
|
||||
(#('pair? #f (a)) (unary emit-pair? a))
|
||||
(#('struct? #f (a)) (unary emit-struct? a))
|
||||
(#('symbol? #f (a)) (unary emit-symbol? a))
|
||||
(#('variable? #f (a)) (unary emit-variable? a))
|
||||
(#('vector? #f (a)) (unary emit-vector? a))
|
||||
(#('string? #f (a)) (unary emit-string? a))
|
||||
(#('heap-number? #f (a)) (unary emit-heap-number? a))
|
||||
(#('hash-table? #f (a)) (unary emit-hash-table? a))
|
||||
(#('pointer? #f (a)) (unary emit-pointer? a))
|
||||
(#('fluid? #f (a)) (unary emit-fluid? a))
|
||||
(#('stringbuf? #f (a)) (unary emit-stringbuf? a))
|
||||
(#('dynamic-state? #f (a)) (unary emit-dynamic-state? a))
|
||||
(#('frame? #f (a)) (unary emit-frame? a))
|
||||
(#('keyword? #f (a)) (unary emit-keyword? a))
|
||||
(#('atomic-box? #f (a)) (unary emit-atomic-box? a))
|
||||
(#('syntax? #f (a)) (unary emit-syntax? a))
|
||||
(#('program? #f (a)) (unary emit-program? a))
|
||||
(#('vm-continuation? #f (a)) (unary emit-vm-continuation? a))
|
||||
(#('bytevector? #f (a)) (unary emit-bytevector? a))
|
||||
(#('weak-set? #f (a)) (unary emit-weak-set? a))
|
||||
(#('weak-table? #f (a)) (unary emit-weak-table? a))
|
||||
(#('array? #f (a)) (unary emit-array? a))
|
||||
(#('bitvector? #f (a)) (unary emit-bitvector? a))
|
||||
(#('smob? #f (a)) (unary emit-smob? a))
|
||||
(#('port? #f (a)) (unary emit-port? a))
|
||||
(#('bignum? #f (a)) (unary emit-bignum? a))
|
||||
(#('flonum? #f (a)) (unary emit-flonum? a))
|
||||
(#('compnum? #f (a)) (unary emit-compnum? a))
|
||||
(#('fracnum? #f (a)) (unary emit-fracnum? a))
|
||||
;; Binary predicates.
|
||||
(($ $primcall 'eq? #f (a b)) (binary-test emit-eq? a b))
|
||||
(($ $primcall 'heap-numbers-equal? #f (a b))
|
||||
(#('eq? #f (a b)) (binary-test emit-eq? a b))
|
||||
(#('heap-numbers-equal? #f (a b))
|
||||
(binary-test emit-heap-numbers-equal? a b))
|
||||
(($ $primcall '< #f (a b)) (binary-< emit-<? a b))
|
||||
(($ $primcall '<= #f (a b)) (binary-<= emit-<? a b))
|
||||
(($ $primcall '= #f (a b)) (binary-test emit-=? a b))
|
||||
(($ $primcall 'u64-< #f (a b)) (binary-< emit-u64<? a b))
|
||||
(($ $primcall 'u64-imm-< b (a)) (binary-</imm emit-u64-imm<? a b))
|
||||
(($ $primcall 'imm-u64-< b (a)) (binary-</imm emit-imm-u64<? a b))
|
||||
(($ $primcall 'u64-= #f (a b)) (binary-test emit-u64=? a b))
|
||||
(($ $primcall 'u64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
|
||||
(($ $primcall 's64-= #f (a b)) (binary-test emit-u64=? a b))
|
||||
(($ $primcall 's64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
|
||||
(($ $primcall 's64-< #f (a b)) (binary-< emit-s64<? a b))
|
||||
(($ $primcall 's64-imm-< b (a)) (binary-</imm emit-s64-imm<? a b))
|
||||
(($ $primcall 'imm-s64-< b (a)) (binary-</imm emit-imm-s64<? a b))
|
||||
(($ $primcall 'f64-< #f (a b)) (binary-< emit-f64<? a b))
|
||||
(($ $primcall 'f64-<= #f (a b)) (binary-<= emit-f64<? a b))
|
||||
(($ $primcall 'f64-= #f (a b)) (binary-test emit-f64=? a b))))
|
||||
(#('< #f (a b)) (binary-< emit-<? a b))
|
||||
(#('<= #f (a b)) (binary-<= emit-<? a b))
|
||||
(#('= #f (a b)) (binary-test emit-=? a b))
|
||||
(#('u64-< #f (a b)) (binary-< emit-u64<? a b))
|
||||
(#('u64-imm-< b (a)) (binary-</imm emit-u64-imm<? a b))
|
||||
(#('imm-u64-< b (a)) (binary-</imm emit-imm-u64<? a b))
|
||||
(#('u64-= #f (a b)) (binary-test emit-u64=? a b))
|
||||
(#('u64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
|
||||
(#('s64-= #f (a b)) (binary-test emit-u64=? a b))
|
||||
(#('s64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
|
||||
(#('s64-< #f (a b)) (binary-< emit-s64<? a b))
|
||||
(#('s64-imm-< b (a)) (binary-</imm emit-s64-imm<? a b))
|
||||
(#('imm-s64-< b (a)) (binary-</imm emit-imm-s64<? a b))
|
||||
(#('f64-< #f (a b)) (binary-< emit-f64<? a b))
|
||||
(#('f64-<= #f (a b)) (binary-<= emit-f64<? a b))
|
||||
(#('f64-= #f (a b)) (binary-test emit-f64=? a b))))
|
||||
|
||||
(define (compile-trunc label k exp nreq rest-var)
|
||||
(define (do-call proc args emit-call)
|
||||
|
|
@ -599,13 +599,8 @@
|
|||
(compile-value label exp dst)))
|
||||
(maybe-emit-jump))
|
||||
(($ $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)
|
||||
(maybe-emit-jump))))
|
||||
(compile-effect label exp k)
|
||||
(maybe-emit-jump))
|
||||
(($ $kargs names syms)
|
||||
(compile-values label exp syms)
|
||||
(maybe-emit-jump))
|
||||
|
|
@ -620,6 +615,20 @@
|
|||
(unless fallthrough?
|
||||
(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)
|
||||
(match cont
|
||||
(($ $kfun src meta self tail clause)
|
||||
|
|
@ -646,7 +655,7 @@
|
|||
(let ((body (forward-label body)))
|
||||
(unless (= body (skip-elided-conts (1+ label)))
|
||||
(emit-j asm body)))))
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(($ $kargs names vars term)
|
||||
(emit-label asm label)
|
||||
(for-each (lambda (name var)
|
||||
(let ((slot (maybe-slot var)))
|
||||
|
|
@ -654,10 +663,7 @@
|
|||
(let ((repr (lookup-representation var allocation)))
|
||||
(emit-definition asm name slot repr)))))
|
||||
names vars)
|
||||
(when src
|
||||
(emit-source asm src))
|
||||
(unless (elide-cont? label)
|
||||
(compile-expression label k exp)))
|
||||
(compile-term label term))
|
||||
(($ $kreceive arity kargs)
|
||||
(emit-label asm label))
|
||||
(($ $ktail)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; 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))
|
||||
(($ $ktail) (ref0))
|
||||
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
|
||||
(($ $kargs names syms ($ $branch kf kt))
|
||||
(ref2 kf kt))
|
||||
(($ $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))
|
||||
((single multiple) (intmap-fold add-ref conts single multiple)))
|
||||
(intset-subtract (persistent-intset single)
|
||||
|
|
@ -187,12 +191,12 @@ $call, and are always called with a compatible arity."
|
|||
(restrict-arity functions proc (length args))))
|
||||
(($ $callk k proc args)
|
||||
(exclude-vars functions (cons proc args)))
|
||||
(($ $branch kt ($ $primcall name param args))
|
||||
(exclude-vars functions args))
|
||||
(($ $primcall name param args)
|
||||
(exclude-vars functions args))
|
||||
(($ $prompt escape? tag handler)
|
||||
(exclude-var functions tag))))
|
||||
(($ $kargs _ _ ($ $branch kf kt src op param args))
|
||||
(exclude-vars functions args))
|
||||
(_ functions)))
|
||||
(intmap-fold visit-cont conts functions)))
|
||||
|
||||
|
|
@ -451,6 +455,12 @@ function set."
|
|||
(((names vars funs) ...)
|
||||
(continue cps k src (build-exp ($rec names vars funs))))))
|
||||
(_ (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
|
||||
;; equipped to deal with stale $kfun nodes whose bodies have been
|
||||
|
|
@ -460,13 +470,13 @@ function set."
|
|||
(intmap-fold
|
||||
(lambda (label cont out)
|
||||
(match cont
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(($ $kargs names vars term)
|
||||
;; Remove bindings for functions that have been contified.
|
||||
(match (filter (match-lambda ((name var) (not (call-subst var))))
|
||||
(map list names vars))
|
||||
(((names vars) ...)
|
||||
(with-cps out
|
||||
(let$ term (visit-exp k src exp))
|
||||
(let$ term (visit-term term))
|
||||
(setk label ($kargs names vars ,term))))))
|
||||
(_ out)))
|
||||
conts
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; 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)))
|
||||
|
||||
(match (intmap-ref conts label)
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(match exp
|
||||
(($ $branch kt) (propagate-branch k kt))
|
||||
(($ $prompt escape? tag handler) (propagate2 k handler))
|
||||
(_ (propagate1 k))))
|
||||
(($ $kargs names vars term)
|
||||
(match term
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
(($ $prompt escape? tag handler) (propagate2 k handler))
|
||||
(_ (propagate1 k))))
|
||||
(($ $branch kf kt) (propagate-branch kf kt))))
|
||||
(($ $kreceive arity k)
|
||||
(propagate1 k))
|
||||
(($ $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)))
|
||||
(($ $ktail)
|
||||
'())
|
||||
(($ $kargs names vars ($ $continue k))
|
||||
(match (intmap-ref conts k)
|
||||
(($ $kargs names vars) vars)
|
||||
(_ #f)))))
|
||||
(($ $kargs names vars term)
|
||||
(match term
|
||||
(($ $continue k)
|
||||
(match (intmap-ref conts k)
|
||||
(($ $kargs names vars) vars)
|
||||
(_ #f)))
|
||||
(($ $branch)
|
||||
'())))))
|
||||
(compute-function-body conts kfun)))
|
||||
|
||||
(define (compute-singly-referenced succs)
|
||||
|
|
@ -199,23 +205,25 @@ false. It could be that both true and false proofs are available."
|
|||
(() '())
|
||||
((var . vars) (cons (subst-var var-substs var) (lp vars))))))
|
||||
|
||||
(define (compute-exp-key var-substs exp)
|
||||
(match exp
|
||||
(($ $const val) (cons 'const val))
|
||||
(($ $prim name) (cons 'prim name))
|
||||
(($ $fun body) #f)
|
||||
(($ $rec names syms funs) #f)
|
||||
(($ $closure label nfree) #f)
|
||||
(($ $call proc args) #f)
|
||||
(($ $callk k proc args) #f)
|
||||
(($ $primcall name param 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)
|
||||
(($ $prompt escape? tag handler) #f)))
|
||||
(define (compute-term-key var-substs term)
|
||||
(match term
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
(($ $const val) (cons 'const val))
|
||||
(($ $prim name) (cons 'prim name))
|
||||
(($ $fun body) #f)
|
||||
(($ $rec names syms funs) #f)
|
||||
(($ $closure label nfree) #f)
|
||||
(($ $call proc args) #f)
|
||||
(($ $callk k proc args) #f)
|
||||
(($ $primcall name param args)
|
||||
(cons* name param (subst-vars var-substs args)))
|
||||
(($ $values args) #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)
|
||||
(lambda (defs) (subst-vars var-substs defs)))))
|
||||
(define (add-def! aux-key var)
|
||||
|
|
@ -229,7 +237,7 @@ false. It could be that both true and false proofs are available."
|
|||
((add-definitions
|
||||
((def <- op arg ...) (aux <- op* arg* ...) ...)
|
||||
. clauses)
|
||||
(match exp-key
|
||||
(match term-key
|
||||
(('op arg ...)
|
||||
(match defs
|
||||
((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
|
||||
((op arg ...) (aux <- op* arg* ...) ...)
|
||||
. clauses)
|
||||
(match exp-key
|
||||
(match term-key
|
||||
(('op arg ...)
|
||||
(add-def! (list 'op* arg* ...) aux) ...)
|
||||
(_ (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)))))
|
||||
|
||||
(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)
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(match (compute-exp-key var-substs exp)
|
||||
(($ $kargs names vars term)
|
||||
(match (compute-term-key var-substs term)
|
||||
(#f (values equiv-labels var-substs))
|
||||
(exp-key
|
||||
(let* ((equiv (hash-ref equiv-set exp-key '()))
|
||||
(term-key
|
||||
(let* ((equiv (hash-ref equiv-set term-key '()))
|
||||
(fx (intmap-ref effects label))
|
||||
(avail (intmap-ref avail label)))
|
||||
(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
|
||||
;; expressions, so that we can take advantage of
|
||||
;; 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))
|
||||
(let lp ((candidates equiv))
|
||||
(match candidates
|
||||
|
|
@ -310,10 +324,9 @@ false. It could be that both true and false proofs are available."
|
|||
;; allocation case).
|
||||
(when (and (not (causes-effect? fx &allocation))
|
||||
(not (effect-clobbers? fx (&read-object &fluid))))
|
||||
(let ((defs (and (intset-ref singly-referenced k)
|
||||
(intmap-ref defs label))))
|
||||
(let ((defs (term-defs term)))
|
||||
(when defs
|
||||
(hash-set! equiv-set exp-key
|
||||
(hash-set! equiv-set term-key
|
||||
(acons label defs equiv)))))
|
||||
(finish equiv-labels var-substs))
|
||||
(((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
|
||||
;; the vars for substitution.
|
||||
(finish (intmap-add equiv-labels label head)
|
||||
(let ((defs (and (intset-ref singly-referenced k)
|
||||
(intmap-ref defs label))))
|
||||
(let ((defs (term-defs term)))
|
||||
(if defs
|
||||
(fold (lambda (def var var-substs)
|
||||
(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)))
|
||||
(($ $primcall name param args)
|
||||
($primcall name param ,(map subst-var args)))
|
||||
(($ $branch k exp)
|
||||
($branch k ,(visit-exp exp)))
|
||||
(($ $values args)
|
||||
($values ,(map subst-var args)))
|
||||
(($ $prompt escape? tag handler)
|
||||
($prompt escape? (subst-var tag) handler))))
|
||||
|
||||
(define (visit-term label term)
|
||||
(match term
|
||||
(($ $branch kf kt src op param args)
|
||||
(match (intmap-ref equiv-labels label (lambda (_) #f))
|
||||
((equiv) ; A branch defines no values.
|
||||
(let* ((bool (intmap-ref truthy-labels label))
|
||||
(t (intset-ref bool (true-idx equiv)))
|
||||
(f (intset-ref bool (false-idx equiv))))
|
||||
(if (eqv? t f)
|
||||
(build-term
|
||||
($branch kf kt src op param ,(map subst-var args)))
|
||||
(build-term
|
||||
($continue (if t kt kf) src ($values ()))))))
|
||||
(#f
|
||||
(build-term
|
||||
($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
|
||||
(build-term
|
||||
($continue k src ,(visit-exp exp))))))))
|
||||
|
||||
(intmap-map
|
||||
(lambda (label cont)
|
||||
(match cont
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(build-cont
|
||||
($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))
|
||||
(t (intset-ref bool (true-idx equiv)))
|
||||
(f (intset-ref bool (false-idx equiv))))
|
||||
(if (eqv? t f)
|
||||
(build-term
|
||||
($continue k src
|
||||
($branch kt ,(visit-exp exp))))
|
||||
(build-term
|
||||
($continue (if t kt k) src ($values ()))))))
|
||||
(_
|
||||
;; 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
|
||||
($continue k src ($values vars))))))
|
||||
(#f
|
||||
(build-term
|
||||
($continue k src ,(visit-exp exp))))))))
|
||||
(_ cont)))
|
||||
(rewrite-cont cont
|
||||
(($ $kargs names vars term)
|
||||
($kargs names vars ,(visit-term label term)))
|
||||
(_ ,cont)))
|
||||
conts))
|
||||
|
||||
(define (eliminate-common-subexpressions conts)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -80,6 +80,10 @@ sites."
|
|||
(causes-effect? fx &allocation))
|
||||
(values (intset-add! known k) unknown)
|
||||
(values known (intset-add! unknown k)))))
|
||||
(($ $kargs _ _ ($ $branch))
|
||||
;; Branches pass no values to their
|
||||
;; continuations.
|
||||
(values known unknown))
|
||||
(($ $kreceive arity kargs)
|
||||
(values known (intset-add! unknown kargs)))
|
||||
(($ $kfun src meta self tail clause)
|
||||
|
|
@ -151,8 +155,6 @@ sites."
|
|||
(adjoin-vars args (adjoin-var proc live-vars))))
|
||||
(($ $primcall name param args)
|
||||
(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 live-labels
|
||||
(match (cont-defs k)
|
||||
|
|
@ -164,17 +166,6 @@ sites."
|
|||
live-vars args defs)))))))
|
||||
|
||||
(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
|
||||
((intset-ref live-labels label)
|
||||
;; Expression live already.
|
||||
|
|
@ -192,12 +183,6 @@ sites."
|
|||
;; Does it cause a type check, but we weren't able to prove
|
||||
;; that the types 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
|
||||
;; is live or was not created by us, then this expression is
|
||||
;; live. Otherwise the value is still dead.
|
||||
|
|
@ -219,6 +204,32 @@ sites."
|
|||
;; Still dead.
|
||||
(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)
|
||||
;; Visit uses before definitions.
|
||||
(postorder-fold-local-conts2
|
||||
|
|
@ -226,6 +237,8 @@ sites."
|
|||
(match cont
|
||||
(($ $kargs _ _ ($ $continue k src exp))
|
||||
(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)
|
||||
(values live-labels live-vars))
|
||||
(($ $kclause arity kargs kalt)
|
||||
|
|
@ -327,7 +340,13 @@ sites."
|
|||
(values cps term)))))
|
||||
(values cps
|
||||
(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)
|
||||
(match cont
|
||||
(($ $kargs names vars term)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -59,22 +59,24 @@
|
|||
(intmap-fold
|
||||
(lambda (label cont use-counts)
|
||||
(match cont
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(match exp
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec))
|
||||
use-counts)
|
||||
(($ $values args)
|
||||
(add-uses use-counts args))
|
||||
(($ $call proc args)
|
||||
(add-uses (add-use use-counts proc) args))
|
||||
(($ $callk kfun 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)
|
||||
(add-uses use-counts args))
|
||||
(($ $prompt escape? tag handler)
|
||||
(add-use use-counts tag))))
|
||||
(($ $kargs names vars term)
|
||||
(match term
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec))
|
||||
use-counts)
|
||||
(($ $values args)
|
||||
(add-uses use-counts args))
|
||||
(($ $call proc args)
|
||||
(add-uses (add-use use-counts proc) args))
|
||||
(($ $callk kfun proc args)
|
||||
(add-uses (add-use use-counts proc) args))
|
||||
(($ $primcall name param args)
|
||||
(add-uses use-counts args))
|
||||
(($ $prompt escape? tag handler)
|
||||
(add-use use-counts tag))))
|
||||
(($ $branch kf kt src op param args)
|
||||
(add-uses use-counts args))))
|
||||
(_ use-counts)))
|
||||
cps
|
||||
(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
|
||||
;; continuation kinds.
|
||||
(($ $ktail) (fail))
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(($ $kargs names vars term)
|
||||
(let* ((vars-of-interest
|
||||
(if defs-of-interest?
|
||||
(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)
|
||||
(intmap-add fresh-vars var (fresh-var)))
|
||||
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)
|
||||
(map (lambda (arg) (intmap-ref fresh-vars arg (lambda (arg) arg)))
|
||||
args))
|
||||
|
|
@ -142,10 +145,10 @@ the trace should be referenced outside of it."
|
|||
(or-map (lambda (arg) (intset-ref vars-of-interest arg))
|
||||
args))
|
||||
(define (continue k live-vars defs-of-interest? can-terminate-trace?
|
||||
exp)
|
||||
make-term)
|
||||
(define (stitch cps k)
|
||||
(with-cps cps
|
||||
(letk label* ($kargs names vars ($continue k src ,exp)))
|
||||
(letk label* ($kargs names peeled-vars ,(make-term k)))
|
||||
label*))
|
||||
(define (terminate)
|
||||
(stitch cps k))
|
||||
|
|
@ -158,73 +161,71 @@ the trace should be referenced outside of it."
|
|||
((and can-terminate-trace? (eq? live-vars empty-intmap))
|
||||
(terminate))
|
||||
(else (fail))))))))
|
||||
(match exp
|
||||
(($ $const)
|
||||
;; fine.
|
||||
(continue k live-vars #f #f exp))
|
||||
(($ $values args)
|
||||
(let ((live-vars (subtract-uses live-vars args)))
|
||||
(continue k live-vars
|
||||
(any-use-of-interest? args) #f
|
||||
(build-exp ($values ,(rename-uses args))))))
|
||||
(($ $primcall name param args)
|
||||
;; exp is effect-free or var of interest in args
|
||||
(let* ((fx (expression-effects exp))
|
||||
(uses-of-interest? (any-use-of-interest? args))
|
||||
(live-vars (subtract-uses live-vars args)))
|
||||
;; If the primcall uses a value of interest,
|
||||
;; consider it for peeling even if it would cause a
|
||||
;; type check; perhaps the peeling causes the type
|
||||
;; check to go away.
|
||||
(if (or (eqv? fx &no-effects)
|
||||
(and uses-of-interest? (eqv? fx &type-check)))
|
||||
(continue k (subtract-uses live-vars args)
|
||||
;; Primcalls that use values of interest
|
||||
;; define values of interest.
|
||||
uses-of-interest? #t
|
||||
(build-exp
|
||||
($primcall name param ,(rename-uses args))))
|
||||
(fail))))
|
||||
(($ $branch kt ($ $primcall name param args))
|
||||
(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?)
|
||||
(exp (build-exp
|
||||
($primcall name param ,(rename-uses args)))))
|
||||
(peeled-args (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)))))))))
|
||||
(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 vars
|
||||
($continue k src ($branch kt ,exp))))
|
||||
($kargs names peeled-vars
|
||||
($branch kf kt src op param peeled-args)))
|
||||
label*)))))
|
||||
(_ (fail))))))))
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
(($ $const)
|
||||
;; fine.
|
||||
(continue k live-vars #f #f
|
||||
(lambda (k)
|
||||
(build-term ($continue k src ,exp)))))
|
||||
(($ $values 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
|
||||
uses-of-interest? #f
|
||||
(lambda (k)
|
||||
(build-term
|
||||
($continue k src ($values peeled-args)))))))
|
||||
(($ $primcall name param args)
|
||||
;; exp is effect-free or var of interest in args
|
||||
(let* ((fx (expression-effects exp))
|
||||
(uses-of-interest? (any-use-of-interest? args))
|
||||
(live-vars (subtract-uses live-vars args))
|
||||
(peeled-args (rename-uses args)))
|
||||
;; If the primcall uses a value of interest,
|
||||
;; consider it for peeling even if it would cause a
|
||||
;; type check; perhaps the peeling causes the type
|
||||
;; check to go away.
|
||||
(if (or (eqv? fx &no-effects)
|
||||
(and uses-of-interest? (eqv? fx &type-check)))
|
||||
(continue k live-vars
|
||||
;; Primcalls that use values of interest
|
||||
;; define values of interest.
|
||||
uses-of-interest? #t
|
||||
(lambda (k)
|
||||
(build-term
|
||||
($continue k src
|
||||
($primcall name param ,peeled-args)))))
|
||||
(fail))))
|
||||
(_ (fail))))))))))
|
||||
|
||||
(define (peel-traces-in-function cps body use-counts)
|
||||
(intset-fold
|
||||
|
|
@ -232,9 +233,7 @@ the trace should be referenced outside of it."
|
|||
(match (intmap-ref cps label)
|
||||
;; Traces start with a fixnum? predicate. We could expand this
|
||||
;; in the future if we wanted to.
|
||||
(($ $kargs names vars
|
||||
($ $continue kf src
|
||||
($ $branch kt ($ $primcall 'fixnum? #f (x)))))
|
||||
(($ $kargs names vars ($ $branch kf kt src 'fixnum? #f (x)))
|
||||
(with-cps cps
|
||||
(let$ kt (peel-trace kt x kf use-counts))
|
||||
($ ((lambda (cps)
|
||||
|
|
@ -242,8 +241,7 @@ the trace should be referenced outside of it."
|
|||
(with-cps cps
|
||||
(setk label
|
||||
($kargs names vars
|
||||
($continue kf src
|
||||
($branch kt ($primcall 'fixnum? #f (x)))))))
|
||||
($branch kf kt src 'fixnum? #f (x)))))
|
||||
cps))))))
|
||||
(_ cps)))
|
||||
body
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; 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)
|
||||
((or ($ $call) ($ $callk))
|
||||
&all-effects)
|
||||
(($ $branch k exp)
|
||||
(expression-effects exp))
|
||||
(($ $primcall name param args)
|
||||
(primitive-effects param name args))))
|
||||
|
||||
|
|
@ -614,6 +612,8 @@ the LABELS that are clobbered by the effects of LABEL."
|
|||
(match cont
|
||||
(($ $kargs names syms ($ $continue k src exp))
|
||||
(expression-effects exp))
|
||||
(($ $kargs names syms ($ $branch kf kt src op param args))
|
||||
(primitive-effects param op args))
|
||||
(($ $kreceive arity kargs)
|
||||
(match arity
|
||||
(($ $arity _ () #f () #f) &type-check)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -34,12 +34,15 @@
|
|||
#:export (add-handle-interrupts))
|
||||
|
||||
(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)
|
||||
(match cont
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(let ((safepoints (if (<= k label)
|
||||
(intset-add! safepoints k)
|
||||
safepoints)))
|
||||
(let ((safepoints (maybe-add-safepoint label k safepoints)))
|
||||
(if (match exp
|
||||
(($ $call) #t)
|
||||
(($ $callk) #t)
|
||||
|
|
@ -50,18 +53,21 @@
|
|||
(_ #f))
|
||||
(intset-add! safepoints label)
|
||||
safepoints)))
|
||||
(($ $kargs names vars ($ $branch kf kt))
|
||||
(maybe-add-safepoint label kf
|
||||
(maybe-add-safepoint label kt safepoints)))
|
||||
(_ safepoints)))
|
||||
(persistent-intset (intmap-fold visit-cont cps empty-intset)))
|
||||
|
||||
(define (add-handle-interrupts cps)
|
||||
(define (add-safepoint label cps)
|
||||
(match (intmap-ref cps label)
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(($ $kargs names vars term)
|
||||
(with-cps cps
|
||||
(letk k* ($kargs () () ($continue k src ,exp)))
|
||||
(letk k ($kargs () () ,term))
|
||||
(setk label
|
||||
($kargs names vars
|
||||
($continue k* src
|
||||
($continue k #f
|
||||
($primcall 'handle-interrupts #f ()))))))))
|
||||
(let* ((cps (renumber cps))
|
||||
(safepoints (compute-safepoints cps)))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -69,7 +69,6 @@
|
|||
(match exp
|
||||
((or ($ $const) ($ $prim) ($ $closure)) #t)
|
||||
(($ $prompt) #f) ;; ?
|
||||
(($ $branch) #f)
|
||||
(($ $primcall name param args)
|
||||
(and-map (lambda (arg) (not (intset-ref loop-vars arg)))
|
||||
args))
|
||||
|
|
@ -127,93 +126,98 @@
|
|||
pre-header-label pre-header-cont)
|
||||
pre-header-label)))
|
||||
(match cont
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
;; If k is a loop exit, it will be nullary.
|
||||
(($ $kargs names vars term)
|
||||
(let-values (((names vars) (filter-loop-vars names vars)))
|
||||
(match (intmap-ref cps k)
|
||||
(($ $kargs def-names def-vars)
|
||||
(cond
|
||||
((not (loop-invariant? label exp loop-vars loop-effects
|
||||
always-reached?))
|
||||
(let* ((loop-vars (adjoin-loop-vars loop-vars def-vars))
|
||||
(loop-vars (match exp
|
||||
(($ $prompt escape? tag handler)
|
||||
(match (intmap-ref cps handler)
|
||||
(($ $kreceive arity kargs)
|
||||
(match (intmap-ref cps kargs)
|
||||
(($ $kargs names vars)
|
||||
(adjoin-loop-vars loop-vars vars))))))
|
||||
(_ loop-vars)))
|
||||
(cont (build-cont
|
||||
($kargs names vars
|
||||
($continue k src ,exp))))
|
||||
(always-reached?
|
||||
(and always-reached?
|
||||
(match exp
|
||||
(($ $branch) #f)
|
||||
(_ (not (causes-effect? (intmap-ref loop-effects label)
|
||||
&type-check)))))))
|
||||
(values cps cont loop-vars loop-effects
|
||||
pre-header-label always-reached?)))
|
||||
((trivial-intset (intmap-ref preds k))
|
||||
(let-values
|
||||
(((cps pre-header-label)
|
||||
(hoist-exp src exp def-names def-vars pre-header-label))
|
||||
((cont) (build-cont
|
||||
($kargs names vars
|
||||
($continue k src ($values ()))))))
|
||||
(values cps cont loop-vars (intmap-remove loop-effects label)
|
||||
pre-header-label always-reached?)))
|
||||
(else
|
||||
(let*-values
|
||||
(((def-names def-vars)
|
||||
(match (intmap-ref cps k)
|
||||
(($ $kargs names vars) (values names vars))))
|
||||
((loop-vars) (adjoin-loop-vars loop-vars def-vars))
|
||||
((fresh-vars) (map (lambda (_) (fresh-var)) def-vars))
|
||||
((cps pre-header-label)
|
||||
(hoist-exp src exp def-names fresh-vars pre-header-label))
|
||||
((cont) (build-cont
|
||||
($kargs names vars
|
||||
($continue k src ($values fresh-vars))))))
|
||||
(values cps cont loop-vars (intmap-remove loop-effects label)
|
||||
pre-header-label always-reached?)))))
|
||||
(($ $kreceive ($ $arity req () rest) kargs)
|
||||
(match (intmap-ref cps kargs)
|
||||
(match term
|
||||
(($ $continue k src exp)
|
||||
;; If k is a loop exit, it will be nullary.
|
||||
(match (intmap-ref cps k)
|
||||
(($ $kargs def-names def-vars)
|
||||
(cond
|
||||
((not (loop-invariant? label exp loop-vars loop-effects
|
||||
always-reached?))
|
||||
(let* ((loop-vars (adjoin-loop-vars loop-vars def-vars))
|
||||
(loop-vars (match exp
|
||||
(($ $prompt escape? tag handler)
|
||||
(match (intmap-ref cps handler)
|
||||
(($ $kreceive arity kargs)
|
||||
(match (intmap-ref cps kargs)
|
||||
(($ $kargs names vars)
|
||||
(adjoin-loop-vars loop-vars vars))))))
|
||||
(_ loop-vars)))
|
||||
(cont (build-cont
|
||||
($kargs names vars
|
||||
($continue k src ,exp)))))
|
||||
(values cps cont loop-vars loop-effects pre-header-label #f)))
|
||||
($continue k src ,exp))))
|
||||
(always-reached?
|
||||
(and always-reached?
|
||||
(not (causes-effect? (intmap-ref loop-effects label)
|
||||
&type-check)))))
|
||||
(values cps cont loop-vars loop-effects
|
||||
pre-header-label always-reached?)))
|
||||
((trivial-intset (intmap-ref preds k))
|
||||
(let ((loop-effects
|
||||
(intmap-remove (intmap-remove loop-effects label) k)))
|
||||
(let-values
|
||||
(((cps pre-header-label)
|
||||
(hoist-call src exp req rest def-names def-vars
|
||||
pre-header-label))
|
||||
((cont) (build-cont
|
||||
($kargs names vars
|
||||
($continue kargs src ($values ()))))))
|
||||
(values cps cont loop-vars loop-effects
|
||||
pre-header-label always-reached?))))
|
||||
(else
|
||||
(let*-values
|
||||
(((loop-vars) (adjoin-loop-vars loop-vars def-vars))
|
||||
((fresh-vars) (map (lambda (_) (fresh-var)) def-vars))
|
||||
((cps pre-header-label)
|
||||
(hoist-call src exp req rest def-names fresh-vars
|
||||
pre-header-label))
|
||||
(let-values
|
||||
(((cps pre-header-label)
|
||||
(hoist-exp src exp def-names def-vars pre-header-label))
|
||||
((cont) (build-cont
|
||||
($kargs names vars
|
||||
($continue kargs src
|
||||
($values fresh-vars))))))
|
||||
(values cps cont loop-vars loop-effects
|
||||
pre-header-label always-reached?))))))))))
|
||||
($continue k src ($values ()))))))
|
||||
(values cps cont loop-vars (intmap-remove loop-effects label)
|
||||
pre-header-label always-reached?)))
|
||||
(else
|
||||
(let*-values
|
||||
(((def-names def-vars)
|
||||
(match (intmap-ref cps k)
|
||||
(($ $kargs names vars) (values names vars))))
|
||||
((loop-vars) (adjoin-loop-vars loop-vars def-vars))
|
||||
((fresh-vars) (map (lambda (_) (fresh-var)) def-vars))
|
||||
((cps pre-header-label)
|
||||
(hoist-exp src exp def-names fresh-vars pre-header-label))
|
||||
((cont) (build-cont
|
||||
($kargs names vars
|
||||
($continue k src ($values fresh-vars))))))
|
||||
(values cps cont loop-vars (intmap-remove loop-effects label)
|
||||
pre-header-label always-reached?)))))
|
||||
(($ $kreceive ($ $arity req () rest) kargs)
|
||||
(match (intmap-ref cps kargs)
|
||||
(($ $kargs def-names def-vars)
|
||||
(cond
|
||||
((not (loop-invariant? label exp loop-vars loop-effects
|
||||
always-reached?))
|
||||
(let* ((loop-vars (adjoin-loop-vars loop-vars def-vars))
|
||||
(cont (build-cont
|
||||
($kargs names vars
|
||||
($continue k src ,exp)))))
|
||||
(values cps cont loop-vars loop-effects pre-header-label #f)))
|
||||
((trivial-intset (intmap-ref preds k))
|
||||
(let ((loop-effects
|
||||
(intmap-remove (intmap-remove loop-effects label) k)))
|
||||
(let-values
|
||||
(((cps pre-header-label)
|
||||
(hoist-call src exp req rest def-names def-vars
|
||||
pre-header-label))
|
||||
((cont) (build-cont
|
||||
($kargs names vars
|
||||
($continue kargs src ($values ()))))))
|
||||
(values cps cont loop-vars loop-effects
|
||||
pre-header-label always-reached?))))
|
||||
(else
|
||||
(let*-values
|
||||
(((loop-vars) (adjoin-loop-vars loop-vars def-vars))
|
||||
((fresh-vars) (map (lambda (_) (fresh-var)) def-vars))
|
||||
((cps pre-header-label)
|
||||
(hoist-call src exp req rest def-names fresh-vars
|
||||
pre-header-label))
|
||||
((cont) (build-cont
|
||||
($kargs names vars
|
||||
($continue kargs src
|
||||
($values fresh-vars))))))
|
||||
(values cps cont loop-vars loop-effects
|
||||
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)
|
||||
(values cps cont loop-vars loop-effects pre-header-label
|
||||
always-reached?))))
|
||||
|
|
@ -252,9 +256,9 @@
|
|||
(define (rename-back-edges cont)
|
||||
(define (rename label) (if (eqv? label entry) header-label label))
|
||||
(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
|
||||
($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 (rename k) src ,exp)))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -141,16 +141,20 @@
|
|||
($call (rename-var proc) ,(map rename-var args)))
|
||||
(($ $callk k proc 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 ,(map rename-var args)))
|
||||
(($ $prompt escape? tag 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
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
($kargs names (map rename-var vars)
|
||||
($continue (rename-label k) src ,(rename-exp exp))))
|
||||
(($ $kargs names vars term)
|
||||
($kargs names (map rename-var vars) ,(rename-term term)))
|
||||
(($ $kreceive ($ $arity req () rest) kargs)
|
||||
($kreceive req rest (rename-label kargs)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -384,8 +384,7 @@
|
|||
($continue krecv src ($call proc args))))
|
||||
(let$ body (resolve-prim name kproc src))
|
||||
(setk label ($kargs names vars ,body))))))
|
||||
(($ $kargs names vars
|
||||
($ $continue kf src ($ $branch kt ($ $primcall name param args))))
|
||||
(($ $kargs names vars ($ $branch kf kt src name param args))
|
||||
(let ()
|
||||
(define (u11? val) (<= 0 val #x7ff))
|
||||
(define (u12? val) (<= 0 val #xfff))
|
||||
|
|
@ -404,8 +403,7 @@
|
|||
(letv c)
|
||||
(letk kconst
|
||||
($kargs ('c) (c)
|
||||
($continue kf src
|
||||
($branch kt ($primcall 'op* #f (out ...))))))
|
||||
($branch kf kt src 'op* #f (out ...))))
|
||||
(setk label
|
||||
($kargs names vars
|
||||
($continue kconst src
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -85,16 +85,18 @@
|
|||
(call-with-values
|
||||
(lambda ()
|
||||
(match (intmap-ref conts k)
|
||||
(($ $kargs names syms ($ $continue k src exp))
|
||||
(match exp
|
||||
(($ $prompt escape? tag handler)
|
||||
(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))))
|
||||
(($ $kargs names syms term)
|
||||
(match term
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
(($ $prompt escape? tag handler)
|
||||
(visit2 k handler 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))
|
||||
(($ $kclause arity kbody kalt)
|
||||
(if kalt
|
||||
|
|
@ -177,8 +179,6 @@
|
|||
($call (rename-var proc) ,(map rename-var args)))
|
||||
(($ $callk k proc 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 ,(map rename-var args)))
|
||||
(($ $prompt escape? tag handler)
|
||||
|
|
@ -200,18 +200,23 @@
|
|||
out
|
||||
new-k
|
||||
(rewrite-cont (intmap-ref conts old-k)
|
||||
(($ $kargs names syms ($ $continue k src exp))
|
||||
($kargs names (map rename-var syms)
|
||||
($continue (rename-label k) src ,(rename-exp exp))))
|
||||
(($ $kreceive ($ $arity req () rest () #f) k)
|
||||
($kreceive req rest (rename-label k)))
|
||||
(($ $ktail)
|
||||
($ktail))
|
||||
(($ $kfun src meta self tail clause)
|
||||
($kfun src meta (rename-var self) (rename-label tail)
|
||||
(and clause (rename-label clause))))
|
||||
(($ $kclause arity body alternate)
|
||||
($kclause ,(rename-arity arity) (rename-label body)
|
||||
(and alternate (rename-label alternate)))))))
|
||||
(($ $kargs names syms term)
|
||||
($kargs names (map rename-var syms)
|
||||
,(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 req rest (rename-label k)))
|
||||
(($ $ktail)
|
||||
($ktail))
|
||||
(($ $kfun src meta self tail clause)
|
||||
($kfun src meta (rename-var self) (rename-label tail)
|
||||
(and clause (rename-label clause))))
|
||||
(($ $kclause arity body alternate)
|
||||
($kclause ,(rename-arity arity) (rename-label body)
|
||||
(and alternate (rename-label alternate)))))))
|
||||
label-map
|
||||
empty-intmap))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -55,6 +55,7 @@
|
|||
#:use-module (language cps utils)
|
||||
#:use-module (language cps intmap)
|
||||
#:use-module (language cps intset)
|
||||
#:use-module (language cps with-cps)
|
||||
#:export (rotate-loops))
|
||||
|
||||
(define (loop-successors scc succs)
|
||||
|
|
@ -79,7 +80,8 @@
|
|||
(match (intmap-ref cps entry-label)
|
||||
((and entry-cont
|
||||
($ $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))
|
||||
(loop-exits (find-exits body-labels succs))
|
||||
(exit (if exit-if-true? entry-kt entry-kf))
|
||||
|
|
@ -93,49 +95,50 @@
|
|||
(map (lambda (_) (fresh-var)) entry-vars))
|
||||
(define (make-trampoline k src values)
|
||||
(build-cont ($kargs () () ($continue k src ($values values)))))
|
||||
(define (replace-exit k trampoline)
|
||||
(if (eqv? k exit) trampoline k))
|
||||
(define (rename-exp exp vars)
|
||||
(define (rename-var var)
|
||||
(match (list-index entry-vars var)
|
||||
(#f var)
|
||||
(idx (list-ref vars idx))))
|
||||
(rewrite-exp exp
|
||||
((or ($ $const) ($ $prim) ($ $closure)) ,exp)
|
||||
(($ $values args)
|
||||
($values ,(map rename-var args)))
|
||||
(($ $call proc args)
|
||||
($call (rename-var proc) ,(map rename-var args)))
|
||||
(($ $callk k proc args)
|
||||
($callk k (rename-var proc) ,(map rename-var args)))
|
||||
(($ $branch kt ($ $primcall name param args))
|
||||
($branch kt ($primcall name param ,(map rename-var args))))
|
||||
(($ $primcall name param args)
|
||||
($primcall name param ,(map rename-var args)))
|
||||
(($ $prompt escape? tag handler)
|
||||
($prompt escape? (rename-var tag) handler))))
|
||||
(define (attach-trampoline label src names vars args)
|
||||
(let* ((trampoline-out-label (fresh-label))
|
||||
(trampoline-out-cont
|
||||
(make-trampoline join-label src args))
|
||||
(trampoline-in-label (fresh-label))
|
||||
(trampoline-in-cont
|
||||
(make-trampoline new-entry-label src args))
|
||||
(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
|
||||
($continue kf entry-src
|
||||
($branch kt ,(rename-exp entry-exp args))))))
|
||||
(cps (intmap-replace! cps label cont))
|
||||
(cps (intmap-add! cps trampoline-in-label trampoline-in-cont)))
|
||||
(intmap-add! cps trampoline-out-label trampoline-out-cont)))
|
||||
(define (rename-var var replacements)
|
||||
"If VAR refers to a member of ENTRY-VARS, replace with a
|
||||
corresponding var from REPLACEMENTS; otherwise return VAR."
|
||||
(match (list-index entry-vars var)
|
||||
(#f var)
|
||||
(idx (list-ref replacements idx))))
|
||||
(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)
|
||||
(($ $values args)
|
||||
($values ,(rename* args)))
|
||||
(($ $call proc args)
|
||||
($call (rename proc) ,(rename* args)))
|
||||
(($ $callk k proc args)
|
||||
($callk k (rename proc) ,(rename* args)))
|
||||
(($ $primcall name param args)
|
||||
($primcall name param ,(rename* args)))
|
||||
(($ $prompt escape? tag handler)
|
||||
($prompt escape? (rename tag) handler)))))
|
||||
(($ $branch kf kt src op param args)
|
||||
($branch kf kt src op param ,(rename* args)))))
|
||||
(define (attach-trampoline cps label src names vars args)
|
||||
(with-cps cps
|
||||
(letk ktramp-out ,(make-trampoline join-label src args))
|
||||
(letk ktramp-in ,(make-trampoline new-entry-label src args))
|
||||
(setk label
|
||||
($kargs names vars
|
||||
($branch (if exit-if-true? ktramp-in ktramp-out)
|
||||
(if exit-if-true? ktramp-out ktramp-in)
|
||||
entry-src
|
||||
entry-op entry-param ,(rename-vars entry-args args))))))
|
||||
;; Rewrite the targets of the entry branch to go to
|
||||
;; trampolines. One will pass values out of the loop, and
|
||||
;; one will pass values into the loop.
|
||||
(let* ((pre-header-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
|
||||
pre-header-vars))
|
||||
(new-entry-cont (build-cont
|
||||
|
|
@ -148,44 +151,38 @@
|
|||
(cond
|
||||
((intset-ref back-edges label)
|
||||
(match (intmap-ref cps label)
|
||||
(($ $kargs names vars ($ $continue _ src exp))
|
||||
(match (rename-exp exp body-vars)
|
||||
(($ $values args)
|
||||
(attach-trampoline label src names vars args))
|
||||
(exp
|
||||
(($ $kargs names vars term)
|
||||
(match (rename-term term body-vars)
|
||||
(($ $continue _ src ($ $values args))
|
||||
(attach-trampoline cps label src names vars args))
|
||||
(($ $continue _ src exp)
|
||||
(let* ((args (make-fresh-vars))
|
||||
(bind-label (fresh-label))
|
||||
(edge* (build-cont
|
||||
($kargs names vars
|
||||
($continue bind-label src ,exp))))
|
||||
(cps (intmap-replace! cps label edge*))
|
||||
;; attach-trampoline uses intmap-replace!.
|
||||
;; attach-trampoline uses setk.
|
||||
(cps (intmap-add! cps bind-label #f)))
|
||||
(attach-trampoline bind-label src
|
||||
(attach-trampoline cps bind-label src
|
||||
entry-names args args)))))))
|
||||
((intset-ref loop-exits label)
|
||||
(match (intmap-ref cps label)
|
||||
(($ $kargs names vars
|
||||
($ $continue kf src ($ $branch kt exp)))
|
||||
(let* ((trampoline-out-label (fresh-label))
|
||||
(trampoline-out-cont
|
||||
(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
|
||||
($continue kf src
|
||||
($branch kt ,(rename-exp exp body-vars))))))
|
||||
(cps (intmap-replace! cps label cont)))
|
||||
(intmap-add! cps trampoline-out-label trampoline-out-cont)))))
|
||||
(($ $kargs names vars ($ $branch kf kt src op param args))
|
||||
(with-cps cps
|
||||
(letk ktramp-out ,(make-trampoline join-label src body-vars))
|
||||
(setk label
|
||||
($kargs names vars
|
||||
($branch (if (eqv? kf exit) ktramp-out kf)
|
||||
(if (eqv? kt exit) ktramp-out kt)
|
||||
src
|
||||
op param ,(rename-vars args body-vars))))))))
|
||||
(else
|
||||
(match (intmap-ref cps label)
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(let ((cont (build-cont
|
||||
($kargs names vars
|
||||
($continue k src
|
||||
,(rename-exp exp body-vars))))))
|
||||
(intmap-replace! cps label cont)))
|
||||
(($ $kargs names vars term)
|
||||
(with-cps cps
|
||||
(setk label ($kargs names vars
|
||||
,(rename-term term body-vars)))))
|
||||
(($ $kreceive) cps)))))
|
||||
(intset-remove body-labels entry-label)
|
||||
cps))))))
|
||||
|
|
@ -195,10 +192,8 @@
|
|||
(intset-fold (lambda (label rotate?)
|
||||
(match (intmap-ref cps label)
|
||||
(($ $kreceive) #f)
|
||||
(($ $kargs _ _ ($ $continue _ _ exp))
|
||||
(match exp
|
||||
(($ $branch) #f)
|
||||
(_ rotate?)))))
|
||||
(($ $kargs _ _ ($ $branch)) #f)
|
||||
(($ $kargs _ _ ($ $continue)) rotate?)))
|
||||
edges #t))
|
||||
(let* ((succs (compute-successors cps kfun))
|
||||
(preds (invert-graph succs)))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -36,42 +36,42 @@
|
|||
(define (subst var)
|
||||
(intmap-ref env var (lambda (var) var)))
|
||||
|
||||
(define (rename-exp label cps names vars k src exp)
|
||||
(let ((exp (rewrite-exp exp
|
||||
((or ($ $const) ($ $prim)) ,exp)
|
||||
(($ $call proc args)
|
||||
($call (subst proc) ,(map subst args)))
|
||||
(($ $callk k proc args)
|
||||
($callk k (subst proc) ,(map subst args)))
|
||||
(($ $primcall name param args)
|
||||
($primcall name param ,(map subst args)))
|
||||
(($ $branch k ($ $primcall name param args))
|
||||
($branch k ($primcall name param ,(map subst args))))
|
||||
(($ $values args)
|
||||
($values ,(map subst args)))
|
||||
(($ $prompt escape? tag handler)
|
||||
($prompt escape? (subst tag) handler)))))
|
||||
(intmap-replace! cps label
|
||||
(build-cont
|
||||
($kargs names vars ($continue k src ,exp))))))
|
||||
(define (rename-exp exp)
|
||||
(rewrite-exp exp
|
||||
((or ($ $const) ($ $prim)) ,exp)
|
||||
(($ $call proc args)
|
||||
($call (subst proc) ,(map subst args)))
|
||||
(($ $callk k proc args)
|
||||
($callk k (subst proc) ,(map subst args)))
|
||||
(($ $primcall name param args)
|
||||
($primcall name param ,(map subst args)))
|
||||
(($ $values args)
|
||||
($values ,(map subst args)))
|
||||
(($ $prompt escape? tag handler)
|
||||
($prompt escape? (subst tag) handler))))
|
||||
|
||||
(define (visit-exp cps label names vars k src exp)
|
||||
(match exp
|
||||
(($ $fun label)
|
||||
(define (rename-term term)
|
||||
(rewrite-term term
|
||||
(($ $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))
|
||||
(($ $rec names vars (($ $fun labels) ...))
|
||||
(($ $kargs _ _ ($ $continue k src
|
||||
($ $rec names vars (($ $fun labels) ...))))
|
||||
(fold (lambda (label var cps)
|
||||
(match (intmap-ref cps label)
|
||||
(($ $kfun src meta self)
|
||||
(resolve-self-references cps label
|
||||
(intmap-add env var self)))))
|
||||
cps labels vars))
|
||||
(_ (rename-exp label cps names vars k src exp))))
|
||||
(($ $kargs names vars term)
|
||||
(intmap-replace! cps label
|
||||
(build-cont ($kargs names vars ,(rename-term term)))))
|
||||
(_ cps)))
|
||||
|
||||
(intset-fold (lambda (label cps)
|
||||
(match (intmap-ref cps label)
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(visit-exp cps label names vars k src exp))
|
||||
(_ cps)))
|
||||
(compute-function-body cps label)
|
||||
cps))
|
||||
(intset-fold visit-label (compute-function-body cps label) cps))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -78,10 +78,10 @@
|
|||
(ref* args))
|
||||
(($ $values args)
|
||||
(ref* args))
|
||||
(($ $branch kt ($ $primcall name param args))
|
||||
(ref* args))
|
||||
(($ $prompt escape? tag handler)
|
||||
(ref tag))))
|
||||
(($ $kargs _ _ ($ $branch kf kt src op param args))
|
||||
(ref* args))
|
||||
(_
|
||||
(values single multiple))))
|
||||
(let*-values (((single multiple) (values empty-intset empty-intset))
|
||||
|
|
@ -144,15 +144,15 @@
|
|||
(lambda (label cont)
|
||||
(and (not (intset-ref label-set label))
|
||||
(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
|
||||
($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)))
|
||||
,(match (intmap-ref conts k)
|
||||
(($ $kargs (_)
|
||||
((? (lambda (var) (intset-ref singly-used var))
|
||||
var))
|
||||
($ $continue kf _ ($ $branch kt ($ $primcall 'false? #f (var)))))
|
||||
($ $branch kf kt _ 'false? #f (var)))
|
||||
(build-cont
|
||||
($kargs names syms
|
||||
($continue (subst (if val kf kt)) src ($values ())))))
|
||||
|
|
@ -189,7 +189,11 @@
|
|||
(($ $ktail) (ref0))
|
||||
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
|
||||
(($ $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))
|
||||
((single multiple) (intset-fold add-ref body single multiple)))
|
||||
(intset-subtract (persistent-intset single)
|
||||
|
|
@ -235,35 +239,37 @@
|
|||
(match (intmap-ref var-map var (lambda (_) #f))
|
||||
(#f var)
|
||||
(val (subst val))))
|
||||
(define (transform-exp label k src exp)
|
||||
(define (transform-term label term)
|
||||
(if (intset-ref label-set label)
|
||||
(match (intmap-ref conts k)
|
||||
(($ $kargs _ _ ($ $continue k* src* exp*))
|
||||
(transform-exp k k* src* exp*)))
|
||||
(build-term
|
||||
($continue k src
|
||||
,(rewrite-exp exp
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
|
||||
,exp)
|
||||
(($ $call proc args)
|
||||
($call (subst proc) ,(map subst args)))
|
||||
(($ $callk k proc args)
|
||||
($callk k (subst proc) ,(map subst args)))
|
||||
(($ $primcall name param args)
|
||||
($primcall name param ,(map subst args)))
|
||||
(($ $values 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? (subst tag) handler)))))))
|
||||
(match term
|
||||
(($ $continue k)
|
||||
(match (intmap-ref conts k)
|
||||
(($ $kargs _ _ term)
|
||||
(transform-term k term)))))
|
||||
(rewrite-term term
|
||||
(($ $continue k src exp)
|
||||
($continue k src
|
||||
,(rewrite-exp exp
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
|
||||
,exp)
|
||||
(($ $call proc args)
|
||||
($call (subst proc) ,(map subst args)))
|
||||
(($ $callk k proc args)
|
||||
($callk k (subst proc) ,(map subst args)))
|
||||
(($ $primcall name param args)
|
||||
($primcall name param ,(map subst args)))
|
||||
(($ $values args)
|
||||
($values ,(map subst args)))
|
||||
(($ $prompt escape? 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
|
||||
(lambda (label cont)
|
||||
(match cont
|
||||
(($ $kargs names syms ($ $continue k src exp))
|
||||
(build-cont
|
||||
($kargs names syms ,(transform-exp label k src exp))))
|
||||
(_ cont)))
|
||||
(rewrite-cont cont
|
||||
(($ $kargs names syms term)
|
||||
($kargs names syms ,(transform-term label term)))
|
||||
(_ ,cont)))
|
||||
conts)))
|
||||
|
||||
(define (simplify conts)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;; 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
|
||||
;;;; 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)))
|
||||
(($ $primcall name param args)
|
||||
(return (get-defs k) (vars->intset args)))
|
||||
(($ $branch kt ($ $primcall name param args))
|
||||
(return empty-intset (vars->intset args)))
|
||||
(($ $values args)
|
||||
(return (get-defs k) (vars->intset args)))
|
||||
(($ $prompt escape? tag handler)
|
||||
(return empty-intset (intset tag)))))
|
||||
(($ $kargs _ _ ($ $branch kf kt src op param args))
|
||||
(return empty-intset (vars->intset args)))
|
||||
(($ $kclause arity body alt)
|
||||
(return (get-defs body) empty-intset))
|
||||
(($ $kreceive arity kargs)
|
||||
|
|
@ -238,10 +238,10 @@ body continuation in the prompt."
|
|||
(visit-cont handler level (visit-cont k (1+ level) labels)))
|
||||
(($ $kargs names syms ($ $continue k src ($ $primcall 'unwind)))
|
||||
(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))
|
||||
(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)
|
||||
(let ((body (compute-prompt-body 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)))
|
||||
(define (measure-cont label cont size)
|
||||
(match cont
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(($ $kargs names vars term)
|
||||
(let ((size (max-size* vars size)))
|
||||
(match exp
|
||||
(($ $call proc args)
|
||||
(match term
|
||||
(($ $continue _ _ ($ $call proc args))
|
||||
(call-size label (1+ (length args)) size))
|
||||
(($ $callk _ proc args)
|
||||
(($ $continue _ _ ($ $callk _ proc args))
|
||||
(call-size label (1+ (length args)) size))
|
||||
(($ $values args)
|
||||
(($ $continue _ _ ($ $values args))
|
||||
(shuffle-size (get-shuffles label) size))
|
||||
(_ size))))
|
||||
(($ $kreceive)
|
||||
|
|
@ -744,6 +744,8 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
(intmap-fold
|
||||
(lambda (label cont representations)
|
||||
(match cont
|
||||
(($ $kargs _ _ ($ $branch))
|
||||
representations)
|
||||
(($ $kargs _ _ ($ $continue k _ exp))
|
||||
(match (get-defs k)
|
||||
(() representations)
|
||||
|
|
@ -970,16 +972,16 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
|
||||
(define (allocate-cont label cont slots call-allocs)
|
||||
(match cont
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(($ $kargs names vars term)
|
||||
(let-values (((slots live) (allocate-defs label vars slots)))
|
||||
(match exp
|
||||
(($ $call proc args)
|
||||
(match term
|
||||
(($ $continue k src ($ $call proc args))
|
||||
(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))
|
||||
(($ $values args)
|
||||
(($ $continue k src ($ $values args))
|
||||
(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))
|
||||
(_
|
||||
(values slots call-allocs)))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; 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)
|
||||
(with-cps cps
|
||||
(letv a* b*)
|
||||
(letk kop ($kargs ('b) (b*)
|
||||
($continue kf src
|
||||
($branch kt ($primcall op #f (a* b*))))))
|
||||
(letk kop ($kargs ('b) (b*) ($branch kf kt src op #f (a* b*))))
|
||||
(let$ unbox-b-body (unbox-b kop src b))
|
||||
(letk kunbox-b ($kargs ('a) (a*) ,unbox-b-body))
|
||||
($ (unbox-a kunbox-b src a))))
|
||||
|
|
@ -157,9 +155,7 @@
|
|||
unbox-a)
|
||||
(with-cps cps
|
||||
(letv ia)
|
||||
(letk kop ($kargs ('ia) (ia)
|
||||
($continue kf src
|
||||
($branch kt ($primcall op imm (ia))))))
|
||||
(letk kop ($kargs ('ia) (ia) ($branch kf kt src op imm (ia))))
|
||||
($ (unbox-a kop src a))))
|
||||
|
||||
(define (specialize-comparison/s64-integer cps kf kt src op a-s64 b-int
|
||||
|
|
@ -168,23 +164,19 @@
|
|||
(with-cps cps
|
||||
(letv a b sunk)
|
||||
(letk kheap ($kargs ('sunk) (sunk)
|
||||
($continue kf src
|
||||
($branch kt ($primcall op #f (sunk b-int))))))
|
||||
($branch kf kt src op #f (sunk b-int))))
|
||||
;; Re-box the variable. FIXME: currently we use a specially
|
||||
;; marked s64->scm to avoid CSE from hoisting the allocation
|
||||
;; again. Instead we should just use a-s64 directly and implement
|
||||
;; an allocation sinking pass that should handle this..
|
||||
(let$ rebox-a-body (rebox-a kheap src a))
|
||||
(letk kretag ($kargs () () ,rebox-a-body))
|
||||
(letk kb ($kargs ('b) (b)
|
||||
($continue kf src
|
||||
($branch kt ($primcall s64-op #f (a b))))))
|
||||
(letk kb ($kargs ('b) (b) ($branch kf kt src s64-op #f (a b))))
|
||||
(letk kfix ($kargs () ()
|
||||
($continue kb src
|
||||
($primcall 'untag-fixnum #f (b-int)))))
|
||||
(letk ka ($kargs ('a) (a)
|
||||
($continue kretag src
|
||||
($branch kfix ($primcall 'fixnum? #f (b-int))))))
|
||||
($branch kretag kfix src 'fixnum? #f (b-int))))
|
||||
($ (unbox-a ka src a-s64)))))
|
||||
|
||||
(define (specialize-comparison/integer-s64 cps kf kt src op a-int b-s64
|
||||
|
|
@ -196,8 +188,7 @@
|
|||
(with-cps cps
|
||||
(letv a b sunk)
|
||||
(letk kheap ($kargs ('sunk) (sunk)
|
||||
($continue kf src
|
||||
($branch kt ($primcall '< #f (a-int sunk))))))
|
||||
($branch kf kt src '< #f (a-int sunk))))
|
||||
;; FIXME: We should just use b-s64 directly and implement an
|
||||
;; allocation sinking pass so that the box op that creates b-64
|
||||
;; should float down here. Instead, for now we just rebox the
|
||||
|
|
@ -205,25 +196,19 @@
|
|||
;; CSE.
|
||||
(let$ rebox-b-body (rebox-b kheap src b))
|
||||
(letk kretag ($kargs () () ,rebox-b-body))
|
||||
(letk ka ($kargs ('a) (a)
|
||||
($continue kf src
|
||||
($branch kt ($primcall 's64-< #f (a b))))))
|
||||
(letk ka ($kargs ('a) (a) ($branch kf kt src 's64-< #f (a b))))
|
||||
(letk kfix ($kargs () ()
|
||||
($continue ka src
|
||||
($primcall 'untag-fixnum #f (a-int)))))
|
||||
(letk kb ($kargs ('b) (b)
|
||||
($continue kretag src
|
||||
($branch kfix ($primcall 'fixnum? #f (a-int))))))
|
||||
($branch kretag kfix src 'fixnum? #f (a-int))))
|
||||
($ (unbox-b kb src b-s64))))))
|
||||
|
||||
(define (specialize-comparison/immediate-s64-integer cps kf kt src op a b-int
|
||||
compare-integers)
|
||||
(with-cps cps
|
||||
(letv b sunk)
|
||||
(let$ sunk-compare-exp (compare-integers sunk))
|
||||
(letk kheap ($kargs ('sunk) (sunk)
|
||||
($continue kf src
|
||||
($branch kt ,sunk-compare-exp))))
|
||||
(letk kheap ($kargs ('sunk) (sunk) ,(compare-integers kf kt src sunk)))
|
||||
;; Re-box the variable. FIXME: currently we use a specially marked
|
||||
;; load-const to avoid CSE from hoisting the constant. Instead we
|
||||
;; should just use a $const directly and implement an allocation
|
||||
|
|
@ -232,14 +217,11 @@
|
|||
($continue kheap src
|
||||
($primcall 'load-const/unlikely a ()))))
|
||||
(letk kb ($kargs ('b) (b)
|
||||
($continue kf src
|
||||
($branch kt ($primcall op a (b))))))
|
||||
($branch kf kt src op a (b))))
|
||||
(letk kfix ($kargs () ()
|
||||
($continue kb src
|
||||
($primcall 'untag-fixnum #f (b-int)))))
|
||||
(build-term
|
||||
($continue kretag src
|
||||
($branch kfix ($primcall 'fixnum? #f (b-int)))))))
|
||||
(build-term ($branch kretag kfix src 'fixnum? #f (b-int)))))
|
||||
|
||||
(define (sigbits-union x y)
|
||||
(and x y (logior x y)))
|
||||
|
|
@ -324,38 +306,40 @@ BITS indicating the significant bits needed for a variable. BITS may be
|
|||
(match (intmap-ref cps label)
|
||||
(($ $kfun src meta self)
|
||||
(add-def out self))
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(($ $kargs names vars term)
|
||||
(let ((out (add-defs out vars)))
|
||||
(match exp
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec))
|
||||
;; No uses, so no info added to sigbits.
|
||||
out)
|
||||
(($ $values args)
|
||||
(match (intmap-ref cps k)
|
||||
(($ $kargs _ vars)
|
||||
(if (intset-ref visited k)
|
||||
(fold (lambda (arg var out)
|
||||
(intmap-add out arg (intmap-ref out var)
|
||||
sigbits-union))
|
||||
out args vars)
|
||||
out))
|
||||
(($ $ktail)
|
||||
(add-unknown-uses out args))))
|
||||
(($ $call proc args)
|
||||
(add-unknown-use (add-unknown-uses out args) proc))
|
||||
(($ $callk label proc args)
|
||||
(add-unknown-use (add-unknown-uses out args) proc))
|
||||
(($ $branch kt ($ $primcall name param args))
|
||||
(add-unknown-uses out args))
|
||||
(($ $primcall name param args)
|
||||
(let ((h (significant-bits-handler name)))
|
||||
(if h
|
||||
(match (intmap-ref cps k)
|
||||
(($ $kargs _ defs)
|
||||
(h label types out param args defs)))
|
||||
(match term
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec))
|
||||
;; No uses, so no info added to sigbits.
|
||||
out)
|
||||
(($ $values args)
|
||||
(match (intmap-ref cps k)
|
||||
(($ $kargs _ vars)
|
||||
(if (intset-ref visited k)
|
||||
(fold (lambda (arg var out)
|
||||
(intmap-add out arg (intmap-ref out var)
|
||||
sigbits-union))
|
||||
out args vars)
|
||||
out))
|
||||
(($ $ktail)
|
||||
(add-unknown-uses out args))))
|
||||
(($ $prompt escape? tag handler)
|
||||
(add-unknown-use out tag)))))
|
||||
(($ $call proc args)
|
||||
(add-unknown-use (add-unknown-uses out args) proc))
|
||||
(($ $callk label proc args)
|
||||
(add-unknown-use (add-unknown-uses out args) proc))
|
||||
(($ $primcall name param args)
|
||||
(let ((h (significant-bits-handler name)))
|
||||
(if h
|
||||
(match (intmap-ref cps k)
|
||||
(($ $kargs _ defs)
|
||||
(h label types out param args defs)))
|
||||
(add-unknown-uses out args))))
|
||||
(($ $prompt escape? tag handler)
|
||||
(add-unknown-use out tag))))
|
||||
(($ $branch kf kt src op param args)
|
||||
(add-unknown-uses out args)))))
|
||||
(_ out)))))))))
|
||||
|
||||
(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-<))))
|
||||
(specialize-comparison/immediate-s64-integer
|
||||
cps kf kt src imm-op a b
|
||||
(lambda (cps a)
|
||||
(with-cps cps
|
||||
(build-exp ($primcall op #f (a b)))))))))
|
||||
(lambda (kf kt src a)
|
||||
(build-term ($branch kf kt src op #f (a b))))))))
|
||||
(else
|
||||
(specialize-comparison/s64-integer cps kf kt src op a b
|
||||
(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-<))))
|
||||
(specialize-comparison/immediate-s64-integer
|
||||
cps kf kt src imm-op b a
|
||||
(lambda (cps b)
|
||||
(with-cps cps
|
||||
(build-exp ($primcall op #f (a b)))))))))
|
||||
(lambda (kf kt src b)
|
||||
(build-term ($branch kf kt src op #f (a b))))))))
|
||||
(else
|
||||
(specialize-comparison/integer-s64 cps kf kt src op a 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)))
|
||||
(values cps types sigbits)))
|
||||
|
||||
(($ $kargs names vars
|
||||
($ $continue k src ($ $primcall op param args)))
|
||||
(($ $kargs names vars ($ $continue k src ($ $primcall op param args)))
|
||||
(call-with-values
|
||||
(lambda () (specialize-primcall cps k src op param args))
|
||||
(lambda (cps term)
|
||||
|
|
@ -665,8 +646,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
|
|||
cps)
|
||||
types sigbits))))
|
||||
|
||||
(($ $kargs names vars
|
||||
($ $continue kf src ($ $branch kt ($ $primcall op param args))))
|
||||
(($ $kargs names vars ($ $branch kf kt src op param args))
|
||||
(call-with-values
|
||||
(lambda () (specialize-branch cps kf kt src op param args))
|
||||
(lambda (cps term)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -70,29 +70,31 @@ references."
|
|||
(intset-fold
|
||||
(lambda (label defs uses)
|
||||
(match (intmap-ref conts label)
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(($ $kargs names vars term)
|
||||
(values
|
||||
(add-defs vars defs)
|
||||
(match exp
|
||||
((or ($ $const) ($ $prim)) uses)
|
||||
(($ $fun kfun)
|
||||
(intset-union (persistent-intset uses)
|
||||
(intmap-ref free kfun)))
|
||||
(($ $rec names vars (($ $fun kfun) ...))
|
||||
(fold (lambda (kfun uses)
|
||||
(intset-union (persistent-intset uses)
|
||||
(intmap-ref free kfun)))
|
||||
uses kfun))
|
||||
(($ $values args)
|
||||
(add-uses args uses))
|
||||
(($ $call proc args)
|
||||
(add-use proc (add-uses args uses)))
|
||||
(($ $branch kt ($ $primcall name param args))
|
||||
(add-uses args uses))
|
||||
(($ $primcall name param args)
|
||||
(add-uses args uses))
|
||||
(($ $prompt escape? tag handler)
|
||||
(add-use tag uses)))))
|
||||
(match term
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
((or ($ $const) ($ $prim)) uses)
|
||||
(($ $fun kfun)
|
||||
(intset-union (persistent-intset uses)
|
||||
(intmap-ref free kfun)))
|
||||
(($ $rec names vars (($ $fun kfun) ...))
|
||||
(fold (lambda (kfun uses)
|
||||
(intset-union (persistent-intset uses)
|
||||
(intmap-ref free kfun)))
|
||||
uses kfun))
|
||||
(($ $values args)
|
||||
(add-uses args uses))
|
||||
(($ $call proc args)
|
||||
(add-use proc (add-uses args uses)))
|
||||
(($ $primcall name param args)
|
||||
(add-uses args uses))
|
||||
(($ $prompt escape? tag handler)
|
||||
(add-use tag uses))))
|
||||
(($ $branch kf kt src op param args)
|
||||
(add-uses args uses)))))
|
||||
(($ $kfun src meta self)
|
||||
(values (add-def self defs) uses))
|
||||
(_ (values defs uses))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -50,14 +50,12 @@ KFUN where we can prove that no assertion will be raised at run-time."
|
|||
((causes-all-effects? fx) effects)
|
||||
((causes-effect? fx &type-check)
|
||||
(match (intmap-ref conts label)
|
||||
(($ $kargs _ _ exp)
|
||||
(match exp
|
||||
(($ $continue k src ($ $primcall name param args))
|
||||
(visit-primcall effects fx label name param args))
|
||||
(($ $continue k src
|
||||
($ $branch _ ($ $primcall name param args)))
|
||||
(visit-primcall effects fx label name param args))
|
||||
(_ effects)))
|
||||
(($ $kargs names vars
|
||||
($ $continue k src ($ $primcall name param args)))
|
||||
(visit-primcall effects fx label name param args))
|
||||
(($ $kargs names vars
|
||||
($ $branch kf kt src name param args))
|
||||
(visit-primcall effects fx label name param args))
|
||||
(_ effects)))
|
||||
(else effects))))
|
||||
types
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;; 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
|
||||
;;; 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 kf ($kargs () () ($continue k src ($const #f))))
|
||||
(letk ku64 ($kargs (#f) (u64)
|
||||
($continue kt src
|
||||
($branch kf ($primcall 's64-imm-= 0 (u64))))))
|
||||
($branch kt kf src 's64-imm-= 0 (u64))))
|
||||
(letk kand ($kargs (#f) (res)
|
||||
($continue ku64 src ($primcall 'untag-fixnum #f (res)))))
|
||||
(letk kmask ($kargs (#f) (mask)
|
||||
|
|
@ -527,32 +526,32 @@
|
|||
($kargs names vars
|
||||
($continue (if v kt kf) src
|
||||
($values ())))))))))))))))
|
||||
(define (visit-expression cps label names vars k src exp)
|
||||
(match exp
|
||||
(($ $primcall name param args)
|
||||
;; We might be able to fold primcalls that define a value.
|
||||
(match (intmap-ref cps k)
|
||||
(($ $kargs (_) (def))
|
||||
(or (fold-primcall cps label names vars k src name param args def)
|
||||
(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))
|
||||
;; We might be able to fold primcalls that branch.
|
||||
(match args
|
||||
((x)
|
||||
(or (fold-unary-branch cps label names vars k kt src name param x)
|
||||
cps))
|
||||
((x y)
|
||||
(or (fold-binary-branch cps label names vars k kt src name param x y)
|
||||
cps))))
|
||||
(_ cps)))
|
||||
(define (visit-primcall cps label names vars k src name param args)
|
||||
;; We might be able to fold primcalls that define a value.
|
||||
(match (intmap-ref cps k)
|
||||
(($ $kargs (_) (def))
|
||||
(or (fold-primcall cps label names vars k src name param args def)
|
||||
(reduce-primcall cps label names vars k src name param args)))
|
||||
(_
|
||||
(reduce-primcall cps label names vars k src 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.
|
||||
(match args
|
||||
((x)
|
||||
(or (fold-unary-branch cps label names vars kf kt src name param x)
|
||||
cps))
|
||||
((x y)
|
||||
(or (fold-binary-branch cps label names vars kf kt src name param x y)
|
||||
cps))))
|
||||
(let lp ((label start) (cps cps))
|
||||
(if (<= label end)
|
||||
(lp (1+ label)
|
||||
(match (intmap-ref cps label)
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(visit-expression cps label names vars k src exp))
|
||||
(($ $kargs names vars ($ $continue k src
|
||||
($ $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))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;; 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
|
||||
;;; it under the terms of the GNU Lesser General Public License as
|
||||
|
|
@ -1777,8 +1777,9 @@ minimum, and maximum."
|
|||
(match cont
|
||||
(($ $kargs _ _ ($ $continue k src exp))
|
||||
(match exp
|
||||
((or ($ $branch) ($ $prompt)) 2)
|
||||
(($ $prompt) 2)
|
||||
(_ 1)))
|
||||
(($ $kargs _ _ ($ $branch)) 2)
|
||||
(($ $kfun src meta self tail clause) (if clause 1 0))
|
||||
(($ $kclause arity body alt) (if alt 2 1))
|
||||
(($ $kreceive) 1)
|
||||
|
|
@ -1915,11 +1916,6 @@ maximum, where type is a bitset as a fixnum."
|
|||
(values (append changed0 changed1) typev)))
|
||||
;; Each of these branches must propagate to its successors.
|
||||
(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)
|
||||
;; The "normal" continuation enters the prompt.
|
||||
(propagate2 k types handler types))
|
||||
|
|
@ -1979,6 +1975,10 @@ maximum, where type is a bitset as a fixnum."
|
|||
(match (intmap-ref conts label)
|
||||
(($ $kargs names vars ($ $continue k src 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)
|
||||
(match (intmap-ref conts k)
|
||||
(($ $kargs names vars)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -198,13 +198,14 @@ disjoint, an error will be signalled."
|
|||
(if kalt
|
||||
(visit-cont kalt (visit-cont kbody labels))
|
||||
(visit-cont kbody labels)))
|
||||
(($ $kargs names syms ($ $continue k src exp))
|
||||
(visit-cont k (match exp
|
||||
(($ $branch k)
|
||||
(visit-cont k labels))
|
||||
(($ $prompt escape? tag k)
|
||||
(visit-cont k labels))
|
||||
(_ labels)))))))))))
|
||||
(($ $kargs names syms term)
|
||||
(match term
|
||||
(($ $continue k src ($ $prompt escape? tag handler))
|
||||
(visit-cont k (visit-cont handler labels)))
|
||||
(($ $continue k)
|
||||
(visit-cont k labels))
|
||||
(($ $branch kf kt)
|
||||
(visit-cont kf (visit-cont kt labels))))))))))))
|
||||
|
||||
(define* (compute-reachable-functions conts #:optional (kfun 0))
|
||||
"Compute a mapping LABEL->LABEL..., where each key is a reachable
|
||||
|
|
@ -257,11 +258,13 @@ intset."
|
|||
(if (intmap-ref succs label (lambda (_) #f))
|
||||
succs
|
||||
(match (intmap-ref conts label)
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(match exp
|
||||
(($ $branch kt) (propagate2 k kt))
|
||||
(($ $prompt escape? tag handler) (propagate2 k handler))
|
||||
(_ (propagate1 k))))
|
||||
(($ $kargs names vars term)
|
||||
(match term
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
(($ $prompt escape? tag handler) (propagate2 k handler))
|
||||
(_ (propagate1 k))))
|
||||
(($ $branch kf kt) (propagate2 kf kt))))
|
||||
(($ $kreceive arity k)
|
||||
(propagate1 k))
|
||||
(($ $kfun src meta self tail clause)
|
||||
|
|
@ -291,12 +294,15 @@ intset."
|
|||
preds)
|
||||
(($ $kclause arity kbody kalt)
|
||||
(add-pred kbody (if kalt (add-pred kalt preds) preds)))
|
||||
(($ $kargs names syms ($ $continue k src exp))
|
||||
(add-pred k
|
||||
(match exp
|
||||
(($ $branch k) (add-pred k preds))
|
||||
(($ $prompt _ _ k) (add-pred k preds))
|
||||
(_ preds))))))
|
||||
(($ $kargs names syms term)
|
||||
(match term
|
||||
(($ $continue k src exp)
|
||||
(add-pred k
|
||||
(match exp
|
||||
(($ $prompt _ _ k) (add-pred k preds))
|
||||
(_ preds))))
|
||||
(($ $branch kf kt)
|
||||
(add-pred kf (add-pred kt preds)))))))
|
||||
(persistent-intmap
|
||||
(intset-fold add-preds labels
|
||||
(intset->intmap (lambda (label) '()) labels))))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;; 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
|
||||
;;; it under the terms of the GNU Lesser General Public License as
|
||||
|
|
@ -62,7 +62,7 @@
|
|||
(intmap-fold
|
||||
(lambda (label cont seen)
|
||||
(match (intmap-ref conts label)
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(($ $kargs names vars term)
|
||||
(fold1 adjoin-def vars seen))
|
||||
(($ $kfun src meta self tail clause)
|
||||
(adjoin-def self seen))
|
||||
|
|
@ -99,12 +99,15 @@ definitions that are available at LABEL."
|
|||
(values (append changed0 changed1) defs)))
|
||||
|
||||
(match (intmap-ref conts label)
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(($ $kargs names vars term)
|
||||
(let ((out (fold1 adjoin-def vars in)))
|
||||
(match exp
|
||||
(($ $branch kt) (propagate2 k kt out))
|
||||
(($ $prompt escape? tag handler) (propagate2 k handler out))
|
||||
(_ (propagate1 k out)))))
|
||||
(match term
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
(($ $prompt escape? tag handler) (propagate2 k handler out))
|
||||
(_ (propagate1 k out))))
|
||||
(($ $branch kf kt)
|
||||
(propagate2 kf kt out)))))
|
||||
(($ $kreceive arity k)
|
||||
(propagate1 k in))
|
||||
(($ $kfun src meta self tail clause)
|
||||
|
|
@ -159,21 +162,60 @@ definitions that are available at LABEL."
|
|||
(check-use proc)
|
||||
(for-each check-use args)
|
||||
(visit-first-order kfun))
|
||||
(($ $branch kt ($ $primcall name param args))
|
||||
(for-each check-use args)
|
||||
first-order)
|
||||
(($ $primcall name param args)
|
||||
(for-each check-use args)
|
||||
first-order)
|
||||
(($ $prompt escape? tag handler)
|
||||
(check-use tag)
|
||||
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
|
||||
(lambda (label bound first-order)
|
||||
(let ((bound (intset-union free bound)))
|
||||
(match (intmap-ref conts label)
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(visit-exp exp (fold1 adjoin-def vars bound) first-order))
|
||||
(($ $kargs names vars term)
|
||||
(visit-term term (fold1 adjoin-def vars bound) first-order))
|
||||
(_ first-order))))
|
||||
(compute-available-definitions conts kfun)
|
||||
first-order)))
|
||||
|
|
@ -236,11 +278,6 @@ definitions that are available at LABEL."
|
|||
(assert-kreceive-or-ktail))
|
||||
(($ $callk k proc args)
|
||||
(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)
|
||||
(match cont
|
||||
(($ $kargs) #t)
|
||||
|
|
@ -254,15 +291,26 @@ definitions that are available at LABEL."
|
|||
(match (intmap-ref conts handler)
|
||||
(($ $kreceive) #t)
|
||||
(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)))
|
||||
(intmap-for-each
|
||||
(lambda (label cont)
|
||||
(when (intset-ref reachable label)
|
||||
(match cont
|
||||
(($ $kargs names vars ($ $continue k src exp))
|
||||
(($ $kargs names vars term)
|
||||
(unless (= (length names) (length vars))
|
||||
(error "broken $kargs" label names vars))
|
||||
(check-arity exp (intmap-ref conts k)))
|
||||
(check-term term))
|
||||
(_ #t))))
|
||||
conts)))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -310,9 +310,8 @@
|
|||
(let$ init (convert init kreceive subst))
|
||||
(letk kunbound ($kargs () () ,init))
|
||||
(build-term
|
||||
($continue kbound src
|
||||
($branch kunbound
|
||||
($primcall 'undefined? #f (orig-var))))))))))))))
|
||||
($branch kbound kunbound src
|
||||
'undefined? #f (orig-var))))))))))))
|
||||
|
||||
(define (build-list cps k src vals)
|
||||
(match vals
|
||||
|
|
@ -914,14 +913,11 @@
|
|||
(if (heap-type-predicate? name)
|
||||
(with-cps cps
|
||||
(letk kt* ($kargs () ()
|
||||
($continue kf src
|
||||
($branch kt ($primcall name #f args)))))
|
||||
($branch kf kt src name #f args)))
|
||||
(build-term
|
||||
($continue kf src
|
||||
($branch kt* ($primcall 'heap-object? #f args)))))
|
||||
($branch kf kt* src 'heap-object? #f args)))
|
||||
(with-cps cps
|
||||
(build-term ($continue kf src
|
||||
($branch kt ($primcall name #f args)))))))))
|
||||
(build-term ($branch kf kt src name #f args)))))))
|
||||
(($ <conditional> src test consequent alternate)
|
||||
(with-cps cps
|
||||
(let$ t (convert-test consequent kt kf))
|
||||
|
|
@ -935,8 +931,7 @@
|
|||
(_ (convert-arg cps test
|
||||
(lambda (cps test)
|
||||
(with-cps cps
|
||||
(build-term ($continue kt src
|
||||
($branch kf ($primcall 'false? #f (test)))))))))))
|
||||
(build-term ($branch kt kf src 'false? #f (test)))))))))
|
||||
(with-cps cps
|
||||
(let$ t (convert consequent k subst))
|
||||
(let$ f (convert alternate k subst))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue