mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-18 10:10:23 +02:00
Code Activity

$primcall has a "param" member

Browse source 
* module/language/cps.scm ($primcall): Add "param" member, which will be
  a constant parameter to the primcall.  The idea is that constants used
  by primcalls as immediates don't need to participate in optimizations
  in any way -- they should not participate in CSE, have the same
  lifetime as the primcall so not part of DCE either, and don't need
  slot allocation.  Indirecting them through a named $const binding is
  complication for no benefit.  This change should eventually improve
  compilation time and memory usage, once we fully take advantage of it,
  as the number of labels and variables will go down.
* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-bytecode.scm:
* module/language/cps/constructors.scm:
* module/language/cps/contification.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/effects-analysis.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/handle-interrupts.scm:
* module/language/cps/licm.scm:
* module/language/cps/peel-loops.scm:
* module/language/cps/prune-bailouts.scm:
* module/language/cps/prune-top-level-scopes.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/renumber.scm:
* module/language/cps/rotate-loops.scm:
* module/language/cps/self-references.scm:
* module/language/cps/simplify.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/specialize-numbers.scm:
* module/language/cps/specialize-primcalls.scm:
* module/language/cps/split-rec.scm:
* module/language/cps/type-checks.scm:
* module/language/cps/type-fold.scm:
* module/language/cps/types.scm:
* module/language/cps/utils.scm:
* module/language/cps/verify.scm:
* module/language/tree-il/compile-cps.scm: Adapt all users.
This commit is contained in:
Andy Wingo 2017-11-01 11:57:16 +01:00
parent 2d8c75f9f2
commit c54c151eb6
29 changed files with 427 additions and 420 deletions
Download patch file Download diff file Expand all files Collapse all files

18
module/language/cps.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -189,7 +189,7 @@
(define-cps-type $branch kt exp) (define-cps-type $branch kt exp)
(define-cps-type $call proc args) (define-cps-type $call proc args)
(define-cps-type $callk k proc args) ; First-order. (define-cps-type $callk k proc args) ; First-order.
(define-cps-type $primcall name args) (define-cps-type $primcall name param args)
(define-cps-type $values args) (define-cps-type $values args)
(define-cps-type $prompt escape? tag handler) (define-cps-type $prompt escape? tag handler)
@ -241,9 +241,9 @@
((_ ($callk k proc (unquote args))) (make-$callk k proc args)) ((_ ($callk k proc (unquote args))) (make-$callk k proc args))
((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...))) ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
((_ ($callk k proc args)) (make-$callk k proc args)) ((_ ($callk k proc args)) (make-$callk k proc args))
((_ ($primcall name (unquote args))) (make-$primcall name args)) ((_ ($primcall name param (unquote args))) (make-$primcall name param args))
((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...))) ((_ ($primcall name param (arg ...))) (make-$primcall name param (list arg ...)))
((_ ($primcall name args)) (make-$primcall name args)) ((_ ($primcall name param args)) (make-$primcall name param args))
((_ ($values (unquote args))) (make-$values args)) ((_ ($values (unquote args))) (make-$values args))
((_ ($values (arg ...))) (make-$values (list arg ...))) ((_ ($values (arg ...))) (make-$values (list arg ...)))
((_ ($values args)) (make-$values args)) ((_ ($values args)) (make-$values args))
@ -299,8 +299,8 @@
(build-exp ($call proc arg))) (build-exp ($call proc arg)))
(('callk k proc arg ...) (('callk k proc arg ...)
(build-exp ($callk k proc arg))) (build-exp ($callk k proc arg)))
(('primcall name arg ...) (('primcall name param arg ...)
(build-exp ($primcall name arg))) (build-exp ($primcall name param arg)))
(('branch k exp) (('branch k exp)
(build-exp ($branch k ,(parse-cps exp)))) (build-exp ($branch k ,(parse-cps exp))))
(('values arg ...) (('values arg ...)
@ -346,8 +346,8 @@
`(call ,proc ,@args)) `(call ,proc ,@args))
(($ $callk k proc args) (($ $callk k proc args)
`(callk ,k ,proc ,@args)) `(callk ,k ,proc ,@args))
(($ $primcall name args) (($ $primcall name param args)
`(primcall ,name ,@args)) `(primcall ,name ,param ,@args))
(($ $branch k exp) (($ $branch k exp)
`(branch ,k ,(unparse-cps exp))) `(branch ,k ,(unparse-cps exp)))
(($ $values args) (($ $values args)

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

@ -89,9 +89,9 @@ conts."
(add-uses args uses)) (add-uses args uses))
(($ $call proc args) (($ $call proc args)
(add-uses args uses)) (add-uses args uses))
(($ $branch kt ($ $primcall name args)) (($ $branch kt ($ $primcall name param args))
(add-uses args uses)) (add-uses args uses))
(($ $primcall name args) (($ $primcall name param args)
(add-uses args uses)) (add-uses args uses))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(add-use tag uses)))) (add-use tag uses))))
@ -245,10 +245,10 @@ shared closures to use the appropriate 'self' variable, if possible."
(rewrite-exp (intmap-ref env proc (lambda (_) #f)) (rewrite-exp (intmap-ref env proc (lambda (_) #f))
(#f ($call proc ,args)) (#f ($call proc ,args))
((closure . label) ($callk label closure ,args))))) ((closure . label) ($callk label closure ,args)))))
(($ $primcall name args) (($ $primcall name param args)
($primcall name ,(map subst args))) ($primcall name param ,(map subst args)))
(($ $branch k ($ $primcall name args)) (($ $branch k ($ $primcall name param args))
($branch k ($primcall name ,(map subst args)))) ($branch k ($primcall name param ,(map subst args))))
(($ $values args) (($ $values args)
($values ,(map subst args))) ($values ,(map subst args)))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
@ -369,9 +369,9 @@ references."
(add-use proc (add-uses args uses))) (add-use proc (add-uses args uses)))
(($ $callk label proc args) (($ $callk label proc args)
(add-use proc (add-uses args uses))) (add-use proc (add-uses args uses)))
(($ $branch kt ($ $primcall name args)) (($ $branch kt ($ $primcall name param args))
(add-uses args uses)) (add-uses args uses))
(($ $primcall name args) (($ $primcall name param args)
(add-uses args uses)) (add-uses args uses))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(add-use tag uses))))) (add-use tag uses)))))
@ -482,7 +482,7 @@ Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
(letv var*) (letv var*)
(let$ body (k var*)) (let$ body (k var*))
(letk k* ($kargs (#f) (var*) ,body)) (letk k* ($kargs (#f) (var*) ,body))
(build-term ($continue k* #f ($primcall op (self))))))) (build-term ($continue k* #f ($primcall op #f (self)))))))
(_ (_
(let ((idx (intset-find free var))) (let ((idx (intset-find free var)))
(cond (cond
@ -493,11 +493,11 @@ Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
(letk k* ($kargs (#f) (var*) ,body)) (letk k* ($kargs (#f) (var*) ,body))
(letk kunbox ($kargs ('idx) (u64) (letk kunbox ($kargs ('idx) (u64)
($continue k* #f ($continue k* #f
($primcall 'vector-ref (self u64))))) ($primcall 'vector-ref #f (self u64)))))
($ (with-cps-constants ((idx idx)) ($ (with-cps-constants ((idx idx))
(build-term (build-term
($continue kunbox #f ($continue kunbox #f
($primcall 'scm->u64 (idx)))))))) ($primcall 'scm->u64 #f (idx))))))))
(else (else
(with-cps cps (with-cps cps
(letv var*) (letv var*)
@ -506,7 +506,7 @@ Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
($ (with-cps-constants ((idx idx)) ($ (with-cps-constants ((idx idx))
(build-term (build-term
($continue k* #f ($continue k* #f
($primcall 'free-ref (self idx))))))))))))) ($primcall 'free-ref #f (self idx)))))))))))))
(else (else
(with-cps cps (with-cps cps
($ (k var)))))) ($ (k var))))))
@ -540,7 +540,7 @@ term."
(with-cps cps (with-cps cps
($ (with-cps-constants ((false #f)) ($ (with-cps-constants ((false #f))
(build-term (build-term
($continue k src ($primcall 'cons (false false)))))))) ($continue k src ($primcall 'cons #f (false false))))))))
;; Well-known callee with more than two free variables; the closure ;; Well-known callee with more than two free variables; the closure
;; is a vector. ;; is a vector.
(#(#t nfree) (#(#t nfree)
@ -552,9 +552,9 @@ term."
(letv u64) (letv u64)
(letk kunbox ($kargs ('nfree) (u64) (letk kunbox ($kargs ('nfree) (u64)
($continue k src ($continue k src
($primcall 'make-vector (u64 false))))) ($primcall 'make-vector #f (u64 false)))))
(build-term (build-term
($continue kunbox src ($primcall 'scm->u64 (nfree)))))))))) ($continue kunbox src ($primcall 'scm->u64 #f (nfree))))))))))
(define (init-closure cps k src var known? free) (define (init-closure cps k src var known? free)
"Initialize the free variables @var{closure-free} in a closure "Initialize the free variables @var{closure-free} in a closure
@ -579,10 +579,10 @@ bound to @var{var}, and continue to @var{k}."
(with-cps cps (with-cps cps
(build-term (build-term
($continue k src ($continue k src
($primcall 'set-cdr! (var v1)))))))) ($primcall 'set-cdr! #f (var v1))))))))
(letk kcdr ($kargs () () ,body)) (letk kcdr ($kargs () () ,body))
(build-term (build-term
($continue kcdr src ($primcall 'set-car! (var v0))))))))) ($continue kcdr src ($primcall 'set-car! #f (var v0)))))))))
;; Otherwise residualize a sequence of vector-set! or free-set!, ;; Otherwise residualize a sequence of vector-set! or free-set!,
;; depending on whether the callee is well-known or not. ;; depending on whether the callee is well-known or not.
(_ (_
@ -602,17 +602,17 @@ bound to @var{var}, and continue to @var{k}."
(letk kunbox (letk kunbox
($kargs ('idx) (u64) ($kargs ('idx) (u64)
($continue k src ($continue k src
($primcall 'vector-set! (var u64 v))))) ($primcall 'vector-set! #f (var u64 v)))))
($ (with-cps-constants ((idx idx)) ($ (with-cps-constants ((idx idx))
(build-term (build-term
($continue kunbox src ($continue kunbox src
($primcall 'scm->u64 (idx)))))))) ($primcall 'scm->u64 #f (idx))))))))
(else (else
(with-cps cps (with-cps cps
($ (with-cps-constants ((idx idx)) ($ (with-cps-constants ((idx idx))
(build-term (build-term
($continue k src ($continue k src
($primcall 'free-set! ($primcall 'free-set! #f
(var idx v))))))))))))))))))) (var idx v)))))))))))))))))))
(define (make-single-closure cps k src kfun) (define (make-single-closure cps k src kfun)
@ -757,20 +757,20 @@ bound to @var{var}, and continue to @var{k}."
(($ $continue k src ($ $callk label proc args)) (($ $continue k src ($ $callk label proc args))
(convert-known-proc-call cps k src label proc args)) (convert-known-proc-call cps k src label proc args))
(($ $continue k src ($ $primcall name args)) (($ $continue k src ($ $primcall name param args))
(convert-args cps args (convert-args cps args
(lambda (cps args) (lambda (cps args)
(with-cps cps (with-cps cps
(build-term (build-term
($continue k src ($primcall name args))))))) ($continue k src ($primcall name param args)))))))
(($ $continue k src ($ $branch kt ($ $primcall name args))) (($ $continue k src ($ $branch kt ($ $primcall name param args)))
(convert-args cps args (convert-args cps args
(lambda (cps args) (lambda (cps args)
(with-cps cps (with-cps cps
(build-term (build-term
($continue k src ($continue k src
($branch kt ($primcall name args)))))))) ($branch kt ($primcall name param args))))))))
(($ $continue k src ($ $values args)) (($ $continue k src ($ $values args))
(convert-args cps args (convert-args cps args

234
module/language/cps/compile-bytecode.scm
View file

@ -143,138 +143,138 @@
(emit-current-module asm (from-sp dst))) (emit-current-module asm (from-sp dst)))
(($ $primcall 'current-thread) (($ $primcall 'current-thread)
(emit-current-thread asm (from-sp dst))) (emit-current-thread asm (from-sp dst)))
(($ $primcall 'cached-toplevel-box (scope name bound?)) (($ $primcall 'cached-toplevel-box #f (scope name bound?))
(emit-cached-toplevel-box asm (from-sp dst) (emit-cached-toplevel-box asm (from-sp dst)
(constant scope) (constant name) (constant scope) (constant name)
(constant bound?))) (constant bound?)))
(($ $primcall 'cached-module-box (mod name public? bound?)) (($ $primcall 'cached-module-box #f (mod name public? bound?))
(emit-cached-module-box asm (from-sp dst) (emit-cached-module-box asm (from-sp dst)
(constant mod) (constant name) (constant mod) (constant name)
(constant public?) (constant bound?))) (constant public?) (constant bound?)))
(($ $primcall 'define! (sym)) (($ $primcall 'define! #f (sym))
(emit-define! asm (from-sp dst) (from-sp (slot sym)))) (emit-define! asm (from-sp dst) (from-sp (slot sym))))
(($ $primcall 'resolve (name bound?)) (($ $primcall 'resolve #f (name bound?))
(emit-resolve asm (from-sp dst) (constant bound?) (emit-resolve asm (from-sp dst) (constant bound?)
(from-sp (slot name)))) (from-sp (slot name))))
(($ $primcall 'free-ref (closure idx)) (($ $primcall 'free-ref #f (closure idx))
(emit-free-ref asm (from-sp dst) (from-sp (slot closure)) (emit-free-ref asm (from-sp dst) (from-sp (slot closure))
(constant idx))) (constant idx)))
(($ $primcall 'vector-ref (vector index)) (($ $primcall 'vector-ref #f (vector index))
(emit-vector-ref asm (from-sp dst) (from-sp (slot vector)) (emit-vector-ref asm (from-sp dst) (from-sp (slot vector))
(from-sp (slot index)))) (from-sp (slot index))))
(($ $primcall 'make-vector (length init)) (($ $primcall 'make-vector #f (length init))
(emit-make-vector asm (from-sp dst) (from-sp (slot length)) (emit-make-vector asm (from-sp dst) (from-sp (slot length))
(from-sp (slot init)))) (from-sp (slot init))))
(($ $primcall 'make-vector/immediate (length init)) (($ $primcall 'make-vector/immediate #f (length init))
(emit-make-vector/immediate asm (from-sp dst) (constant length) (emit-make-vector/immediate asm (from-sp dst) (constant length)
(from-sp (slot init)))) (from-sp (slot init))))
(($ $primcall 'vector-ref/immediate (vector index)) (($ $primcall 'vector-ref/immediate #f (vector index))
(emit-vector-ref/immediate asm (from-sp dst) (from-sp (slot vector)) (emit-vector-ref/immediate asm (from-sp dst) (from-sp (slot vector))
(constant index))) (constant index)))
(($ $primcall 'allocate-struct (vtable nfields)) (($ $primcall 'allocate-struct #f (vtable nfields))
(emit-allocate-struct asm (from-sp dst) (from-sp (slot vtable)) (emit-allocate-struct asm (from-sp dst) (from-sp (slot vtable))
(from-sp (slot nfields)))) (from-sp (slot nfields))))
(($ $primcall 'allocate-struct/immediate (vtable nfields)) (($ $primcall 'allocate-struct/immediate #f (vtable nfields))
(emit-allocate-struct/immediate asm (from-sp dst) (emit-allocate-struct/immediate asm (from-sp dst)
(from-sp (slot vtable)) (from-sp (slot vtable))
(constant nfields))) (constant nfields)))
(($ $primcall 'struct-ref (struct n)) (($ $primcall 'struct-ref #f (struct n))
(emit-struct-ref asm (from-sp dst) (from-sp (slot struct)) (emit-struct-ref asm (from-sp dst) (from-sp (slot struct))
(from-sp (slot n)))) (from-sp (slot n))))
(($ $primcall 'struct-ref/immediate (struct n)) (($ $primcall 'struct-ref/immediate #f (struct n))
(emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct)) (emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct))
(constant n))) (constant n)))
(($ $primcall 'char->integer (src)) (($ $primcall 'char->integer #f (src))
(emit-char->integer asm (from-sp dst) (from-sp (slot src)))) (emit-char->integer asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'integer->char (src)) (($ $primcall 'integer->char #f (src))
(emit-integer->char asm (from-sp dst) (from-sp (slot src)))) (emit-integer->char asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'add/immediate (x y)) (($ $primcall 'add/immediate #f (x y))
(emit-add/immediate asm (from-sp dst) (from-sp (slot x)) (constant y))) (emit-add/immediate asm (from-sp dst) (from-sp (slot x)) (constant y)))
(($ $primcall 'sub/immediate (x y)) (($ $primcall 'sub/immediate #f (x y))
(emit-sub/immediate asm (from-sp dst) (from-sp (slot x)) (constant y))) (emit-sub/immediate asm (from-sp dst) (from-sp (slot x)) (constant y)))
(($ $primcall 'uadd/immediate (x y)) (($ $primcall 'uadd/immediate #f (x y))
(emit-uadd/immediate asm (from-sp dst) (from-sp (slot x)) (emit-uadd/immediate asm (from-sp dst) (from-sp (slot x))
(constant y))) (constant y)))
(($ $primcall 'usub/immediate (x y)) (($ $primcall 'usub/immediate #f (x y))
(emit-usub/immediate asm (from-sp dst) (from-sp (slot x)) (emit-usub/immediate asm (from-sp dst) (from-sp (slot x))
(constant y))) (constant y)))
(($ $primcall 'umul/immediate (x y)) (($ $primcall 'umul/immediate #f (x y))
(emit-umul/immediate asm (from-sp dst) (from-sp (slot x)) (emit-umul/immediate asm (from-sp dst) (from-sp (slot x))
(constant y))) (constant y)))
(($ $primcall 'ursh/immediate (x y)) (($ $primcall 'ursh/immediate #f (x y))
(emit-ursh/immediate asm (from-sp dst) (from-sp (slot x)) (emit-ursh/immediate asm (from-sp dst) (from-sp (slot x))
(constant y))) (constant y)))
(($ $primcall 'ulsh/immediate (x y)) (($ $primcall 'ulsh/immediate #f (x y))
(emit-ulsh/immediate asm (from-sp dst) (from-sp (slot x)) (emit-ulsh/immediate asm (from-sp dst) (from-sp (slot x))
(constant y))) (constant y)))
(($ $primcall 'builtin-ref (name)) (($ $primcall 'builtin-ref #f (name))
(emit-builtin-ref asm (from-sp dst) (constant name))) (emit-builtin-ref asm (from-sp dst) (constant name)))
(($ $primcall 'scm->f64 (src)) (($ $primcall 'scm->f64 #f (src))
(emit-scm->f64 asm (from-sp dst) (from-sp (slot src)))) (emit-scm->f64 asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'load-f64 (src)) (($ $primcall 'load-f64 #f (src))
(emit-load-f64 asm (from-sp dst) (constant src))) (emit-load-f64 asm (from-sp dst) (constant src)))
(($ $primcall 'f64->scm (src)) (($ $primcall 'f64->scm #f (src))
(emit-f64->scm asm (from-sp dst) (from-sp (slot src)))) (emit-f64->scm asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'scm->u64 (src)) (($ $primcall 'scm->u64 #f (src))
(emit-scm->u64 asm (from-sp dst) (from-sp (slot src)))) (emit-scm->u64 asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'scm->u64/truncate (src)) (($ $primcall 'scm->u64/truncate #f (src))
(emit-scm->u64/truncate asm (from-sp dst) (from-sp (slot src)))) (emit-scm->u64/truncate asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'load-u64 (src)) (($ $primcall 'load-u64 #f (src))
(emit-load-u64 asm (from-sp dst) (constant src))) (emit-load-u64 asm (from-sp dst) (constant src)))
(($ $primcall (or 'u64->scm 'u64->scm/unlikely) (src)) (($ $primcall (or 'u64->scm 'u64->scm/unlikely) #f (src))
(emit-u64->scm asm (from-sp dst) (from-sp (slot src)))) (emit-u64->scm asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'scm->s64 (src)) (($ $primcall 'scm->s64 #f (src))
(emit-scm->s64 asm (from-sp dst) (from-sp (slot src)))) (emit-scm->s64 asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'load-s64 (src)) (($ $primcall 'load-s64 #f (src))
(emit-load-s64 asm (from-sp dst) (constant src))) (emit-load-s64 asm (from-sp dst) (constant src)))
(($ $primcall (or 's64->scm 's64->scm/unlikely) (src)) (($ $primcall (or 's64->scm 's64->scm/unlikely) #f (src))
(emit-s64->scm asm (from-sp dst) (from-sp (slot src)))) (emit-s64->scm asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'bv-length (bv)) (($ $primcall 'bv-length #f (bv))
(emit-bv-length asm (from-sp dst) (from-sp (slot bv)))) (emit-bv-length asm (from-sp dst) (from-sp (slot bv))))
(($ $primcall 'bv-u8-ref (bv idx)) (($ $primcall 'bv-u8-ref #f (bv idx))
(emit-bv-u8-ref asm (from-sp dst) (from-sp (slot bv)) (emit-bv-u8-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx)))) (from-sp (slot idx))))
(($ $primcall 'bv-s8-ref (bv idx)) (($ $primcall 'bv-s8-ref #f (bv idx))
(emit-bv-s8-ref asm (from-sp dst) (from-sp (slot bv)) (emit-bv-s8-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx)))) (from-sp (slot idx))))
(($ $primcall 'bv-u16-ref (bv idx)) (($ $primcall 'bv-u16-ref #f (bv idx))
(emit-bv-u16-ref asm (from-sp dst) (from-sp (slot bv)) (emit-bv-u16-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx)))) (from-sp (slot idx))))
(($ $primcall 'bv-s16-ref (bv idx)) (($ $primcall 'bv-s16-ref #f (bv idx))
(emit-bv-s16-ref asm (from-sp dst) (from-sp (slot bv)) (emit-bv-s16-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx)))) (from-sp (slot idx))))
(($ $primcall 'bv-u32-ref (bv idx val)) (($ $primcall 'bv-u32-ref #f (bv idx val))
(emit-bv-u32-ref asm (from-sp dst) (from-sp (slot bv)) (emit-bv-u32-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx)))) (from-sp (slot idx))))
(($ $primcall 'bv-s32-ref (bv idx val)) (($ $primcall 'bv-s32-ref #f (bv idx val))
(emit-bv-s32-ref asm (from-sp dst) (from-sp (slot bv)) (emit-bv-s32-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx)))) (from-sp (slot idx))))
(($ $primcall 'bv-u64-ref (bv idx val)) (($ $primcall 'bv-u64-ref #f (bv idx val))
(emit-bv-u64-ref asm (from-sp dst) (from-sp (slot bv)) (emit-bv-u64-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx)))) (from-sp (slot idx))))
(($ $primcall 'bv-s64-ref (bv idx val)) (($ $primcall 'bv-s64-ref #f (bv idx val))
(emit-bv-s64-ref asm (from-sp dst) (from-sp (slot bv)) (emit-bv-s64-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx)))) (from-sp (slot idx))))
(($ $primcall 'bv-f32-ref (bv idx val)) (($ $primcall 'bv-f32-ref #f (bv idx val))
(emit-bv-f32-ref asm (from-sp dst) (from-sp (slot bv)) (emit-bv-f32-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx)))) (from-sp (slot idx))))
(($ $primcall 'bv-f64-ref (bv idx val)) (($ $primcall 'bv-f64-ref #f (bv idx val))
(emit-bv-f64-ref asm (from-sp dst) (from-sp (slot bv)) (emit-bv-f64-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx)))) (from-sp (slot idx))))
(($ $primcall 'make-atomic-box (init)) (($ $primcall 'make-atomic-box #f (init))
(emit-make-atomic-box asm (from-sp dst) (from-sp (slot init)))) (emit-make-atomic-box asm (from-sp dst) (from-sp (slot init))))
(($ $primcall 'atomic-box-ref (box)) (($ $primcall 'atomic-box-ref #f (box))
(emit-atomic-box-ref asm (from-sp dst) (from-sp (slot box)))) (emit-atomic-box-ref asm (from-sp dst) (from-sp (slot box))))
(($ $primcall 'atomic-box-swap! (box val)) (($ $primcall 'atomic-box-swap! #f (box val))
(emit-atomic-box-swap! asm (from-sp dst) (from-sp (slot box)) (emit-atomic-box-swap! asm (from-sp dst) (from-sp (slot box))
(from-sp (slot val)))) (from-sp (slot val))))
(($ $primcall 'atomic-box-compare-and-swap! (box expected desired)) (($ $primcall 'atomic-box-compare-and-swap! #f (box expected desired))
(emit-atomic-box-compare-and-swap! (emit-atomic-box-compare-and-swap!
asm (from-sp dst) (from-sp (slot box)) asm (from-sp dst) (from-sp (slot box))
(from-sp (slot expected)) (from-sp (slot desired)))) (from-sp (slot expected)) (from-sp (slot desired))))
(($ $primcall 'untag-fixnum (src)) (($ $primcall 'untag-fixnum #f (src))
(emit-untag-fixnum asm (from-sp dst) (from-sp (slot src)))) (emit-untag-fixnum asm (from-sp dst) (from-sp (slot src))))
(($ $primcall name args) (($ $primcall name #f args)
;; FIXME: Inline all the cases. ;; FIXME: Inline all the cases.
(let ((inst (prim-instruction name))) (let ((inst (prim-instruction name)))
(emit-text asm `((,inst ,(from-sp dst) (emit-text asm `((,inst ,(from-sp dst)
@ -305,79 +305,79 @@
(lookup-parallel-moves handler allocation)) (lookup-parallel-moves handler allocation))
(emit-reset-frame asm frame-size) (emit-reset-frame asm frame-size)
(emit-j asm (forward-label khandler-body)))))) (emit-j asm (forward-label khandler-body))))))
(($ $primcall 'cache-current-module! (sym scope)) (($ $primcall 'cache-current-module! #f (sym scope))
(emit-cache-current-module! asm (from-sp (slot sym)) (constant scope))) (emit-cache-current-module! asm (from-sp (slot sym)) (constant scope)))
(($ $primcall 'free-set! (closure idx value)) (($ $primcall 'free-set! #f (closure idx value))
(emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value)) (emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value))
(constant idx))) (constant idx)))
(($ $primcall 'box-set! (box value)) (($ $primcall 'box-set! #f (box value))
(emit-box-set! asm (from-sp (slot box)) (from-sp (slot value)))) (emit-box-set! asm (from-sp (slot box)) (from-sp (slot value))))
(($ $primcall 'struct-set! (struct index value)) (($ $primcall 'struct-set! #f (struct index value))
(emit-struct-set! asm (from-sp (slot struct)) (from-sp (slot index)) (emit-struct-set! asm (from-sp (slot struct)) (from-sp (slot index))
(from-sp (slot value)))) (from-sp (slot value))))
(($ $primcall 'struct-set!/immediate (struct index value)) (($ $primcall 'struct-set!/immediate #f (struct index value))
(emit-struct-set!/immediate asm (from-sp (slot struct)) (emit-struct-set!/immediate asm (from-sp (slot struct))
(constant index) (from-sp (slot value)))) (constant index) (from-sp (slot value))))
(($ $primcall 'vector-set! (vector index value)) (($ $primcall 'vector-set! #f (vector index value))
(emit-vector-set! asm (from-sp (slot vector)) (from-sp (slot index)) (emit-vector-set! asm (from-sp (slot vector)) (from-sp (slot index))
(from-sp (slot value)))) (from-sp (slot value))))
(($ $primcall 'vector-set!/immediate (vector index value)) (($ $primcall 'vector-set!/immediate #f (vector index value))
(emit-vector-set!/immediate asm (from-sp (slot vector)) (emit-vector-set!/immediate asm (from-sp (slot vector))
(constant index) (from-sp (slot value)))) (constant index) (from-sp (slot value))))
(($ $primcall 'string-set! (string index char)) (($ $primcall 'string-set! #f (string index char))
(emit-string-set! asm (from-sp (slot string)) (from-sp (slot index)) (emit-string-set! asm (from-sp (slot string)) (from-sp (slot index))
(from-sp (slot char)))) (from-sp (slot char))))
(($ $primcall 'set-car! (pair value)) (($ $primcall 'set-car! #f (pair value))
(emit-set-car! asm (from-sp (slot pair)) (from-sp (slot value)))) (emit-set-car! asm (from-sp (slot pair)) (from-sp (slot value))))
(($ $primcall 'set-cdr! (pair value)) (($ $primcall 'set-cdr! #f (pair value))
(emit-set-cdr! asm (from-sp (slot pair)) (from-sp (slot value)))) (emit-set-cdr! asm (from-sp (slot pair)) (from-sp (slot value))))
(($ $primcall 'push-fluid (fluid val)) (($ $primcall 'push-fluid #f (fluid val))
(emit-push-fluid asm (from-sp (slot fluid)) (from-sp (slot val)))) (emit-push-fluid asm (from-sp (slot fluid)) (from-sp (slot val))))
(($ $primcall 'pop-fluid ()) (($ $primcall 'pop-fluid #f ())
(emit-pop-fluid asm)) (emit-pop-fluid asm))
(($ $primcall 'push-dynamic-state (state)) (($ $primcall 'push-dynamic-state #f (state))
(emit-push-dynamic-state asm (from-sp (slot state)))) (emit-push-dynamic-state asm (from-sp (slot state))))
(($ $primcall 'pop-dynamic-state ()) (($ $primcall 'pop-dynamic-state #f ())
(emit-pop-dynamic-state asm)) (emit-pop-dynamic-state asm))
(($ $primcall 'wind (winder unwinder)) (($ $primcall 'wind #f (winder unwinder))
(emit-wind asm (from-sp (slot winder)) (from-sp (slot unwinder)))) (emit-wind asm (from-sp (slot winder)) (from-sp (slot unwinder))))
(($ $primcall 'bv-u8-set! (bv idx val)) (($ $primcall 'bv-u8-set! #f (bv idx val))
(emit-bv-u8-set! asm (from-sp (slot bv)) (from-sp (slot idx)) (emit-bv-u8-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val)))) (from-sp (slot val))))
(($ $primcall 'bv-s8-set! (bv idx val)) (($ $primcall 'bv-s8-set! #f (bv idx val))
(emit-bv-s8-set! asm (from-sp (slot bv)) (from-sp (slot idx)) (emit-bv-s8-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val)))) (from-sp (slot val))))
(($ $primcall 'bv-u16-set! (bv idx val)) (($ $primcall 'bv-u16-set! #f (bv idx val))
(emit-bv-u16-set! asm (from-sp (slot bv)) (from-sp (slot idx)) (emit-bv-u16-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val)))) (from-sp (slot val))))
(($ $primcall 'bv-s16-set! (bv idx val)) (($ $primcall 'bv-s16-set! #f (bv idx val))
(emit-bv-s16-set! asm (from-sp (slot bv)) (from-sp (slot idx)) (emit-bv-s16-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val)))) (from-sp (slot val))))
(($ $primcall 'bv-u32-set! (bv idx val)) (($ $primcall 'bv-u32-set! #f (bv idx val))
(emit-bv-u32-set! asm (from-sp (slot bv)) (from-sp (slot idx)) (emit-bv-u32-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val)))) (from-sp (slot val))))
(($ $primcall 'bv-s32-set! (bv idx val)) (($ $primcall 'bv-s32-set! #f (bv idx val))
(emit-bv-s32-set! asm (from-sp (slot bv)) (from-sp (slot idx)) (emit-bv-s32-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val)))) (from-sp (slot val))))
(($ $primcall 'bv-u64-set! (bv idx val)) (($ $primcall 'bv-u64-set! #f (bv idx val))
(emit-bv-u64-set! asm (from-sp (slot bv)) (from-sp (slot idx)) (emit-bv-u64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val)))) (from-sp (slot val))))
(($ $primcall 'bv-s64-set! (bv idx val)) (($ $primcall 'bv-s64-set! #f (bv idx val))
(emit-bv-s64-set! asm (from-sp (slot bv)) (from-sp (slot idx)) (emit-bv-s64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val)))) (from-sp (slot val))))
(($ $primcall 'bv-f32-set! (bv idx val)) (($ $primcall 'bv-f32-set! #f (bv idx val))
(emit-bv-f32-set! asm (from-sp (slot bv)) (from-sp (slot idx)) (emit-bv-f32-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val)))) (from-sp (slot val))))
(($ $primcall 'bv-f64-set! (bv idx val)) (($ $primcall 'bv-f64-set! #f (bv idx val))
(emit-bv-f64-set! asm (from-sp (slot bv)) (from-sp (slot idx)) (emit-bv-f64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val)))) (from-sp (slot val))))
(($ $primcall 'unwind ()) (($ $primcall 'unwind #f ())
(emit-unwind asm)) (emit-unwind asm))
(($ $primcall 'fluid-set! (fluid value)) (($ $primcall 'fluid-set! #f (fluid value))
(emit-fluid-set! asm (from-sp (slot fluid)) (from-sp (slot value)))) (emit-fluid-set! asm (from-sp (slot fluid)) (from-sp (slot value))))
(($ $primcall 'atomic-box-set! (box val)) (($ $primcall 'atomic-box-set! #f (box val))
(emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val)))) (emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val))))
(($ $primcall 'handle-interrupts ()) (($ $primcall 'handle-interrupts #f ())
(emit-handle-interrupts asm)))) (emit-handle-interrupts asm))))
(define (compile-values label exp syms) (define (compile-values label exp syms)
@ -417,48 +417,48 @@
(define (binary-test op a b) (define (binary-test op a b)
(binary op emit-je emit-jne a b)) (binary op emit-je emit-jne a b))
(match exp (match exp
(($ $primcall 'heap-object? (a)) (unary emit-heap-object? a)) (($ $primcall 'heap-object? #f (a)) (unary emit-heap-object? a))
(($ $primcall 'null? (a)) (unary emit-null? a)) (($ $primcall 'null? #f (a)) (unary emit-null? a))
(($ $primcall 'nil? (a)) (unary emit-nil? a)) (($ $primcall 'nil? #f (a)) (unary emit-nil? a))
(($ $primcall 'false? (a)) (unary emit-false? a)) (($ $primcall 'false? #f (a)) (unary emit-false? a))
(($ $primcall 'pair? (a)) (unary emit-pair? a)) (($ $primcall 'pair? #f (a)) (unary emit-pair? a))
(($ $primcall 'struct? (a)) (unary emit-struct? a)) (($ $primcall 'struct? #f (a)) (unary emit-struct? a))
(($ $primcall 'char? (a)) (unary emit-char? a)) (($ $primcall 'char? #f (a)) (unary emit-char? a))
(($ $primcall 'symbol? (a)) (unary emit-symbol? a)) (($ $primcall 'symbol? #f (a)) (unary emit-symbol? a))
(($ $primcall 'variable? (a)) (unary emit-variable? a)) (($ $primcall 'variable? #f (a)) (unary emit-variable? a))
(($ $primcall 'vector? (a)) (unary emit-vector? a)) (($ $primcall 'vector? #f (a)) (unary emit-vector? a))
(($ $primcall 'string? (a)) (unary emit-string? a)) (($ $primcall 'string? #f (a)) (unary emit-string? a))
(($ $primcall 'bytevector? (a)) (unary emit-bytevector? a)) (($ $primcall 'bytevector? #f (a)) (unary emit-bytevector? a))
(($ $primcall 'bitvector? (a)) (unary emit-bitvector? a)) (($ $primcall 'bitvector? #f (a)) (unary emit-bitvector? a))
(($ $primcall 'keyword? (a)) (unary emit-keyword? a)) (($ $primcall 'keyword? #f (a)) (unary emit-keyword? a))
(($ $primcall 'heap-number? (a)) (unary emit-heap-number? a)) (($ $primcall 'heap-number? #f (a)) (unary emit-heap-number? a))
(($ $primcall 'fixnum? (a)) (unary emit-fixnum? a)) (($ $primcall 'fixnum? #f (a)) (unary emit-fixnum? a))
;; Add more TC7 tests here. Keep in sync with ;; Add more TC7 tests here. Keep in sync with
;; *branching-primcall-arities* in (language cps primitives) and ;; *branching-primcall-arities* in (language cps primitives) and
;; the set of macro-instructions in assembly.scm. ;; the set of macro-instructions in assembly.scm.
(($ $primcall 'eq? (a b)) (binary-test emit-eq? a b)) (($ $primcall 'eq? #f (a b)) (binary-test emit-eq? a b))
(($ $primcall 'heap-numbers-equal? (a b)) (($ $primcall 'heap-numbers-equal? #f (a b))
(binary-test emit-heap-numbers-equal? a b)) (binary-test emit-heap-numbers-equal? a b))
(($ $primcall '< (a b)) (binary emit-<? emit-jl emit-jnl a b)) (($ $primcall '< #f (a b)) (binary emit-<? emit-jl emit-jnl a b))
(($ $primcall '<= (a b)) (binary emit-<? emit-jge emit-jnge b a)) (($ $primcall '<= #f (a b)) (binary emit-<? emit-jge emit-jnge b a))
(($ $primcall '= (a b)) (binary-test emit-=? a b)) (($ $primcall '= #f (a b)) (binary-test emit-=? a b))
(($ $primcall '>= (a b)) (binary emit-<? emit-jge emit-jnge a b)) (($ $primcall '>= #f (a b)) (binary emit-<? emit-jge emit-jnge a b))
(($ $primcall '> (a b)) (binary emit-<? emit-jl emit-jnl b a)) (($ $primcall '> #f (a b)) (binary emit-<? emit-jl emit-jnl b a))
(($ $primcall 'u64-< (a b)) (binary emit-u64<? emit-jl emit-jnl a b)) (($ $primcall 'u64-< #f (a b)) (binary emit-u64<? emit-jl emit-jnl a b))
(($ $primcall 'u64-<= (a b)) (binary emit-u64<? emit-jnl emit-jl b a)) (($ $primcall 'u64-<= #f (a b)) (binary emit-u64<? emit-jnl emit-jl b a))
(($ $primcall 'u64-= (a b)) (binary-test emit-u64=? a b)) (($ $primcall 'u64-= #f (a b)) (binary-test emit-u64=? a b))
(($ $primcall 'u64->= (a b)) (binary emit-u64<? emit-jnl emit-jl a b)) (($ $primcall 'u64->= #f (a b)) (binary emit-u64<? emit-jnl emit-jl a b))
(($ $primcall 'u64-> (a b)) (binary emit-u64<? emit-jl emit-jnl b a)) (($ $primcall 'u64-> #f (a b)) (binary emit-u64<? emit-jl emit-jnl b a))
(($ $primcall 's64-< (a b)) (binary emit-s64<? emit-jl emit-jnl a b)) (($ $primcall 's64-< #f (a b)) (binary emit-s64<? emit-jl emit-jnl a b))
(($ $primcall 's64-<= (a b)) (binary emit-s64<? emit-jnl emit-jl b a)) (($ $primcall 's64-<= #f (a b)) (binary emit-s64<? emit-jnl emit-jl b a))
(($ $primcall 's64-= (a b)) (binary-test emit-s64=? a b)) (($ $primcall 's64-= #f (a b)) (binary-test emit-s64=? a b))
(($ $primcall 's64->= (a b)) (binary emit-s64<? emit-jnl emit-jl a b)) (($ $primcall 's64->= #f (a b)) (binary emit-s64<? emit-jnl emit-jl a b))
(($ $primcall 's64-> (a b)) (binary emit-s64<? emit-jl emit-jnl b a)) (($ $primcall 's64-> #f (a b)) (binary emit-s64<? emit-jl emit-jnl b a))
(($ $primcall 'f64-< (a b)) (binary emit-f64<? emit-jl emit-jnl a b)) (($ $primcall 'f64-< #f (a b)) (binary emit-f64<? emit-jl emit-jnl a b))
(($ $primcall 'f64-<= (a b)) (binary emit-f64<? emit-jge emit-jnge b a)) (($ $primcall 'f64-<= #f (a b)) (binary emit-f64<? emit-jge emit-jnge b a))
(($ $primcall 'f64-= (a b)) (binary-test emit-f64=? a b)) (($ $primcall 'f64-= #f (a b)) (binary-test emit-f64=? a b))
(($ $primcall 'f64->= (a b)) (binary emit-f64<? emit-jge emit-jnge a b)) (($ $primcall 'f64->= #f (a b)) (binary emit-f64<? emit-jge emit-jnge a b))
(($ $primcall 'f64-> (a b)) (binary emit-f64<? emit-jl emit-jnl b a)))) (($ $primcall 'f64-> #f (a b)) (binary emit-f64<? emit-jl emit-jnl b a))))
(define (compile-trunc label k exp nreq rest-var) (define (compile-trunc label k exp nreq rest-var)
(define (do-call proc args emit-call) (define (do-call proc args emit-call)

18
module/language/cps/constructors.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -42,13 +42,13 @@
(letv tail) (letv tail)
(letk ktail ($kargs ('tail) (tail) (letk ktail ($kargs ('tail) (tail)
($continue k src ($continue k src
($primcall 'cons (arg tail))))) ($primcall 'cons #f (arg tail)))))
($ (build-list args ktail)))))) ($ (build-list args ktail))))))
(with-cps out (with-cps out
(letv val) (letv val)
(letk kvalues ($kargs ('val) (val) (letk kvalues ($kargs ('val) (val)
($continue k src ($continue k src
($primcall 'values (val))))) ($primcall 'values #f (val)))))
($ (build-list args kvalues)))) ($ (build-list args kvalues))))
(define (inline-vector out k src args) (define (inline-vector out k src args)
@ -56,7 +56,7 @@
(match args (match args
(() (()
(with-cps out (with-cps out
(build-term ($continue k src ($primcall 'values (vec)))))) (build-term ($continue k src ($primcall 'values #f (vec))))))
((arg . args) ((arg . args)
(with-cps out (with-cps out
(let$ next (initialize vec args (1+ n))) (let$ next (initialize vec args (1+ n)))
@ -64,10 +64,10 @@
(letv u64) (letv u64)
(letk kunbox ($kargs ('idx) (u64) (letk kunbox ($kargs ('idx) (u64)
($continue knext src ($continue knext src
($primcall 'vector-set! (vec u64 arg))))) ($primcall 'vector-set! #f (vec u64 arg)))))
($ (with-cps-constants ((idx n)) ($ (with-cps-constants ((idx n))
(build-term ($continue kunbox src (build-term ($continue kunbox src
($primcall 'scm->u64 (idx)))))))))) ($primcall 'scm->u64 #f (idx))))))))))
(with-cps out (with-cps out
(letv vec) (letv vec)
(let$ body (initialize vec args 0)) (let$ body (initialize vec args 0))
@ -77,9 +77,9 @@
(letv u64) (letv u64)
(letk kunbox ($kargs ('len) (u64) (letk kunbox ($kargs ('len) (u64)
($continue kalloc src ($continue kalloc src
($primcall 'make-vector (u64 init))))) ($primcall 'make-vector #f (u64 init)))))
(build-term ($continue kunbox src (build-term ($continue kunbox src
($primcall 'scm->u64 (len)))))))) ($primcall 'scm->u64 #f (len))))))))
(define (find-constructor-inliner name) (define (find-constructor-inliner name)
(match name (match name
@ -93,7 +93,7 @@
(intmap-fold (intmap-fold
(lambda (label cont out) (lambda (label cont out)
(match cont (match cont
(($ $kargs names vars ($ $continue k src ($ $primcall name args))) (($ $kargs names vars ($ $continue k src ($ $primcall name #f args)))
(let ((inline (find-constructor-inliner name))) (let ((inline (find-constructor-inliner name)))
(if inline (if inline
(call-with-values (lambda () (inline out k src args)) (call-with-values (lambda () (inline out k src args))

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

@ -186,9 +186,9 @@ $call, and are always called with a compatible arity."
(restrict-arity functions proc (length args)))) (restrict-arity functions proc (length args))))
(($ $callk k proc args) (($ $callk k proc args)
(exclude-vars functions (cons proc args))) (exclude-vars functions (cons proc args)))
(($ $branch kt ($ $primcall name args)) (($ $branch kt ($ $primcall name param args))
(exclude-vars functions args)) (exclude-vars functions args))
(($ $primcall name args) (($ $primcall name param args)
(exclude-vars functions args)) (exclude-vars functions args))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(exclude-var functions tag)))) (exclude-var functions tag))))
@ -394,7 +394,7 @@ function set."
;; continue to $kreceive. ;; continue to $kreceive.
(($ $primcall) exp) (($ $primcall) exp)
(($ $values vals) (($ $values vals)
(build-exp ($primcall 'values vals))))) (build-exp ($primcall 'values #f vals)))))
(($ $ktail) exp))))))) (($ $ktail) exp)))))))
(define (visit-exp k src exp) (define (visit-exp k src exp)
(match exp (match exp

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

@ -249,10 +249,10 @@ false. It could be that both true and false proofs are available."
(($ $closure label nfree) #f) (($ $closure label nfree) #f)
(($ $call proc args) #f) (($ $call proc args) #f)
(($ $callk k proc args) #f) (($ $callk k proc args) #f)
(($ $primcall name args) (($ $primcall name param args)
(cons* 'primcall name (subst-vars var-substs args))) (cons* 'primcall name param (subst-vars var-substs args)))
(($ $branch _ ($ $primcall name args)) (($ $branch _ ($ $primcall name param args))
(cons* 'primcall name (subst-vars var-substs args))) (cons* 'primcall name param (subst-vars var-substs args)))
(($ $values args) #f) (($ $values args) #f)
(($ $prompt escape? tag handler) #f))) (($ $prompt escape? tag handler) #f)))
@ -265,64 +265,64 @@ false. It could be that both true and false proofs are available."
(hash-set! equiv-set aux-key (hash-set! equiv-set aux-key
(acons label (list var) equiv)))) (acons label (list var) equiv))))
(match exp-key (match exp-key
(('primcall 'box val) (('primcall 'box #f val)
(match defs (match defs
((box) ((box)
(add-def! `(primcall box-ref ,(subst box)) val)))) (add-def! `(primcall box-ref #f ,(subst box)) val))))
(('primcall 'box-set! box val) (('primcall 'box-set! #f box val)
(add-def! `(primcall box-ref ,box) val)) (add-def! `(primcall box-ref #f ,box) val))
(('primcall 'cons car cdr) (('primcall 'cons #f car cdr)
(match defs (match defs
((pair) ((pair)
(add-def! `(primcall car ,(subst pair)) car) (add-def! `(primcall car #f ,(subst pair)) car)
(add-def! `(primcall cdr ,(subst pair)) cdr)))) (add-def! `(primcall cdr #f ,(subst pair)) cdr))))
(('primcall 'set-car! pair car) (('primcall 'set-car! #f pair car)
(add-def! `(primcall car ,pair) car)) (add-def! `(primcall car #f ,pair) car))
(('primcall 'set-cdr! pair cdr) (('primcall 'set-cdr! #f pair cdr)
(add-def! `(primcall cdr ,pair) cdr)) (add-def! `(primcall cdr #f ,pair) cdr))
(('primcall (or 'make-vector 'make-vector/immediate) len fill) (('primcall (or 'make-vector 'make-vector/immediate) #f len fill)
(match defs (match defs
((vec) ((vec)
(add-def! `(primcall vector-length ,(subst vec)) len)))) (add-def! `(primcall vector-length #f ,(subst vec)) len))))
(('primcall 'vector-set! vec idx val) (('primcall 'vector-set! #f vec idx val)
(add-def! `(primcall vector-ref ,vec ,idx) val)) (add-def! `(primcall vector-ref #f ,vec ,idx) val))
(('primcall 'vector-set!/immediate vec idx val) (('primcall 'vector-set!/immediate #f vec idx val)
(add-def! `(primcall vector-ref/immediate ,vec ,idx) val)) (add-def! `(primcall vector-ref/immediate #f ,vec ,idx) val))
(('primcall (or 'allocate-struct 'allocate-struct/immediate) (('primcall (or 'allocate-struct 'allocate-struct/immediate) #f
vtable size) vtable size)
(match defs (match defs
((struct) ((struct)
(add-def! `(primcall struct-vtable ,(subst struct)) (add-def! `(primcall struct-vtable #f ,(subst struct))
vtable)))) vtable))))
(('primcall 'struct-set! struct n val) (('primcall 'struct-set! #f struct n val)
(add-def! `(primcall struct-ref ,struct ,n) val)) (add-def! `(primcall struct-ref #f ,struct ,n) val))
(('primcall 'struct-set!/immediate struct n val) (('primcall 'struct-set!/immediate #f struct n val)
(add-def! `(primcall struct-ref/immediate ,struct ,n) val)) (add-def! `(primcall struct-ref/immediate #f ,struct ,n) val))
(('primcall 'scm->f64 scm) (('primcall 'scm->f64 #f scm)
(match defs (match defs
((f64) ((f64)
(add-def! `(primcall f64->scm ,f64) scm)))) (add-def! `(primcall f64->scm #f ,f64) scm))))
(('primcall 'f64->scm f64) (('primcall 'f64->scm #f f64)
(match defs (match defs
((scm) ((scm)
(add-def! `(primcall scm->f64 ,scm) f64)))) (add-def! `(primcall scm->f64 #f ,scm) f64))))
(('primcall 'scm->u64 scm) (('primcall 'scm->u64 #f scm)
(match defs (match defs
((u64) ((u64)
(add-def! `(primcall u64->scm ,u64) scm)))) (add-def! `(primcall u64->scm #f ,u64) scm))))
(('primcall (or 'u64->scm 'u64->scm/unlikely) u64) (('primcall (or 'u64->scm 'u64->scm/unlikely) #f u64)
(match defs (match defs
((scm) ((scm)
(add-def! `(primcall scm->u64 ,scm) u64) (add-def! `(primcall scm->u64 #f ,scm) u64)
(add-def! `(primcall scm->u64/truncate ,scm) u64)))) (add-def! `(primcall scm->u64/truncate #f ,scm) u64))))
(('primcall 'scm->s64 scm) (('primcall 'scm->s64 #f scm)
(match defs (match defs
((s64) ((s64)
(add-def! `(primcall s64->scm ,s64) scm)))) (add-def! `(primcall s64->scm #f ,s64) scm))))
(('primcall (or 's64->scm 's64->scm/unlikely) s64) (('primcall (or 's64->scm 's64->scm/unlikely) #f s64)
(match defs (match defs
((scm) ((scm)
(add-def! `(primcall scm->s64 ,scm) s64)))) (add-def! `(primcall scm->s64 #f ,scm) s64))))
(_ #t)))) (_ #t))))
(define (visit-label label equiv-labels var-substs) (define (visit-label label equiv-labels var-substs)
@ -405,8 +405,8 @@ false. It could be that both true and false proofs are available."
($call (subst-var proc) ,(map subst-var args))) ($call (subst-var proc) ,(map subst-var args)))
(($ $callk k proc args) (($ $callk k proc args)
($callk k (subst-var proc) ,(map subst-var args))) ($callk k (subst-var proc) ,(map subst-var args)))
(($ $primcall name args) (($ $primcall name param args)
($primcall name ,(map subst-var args))) ($primcall name param ,(map subst-var args)))
(($ $branch k exp) (($ $branch k exp)
($branch k ,(visit-exp exp))) ($branch k ,(visit-exp exp)))
(($ $values args) (($ $values args)

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

@ -149,9 +149,9 @@ sites."
(($ $callk kfun proc args) (($ $callk kfun proc args)
(values (intset-add live-labels kfun) (values (intset-add live-labels kfun)
(adjoin-vars args (adjoin-var proc live-vars)))) (adjoin-vars args (adjoin-var proc live-vars))))
(($ $primcall name args) (($ $primcall name param args)
(values live-labels (adjoin-vars args live-vars))) (values live-labels (adjoin-vars args live-vars)))
(($ $branch k ($ $primcall name args)) (($ $branch k ($ $primcall name param args))
(values live-labels (adjoin-vars args live-vars))) (values live-labels (adjoin-vars args live-vars)))
(($ $values args) (($ $values args)
(values live-labels (values live-labels
@ -191,7 +191,7 @@ sites."
(($ $primcall (($ $primcall
(or 'vector-set! 'vector-set!/immediate (or 'vector-set! 'vector-set!/immediate
'set-car! 'set-cdr! 'set-car! 'set-cdr!
'box-set!) 'box-set!) #f
(obj . _)) (obj . _))
(or (var-live? obj live-vars) (or (var-live? obj live-vars)
(not (intset-ref known-allocations obj)))) (not (intset-ref known-allocations obj))))

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

@ -538,7 +538,7 @@ is or might be a read or a write to the same location as A."
&all-effects) &all-effects)
(($ $branch k exp) (($ $branch k exp)
(expression-effects exp constants)) (expression-effects exp constants))
(($ $primcall name args) (($ $primcall name param args)
(primitive-effects constants name args)))) (primitive-effects constants name args))))
(define (compute-effects conts) (define (compute-effects conts)

6
module/language/cps/elide-values.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -59,7 +59,7 @@
(with-cps cps (with-cps cps
(letv rest) (letv rest)
(letk krest ($kargs ('rest) (rest) (letk krest ($kargs ('rest) (rest)
($continue k src ($primcall 'cons (v rest))))) ($continue k src ($primcall 'cons #f (v rest)))))
($ (build-rest krest tail)))))) ($ (build-rest krest tail))))))
(with-cps cps (with-cps cps
(letv rest) (letv rest)
@ -76,7 +76,7 @@
(intmap-fold (intmap-fold
(lambda (label cont out) (lambda (label cont out)
(match cont (match cont
(($ $kargs names vars ($ $continue k src ($ $primcall 'values args))) (($ $kargs names vars ($ $continue k src ($ $primcall 'values #f args)))
(call-with-values (lambda () (inline-values out k src args)) (call-with-values (lambda () (inline-values out k src args))
(lambda (out term) (lambda (out term)
(if term (if term

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2016 Free Software Foundation, Inc. ;; Copyright (C) 2016, 2017 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -62,7 +62,7 @@
(setk label (setk label
($kargs names vars ($kargs names vars
($continue k* src ($continue k* src
($primcall 'handle-interrupts ())))))))) ($primcall 'handle-interrupts #f ()))))))))
(let* ((cps (renumber cps)) (let* ((cps (renumber cps))
(safepoints (compute-safepoints cps))) (safepoints (compute-safepoints cps)))
(with-fresh-name-state cps (with-fresh-name-state cps

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -70,8 +70,8 @@
((or ($ $const) ($ $prim) ($ $closure)) #t) ((or ($ $const) ($ $prim) ($ $closure)) #t)
(($ $prompt) #f) ;; ? (($ $prompt) #f) ;; ?
(($ $branch) #f) (($ $branch) #f)
(($ $primcall 'values) #f) (($ $primcall 'values #f) #f)
(($ $primcall name args) (($ $primcall name param args)
(and-map (lambda (arg) (not (intset-ref loop-vars arg))) (and-map (lambda (arg) (not (intset-ref loop-vars arg)))
args)) args))
(($ $values args) (($ $values args)

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

@ -141,10 +141,10 @@
($call (rename-var proc) ,(map rename-var args))) ($call (rename-var proc) ,(map rename-var args)))
(($ $callk k proc args) (($ $callk k proc args)
($callk k (rename-var proc) ,(map rename-var args))) ($callk k (rename-var proc) ,(map rename-var args)))
(($ $branch kt ($ $primcall name args)) (($ $branch kt ($ $primcall name param args))
($branch (rename-label kt) ($primcall name ,(map rename-var args)))) ($branch (rename-label kt) ($primcall name param ,(map rename-var args))))
(($ $primcall name args) (($ $primcall name param args)
($primcall name ,(map rename-var args))) ($primcall name param ,(map rename-var args)))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) (rename-label handler))))) ($prompt escape? (rename-var tag) (rename-label handler)))))
(rewrite-cont cont (rewrite-cont cont

2
module/language/cps/prune-bailouts.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public

6
module/language/cps/prune-top-level-scopes.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. ;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -37,7 +37,7 @@
(match cont (match cont
(($ $kargs _ _ (($ $kargs _ _
($ $continue k src ($ $continue k src
($ $primcall 'cached-toplevel-box (scope name bound?)))) ($ $primcall 'cached-toplevel-box #f (scope name bound?))))
(intset-add! used-scopes (intmap-ref constants scope))) (intset-add! used-scopes (intmap-ref constants scope)))
(_ (_
used-scopes))) used-scopes)))
@ -52,7 +52,7 @@
(match cont (match cont
(($ $kargs names vars (($ $kargs names vars
($ $continue k src ($ $continue k src
($ $primcall 'cache-current-module! ($ $primcall 'cache-current-module! #f
(module (? (lambda (scope) (module (? (lambda (scope)
(let ((val (intmap-ref constants scope))) (let ((val (intmap-ref constants scope)))
(not (intset-ref used-scopes val))))))))) (not (intset-ref used-scopes val)))))))))

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -44,7 +44,7 @@
(public? public?) (public? public?)
(bound? bound?)) (bound? bound?))
(build-term ($continue kbox src (build-term ($continue kbox src
($primcall 'cached-module-box ($primcall 'cached-module-box #f
(module name public? bound?)))))))) (module name public? bound?))))))))
(define (primitive-module name) (define (primitive-module name)
@ -95,13 +95,13 @@
(lambda (cps box) (lambda (cps box)
(with-cps cps (with-cps cps
(build-term (build-term
($continue k src ($primcall 'box-ref (box)))))))) ($continue k src ($primcall 'box-ref #f (box))))))))
(define (builtin-ref cps idx k src) (define (builtin-ref cps idx k src)
(with-cps cps (with-cps cps
($ (with-cps-constants ((idx idx)) ($ (with-cps-constants ((idx idx))
(build-term (build-term
($continue k src ($primcall 'builtin-ref (idx)))))))) ($continue k src ($primcall 'builtin-ref #f (idx))))))))
(define (reify-clause cps ktail) (define (reify-clause cps ktail)
(with-cps cps (with-cps cps
@ -149,20 +149,23 @@
(let$ body (resolve-prim name k src)) (let$ body (resolve-prim name k src))
(setk label ($kargs names vars ,body)))) (setk label ($kargs names vars ,body))))
(($ $kargs names vars (($ $kargs names vars
($ $continue k src ($ $primcall 'call-thunk/no-inline (proc)))) ($ $continue k src ($ $primcall 'call-thunk/no-inline #f (proc))))
(with-cps cps (with-cps cps
(setk label ($kargs names vars ($continue k src ($call proc ())))))) (setk label ($kargs names vars ($continue k src ($call proc ()))))))
(($ $kargs names vars ($ $continue k src ($ $primcall name args))) (($ $kargs names vars ($ $continue k src ($ $primcall name param args)))
(if (or (prim-instruction name) (branching-primitive? name)) (cond
;; Assume arities are correct. ((or (prim-instruction name) (branching-primitive? name))
cps ;; Assume arities are correct.
(with-cps cps cps)
(letv proc) (param (error "unexpected param to reified primcall" name))
(let$ k (uniquify-receive k)) (else
(letk kproc ($kargs ('proc) (proc) (with-cps cps
($continue k src ($call proc args)))) (letv proc)
(let$ body (resolve-prim name kproc src)) (let$ k (uniquify-receive k))
(setk label ($kargs names vars ,body))))) (letk kproc ($kargs ('proc) (proc)
($continue k src ($call proc args))))
(let$ body (resolve-prim name kproc src))
(setk label ($kargs names vars ,body))))))
(($ $kargs names vars ($ $continue k src ($ $call proc args))) (($ $kargs names vars ($ $continue k src ($ $call proc args)))
(with-cps cps (with-cps cps
(let$ k (uniquify-receive k)) (let$ k (uniquify-receive k))

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -179,8 +179,8 @@
($callk (rename-label k) (rename-var proc) ,(map rename-var args))) ($callk (rename-label k) (rename-var proc) ,(map rename-var args)))
(($ $branch kt exp) (($ $branch kt exp)
($branch (rename-label kt) ,(rename-exp exp))) ($branch (rename-label kt) ,(rename-exp exp)))
(($ $primcall name args) (($ $primcall name param args)
($primcall name ,(map rename-var args))) ($primcall name param ,(map rename-var args)))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) (rename-label handler))))) ($prompt escape? (rename-var tag) (rename-label handler)))))
(define (rename-arity arity) (define (rename-arity arity)

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

@ -108,10 +108,10 @@
($call (rename-var proc) ,(map rename-var args))) ($call (rename-var proc) ,(map rename-var args)))
(($ $callk k proc args) (($ $callk k proc args)
($callk k (rename-var proc) ,(map rename-var args))) ($callk k (rename-var proc) ,(map rename-var args)))
(($ $branch kt ($ $primcall name args)) (($ $branch kt ($ $primcall name param args))
($branch kt ($primcall name ,(map rename-var args)))) ($branch kt ($primcall name param ,(map rename-var args))))
(($ $primcall name args) (($ $primcall name param args)
($primcall name ,(map rename-var args))) ($primcall name param ,(map rename-var args)))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) handler)))) ($prompt escape? (rename-var tag) handler))))
(define (attach-trampoline label src names vars args) (define (attach-trampoline label src names vars args)

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

@ -43,10 +43,10 @@
($call (subst proc) ,(map subst args))) ($call (subst proc) ,(map subst args)))
(($ $callk k proc args) (($ $callk k proc args)
($callk k (subst proc) ,(map subst args))) ($callk k (subst proc) ,(map subst args)))
(($ $primcall name args) (($ $primcall name param args)
($primcall name ,(map subst args))) ($primcall name param ,(map subst args)))
(($ $branch k ($ $primcall name args)) (($ $branch k ($ $primcall name param args))
($branch k ($primcall name ,(map subst args)))) ($branch k ($primcall name param ,(map subst args))))
(($ $values args) (($ $values args)
($values ,(map subst args))) ($values ,(map subst args)))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)

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

@ -74,11 +74,11 @@
(ref* (cons proc args))) (ref* (cons proc args)))
(($ $callk k proc args) (($ $callk k proc args)
(ref* (cons proc args))) (ref* (cons proc args)))
(($ $primcall name args) (($ $primcall name param args)
(ref* args)) (ref* args))
(($ $values args) (($ $values args)
(ref* args)) (ref* args))
(($ $branch kt ($ $primcall name args)) (($ $branch kt ($ $primcall name param args))
(ref* args)) (ref* args))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(ref tag)))) (ref tag))))
@ -152,7 +152,7 @@
(($ $kargs (_) (($ $kargs (_)
((? (lambda (var) (intset-ref singly-used var)) ((? (lambda (var) (intset-ref singly-used var))
var)) var))
($ $continue kf _ ($ $branch kt ($ $primcall 'false? (var))))) ($ $continue kf _ ($ $branch kt ($ $primcall 'false? #f (var)))))
(build-cont (build-cont
($kargs names syms ($kargs names syms
($continue (subst (if val kf kt)) src ($values ()))))) ($continue (subst (if val kf kt)) src ($values ())))))
@ -249,12 +249,12 @@
($call (subst proc) ,(map subst args))) ($call (subst proc) ,(map subst args)))
(($ $callk k proc args) (($ $callk k proc args)
($callk k (subst proc) ,(map subst args))) ($callk k (subst proc) ,(map subst args)))
(($ $primcall name args) (($ $primcall name param args)
($primcall name ,(map subst args))) ($primcall name param ,(map subst args)))
(($ $values args) (($ $values args)
($values ,(map subst args))) ($values ,(map subst args)))
(($ $branch kt ($ $primcall name args)) (($ $branch kt ($ $primcall name param args))
($branch kt ($primcall name ,(map subst args)))) ($branch kt ($primcall name param ,(map subst args))))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler))))))) ($prompt escape? (subst tag) handler)))))))
(transform-conts (transform-conts

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

@ -172,9 +172,9 @@ by a label, respectively."
(return (get-defs k) (intset-add (vars->intset args) proc))) (return (get-defs k) (intset-add (vars->intset args) proc)))
(($ $callk _ proc args) (($ $callk _ proc args)
(return (get-defs k) (intset-add (vars->intset args) proc))) (return (get-defs k) (intset-add (vars->intset args) proc)))
(($ $primcall name args) (($ $primcall name param args)
(return (get-defs k) (vars->intset args))) (return (get-defs k) (vars->intset args)))
(($ $branch kt ($ $primcall name args)) (($ $branch kt ($ $primcall name param args))
(return empty-intset (vars->intset args))) (return empty-intset (vars->intset args)))
(($ $values args) (($ $values args)
(return (get-defs k) (vars->intset args))) (return (get-defs k) (vars->intset args)))
@ -333,38 +333,40 @@ the definitions that are live before and after LABEL, as intsets."
(match exp (match exp
(($ $const) (($ $const)
empty-intset) empty-intset)
(($ $primcall (or 'load-f64 'load-u64 'load-s64) (val)) ;; FIXME: Move all of these instructions to use $primcall
;; params.
(($ $primcall (or 'load-f64 'load-u64 'load-s64) #f (val))
empty-intset) empty-intset)
(($ $primcall 'free-ref (closure slot)) (($ $primcall 'free-ref #f (closure slot))
(defs+ closure)) (defs+ closure))
(($ $primcall 'free-set! (closure slot value)) (($ $primcall 'free-set! #f (closure slot value))
(defs+* (intset closure value))) (defs+* (intset closure value)))
(($ $primcall 'cache-current-module! (mod . _)) (($ $primcall 'cache-current-module! #f (mod . _))
(defs+ mod)) (defs+ mod))
(($ $primcall 'cached-toplevel-box _) (($ $primcall 'cached-toplevel-box #f _)
defs) defs)
(($ $primcall 'cached-module-box _) (($ $primcall 'cached-module-box #f _)
defs) defs)
(($ $primcall 'resolve (name bound?)) (($ $primcall 'resolve #f (name bound?))
(defs+ name)) (defs+ name))
(($ $primcall 'make-vector/immediate (len init)) (($ $primcall 'make-vector/immediate #f (len init))
(defs+ init)) (defs+ init))
(($ $primcall 'vector-ref/immediate (v i)) (($ $primcall 'vector-ref/immediate #f (v i))
(defs+ v)) (defs+ v))
(($ $primcall 'vector-set!/immediate (v i x)) (($ $primcall 'vector-set!/immediate #f (v i x))
(defs+* (intset v x))) (defs+* (intset v x)))
(($ $primcall 'allocate-struct/immediate (vtable nfields)) (($ $primcall 'allocate-struct/immediate #f (vtable nfields))
(defs+ vtable)) (defs+ vtable))
(($ $primcall 'struct-ref/immediate (s n)) (($ $primcall 'struct-ref/immediate #f (s n))
(defs+ s)) (defs+ s))
(($ $primcall 'struct-set!/immediate (s n x)) (($ $primcall 'struct-set!/immediate #f (s n x))
(defs+* (intset s x))) (defs+* (intset s x)))
(($ $primcall (or 'add/immediate 'sub/immediate (($ $primcall (or 'add/immediate 'sub/immediate
'uadd/immediate 'usub/immediate 'umul/immediate 'uadd/immediate 'usub/immediate 'umul/immediate
'ursh/immediate 'ulsh/immediate) 'ursh/immediate 'ulsh/immediate) #f
(x y)) (x y))
(defs+ x)) (defs+ x))
(($ $primcall 'builtin-ref (idx)) (($ $primcall 'builtin-ref #f (idx))
defs) defs)
(_ (_
(defs+* (get-uses label)))))) (defs+* (get-uses label))))))

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

@ -71,16 +71,16 @@
(letv f64-a f64-b result) (letv f64-a f64-b result)
(letk kbox ($kargs ('result) (result) (letk kbox ($kargs ('result) (result)
($continue k src ($continue k src
($primcall 'f64->scm (result))))) ($primcall 'f64->scm #f (result)))))
(letk kop ($kargs ('f64-b) (f64-b) (letk kop ($kargs ('f64-b) (f64-b)
($continue kbox src ($continue kbox src
($primcall fop (f64-a f64-b))))) ($primcall fop #f (f64-a f64-b)))))
(letk kunbox-b ($kargs ('f64-a) (f64-a) (letk kunbox-b ($kargs ('f64-a) (f64-a)
($continue kop src ($continue kop src
($primcall 'scm->f64 (b))))) ($primcall 'scm->f64 #f (b)))))
(build-term (build-term
($continue kunbox-b src ($continue kunbox-b src
($primcall 'scm->f64 (a))))))) ($primcall 'scm->f64 #f (a)))))))
(define* (specialize-u64-binop cps k src op a b #:key (define* (specialize-u64-binop cps k src op a b #:key
(unbox-a 'scm->u64) (unbox-a 'scm->u64)
@ -99,26 +99,26 @@
(letv u64-a u64-b result) (letv u64-a u64-b result)
(letk kbox ($kargs ('result) (result) (letk kbox ($kargs ('result) (result)
($continue k src ($continue k src
($primcall 'u64->scm (result))))) ($primcall 'u64->scm #f (result)))))
(letk kop ($kargs ('u64-b) (u64-b) (letk kop ($kargs ('u64-b) (u64-b)
($continue kbox src ($continue kbox src
($primcall uop (u64-a u64-b))))) ($primcall uop #f (u64-a u64-b)))))
(letk kunbox-b ($kargs ('u64-a) (u64-a) (letk kunbox-b ($kargs ('u64-a) (u64-a)
($continue kop src ($continue kop src
($primcall unbox-b (b))))) ($primcall unbox-b #f (b)))))
(build-term (build-term
($continue kunbox-b src ($continue kunbox-b src
($primcall unbox-a (a))))))) ($primcall unbox-a #f (a)))))))
(define (truncate-u64 cps k src scm) (define (truncate-u64 cps k src scm)
(with-cps cps (with-cps cps
(letv u64) (letv u64)
(letk kbox ($kargs ('u64) (u64) (letk kbox ($kargs ('u64) (u64)
($continue k src ($continue k src
($primcall 'u64->scm (u64))))) ($primcall 'u64->scm #f (u64)))))
(build-term (build-term
($continue kbox src ($continue kbox src
($primcall 'scm->u64/truncate (scm)))))) ($primcall 'scm->u64/truncate #f (scm))))))
(define (specialize-u64-comparison cps kf kt src op a b) (define (specialize-u64-comparison cps kf kt src op a b)
(let ((op (symbol-append 'u64- op))) (let ((op (symbol-append 'u64- op)))
@ -126,13 +126,13 @@
(letv u64-a u64-b) (letv u64-a u64-b)
(letk kop ($kargs ('u64-b) (u64-b) (letk kop ($kargs ('u64-b) (u64-b)
($continue kf src ($continue kf src
($branch kt ($primcall op (u64-a u64-b)))))) ($branch kt ($primcall op #f (u64-a u64-b))))))
(letk kunbox-b ($kargs ('u64-a) (u64-a) (letk kunbox-b ($kargs ('u64-a) (u64-a)
($continue kop src ($continue kop src
($primcall 'scm->u64 (b))))) ($primcall 'scm->u64 #f (b)))))
(build-term (build-term
($continue kunbox-b src ($continue kunbox-b src
($primcall 'scm->u64 (a))))))) ($primcall 'scm->u64 #f (a)))))))
(define (specialize-u64-scm-comparison cps kf kt src op a-u64 b-scm) (define (specialize-u64-scm-comparison cps kf kt src op a-u64 b-scm)
(let ((u64-op (symbol-append 'u64- op))) (let ((u64-op (symbol-append 'u64- op)))
@ -140,33 +140,33 @@
(letv u64 s64 zero z64 sunk) (letv u64 s64 zero z64 sunk)
(letk kheap ($kargs ('sunk) (sunk) (letk kheap ($kargs ('sunk) (sunk)
($continue kf src ($continue kf src
($branch kt ($primcall op (sunk b-scm)))))) ($branch kt ($primcall op #f (sunk b-scm))))))
;; Re-box the variable. FIXME: currently we use a specially ;; Re-box the variable. FIXME: currently we use a specially
;; marked u64->scm to avoid CSE from hoisting the allocation ;; marked u64->scm to avoid CSE from hoisting the allocation
;; again. Instaed we should just use a-u64 directly and implement ;; again. Instaed we should just use a-u64 directly and implement
;; an allocation sinking pass that should handle this.. ;; an allocation sinking pass that should handle this..
(letk kretag ($kargs () () (letk kretag ($kargs () ()
($continue kheap src ($continue kheap src
($primcall 'u64->scm/unlikely (u64))))) ($primcall 'u64->scm/unlikely #f (u64)))))
(letk kcmp ($kargs () () (letk kcmp ($kargs () ()
($continue kf src ($continue kf src
($branch kt ($primcall u64-op (u64 s64)))))) ($branch kt ($primcall u64-op #f (u64 s64))))))
(letk kz64 ($kargs ('z64) (z64) (letk kz64 ($kargs ('z64) (z64)
($continue (case op ((< <= =) kf) (else kt)) src ($continue (case op ((< <= =) kf) (else kt)) src
($branch kcmp ($primcall 's64-<= (z64 s64)))))) ($branch kcmp ($primcall 's64-<= #f (z64 s64))))))
(letk kzero ($kargs ('zero) (zero) (letk kzero ($kargs ('zero) (zero)
($continue kz64 src ($primcall 'load-s64 (zero))))) ($continue kz64 src ($primcall 'load-s64 #f (zero)))))
(letk ks64 ($kargs ('s64) (s64) (letk ks64 ($kargs ('s64) (s64)
($continue kzero src ($const 0)))) ($continue kzero src ($const 0))))
(letk kfix ($kargs () () (letk kfix ($kargs () ()
($continue ks64 src ($continue ks64 src
($primcall 'untag-fixnum (b-scm))))) ($primcall 'untag-fixnum #f (b-scm)))))
(letk ku64 ($kargs ('u64) (u64) (letk ku64 ($kargs ('u64) (u64)
($continue kretag src ($continue kretag src
($branch kfix ($primcall 'fixnum? (b-scm)))))) ($branch kfix ($primcall 'fixnum? #f (b-scm))))))
(build-term (build-term
($continue ku64 src ($continue ku64 src
($primcall 'scm->u64 (a-u64))))))) ($primcall 'scm->u64 #f (a-u64)))))))
(define (specialize-f64-comparison cps kf kt src op a b) (define (specialize-f64-comparison cps kf kt src op a b)
(let ((op (symbol-append 'f64- op))) (let ((op (symbol-append 'f64- op)))
@ -174,13 +174,13 @@
(letv f64-a f64-b) (letv f64-a f64-b)
(letk kop ($kargs ('f64-b) (f64-b) (letk kop ($kargs ('f64-b) (f64-b)
($continue kf src ($continue kf src
($branch kt ($primcall op (f64-a f64-b)))))) ($branch kt ($primcall op #f (f64-a f64-b))))))
(letk kunbox-b ($kargs ('f64-a) (f64-a) (letk kunbox-b ($kargs ('f64-a) (f64-a)
($continue kop src ($continue kop src
($primcall 'scm->f64 (b))))) ($primcall 'scm->f64 #f (b)))))
(build-term (build-term
($continue kunbox-b src ($continue kunbox-b src
($primcall 'scm->f64 (a))))))) ($primcall 'scm->f64 #f (a)))))))
(define (sigbits-union x y) (define (sigbits-union x y)
(and x y (logior x y))) (and x y (logior x y)))
@ -217,7 +217,7 @@
((primop label types out def ...) arg ...) ((primop label types out def ...) arg ...)
body ...) body ...)
(hashq-set! significant-bits-handlers 'primop (hashq-set! significant-bits-handlers 'primop
(lambda (label types out args defs) (lambda (label types out param args defs)
(match args ((arg ...) (match defs ((def ...) body ...))))))) (match args ((arg ...) (match defs ((def ...) body ...)))))))
(define-significant-bits-handler ((logand label types out res) a b) (define-significant-bits-handler ((logand label types out res) a b)
@ -286,14 +286,14 @@ BITS indicating the significant bits needed for a variable. BITS may be
(add-unknown-use (add-unknown-uses out args) proc)) (add-unknown-use (add-unknown-uses out args) proc))
(($ $callk label proc args) (($ $callk label proc args)
(add-unknown-use (add-unknown-uses out args) proc)) (add-unknown-use (add-unknown-uses out args) proc))
(($ $branch kt ($ $primcall name args)) (($ $branch kt ($ $primcall name param args))
(add-unknown-uses out args)) (add-unknown-uses out args))
(($ $primcall name args) (($ $primcall name param args)
(let ((h (significant-bits-handler name))) (let ((h (significant-bits-handler name)))
(if h (if h
(match (intmap-ref cps k) (match (intmap-ref cps k)
(($ $kargs _ defs) (($ $kargs _ defs)
(h label types out args defs))) (h label types out param args defs)))
(add-unknown-uses out args)))) (add-unknown-uses out args))))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(add-unknown-use out tag))))) (add-unknown-use out tag)))))
@ -335,7 +335,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
(values cps types (compute-significant-bits cps types label)))) (values cps types (compute-significant-bits cps types label))))
(($ $kargs names vars (($ $kargs names vars
($ $continue k src ($ $continue k src
($ $primcall (and op (or 'add 'sub 'mul 'div)) (a b)))) ($ $primcall (and op (or 'add 'sub 'mul 'div)) #f (a b))))
(match (intmap-ref cps k) (match (intmap-ref cps k)
(($ $kargs (_) (result)) (($ $kargs (_) (result))
(call-with-values (lambda () (call-with-values (lambda ()
@ -360,7 +360,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
types types
sigbits)))))) sigbits))))))
(($ $kargs names vars (($ $kargs names vars
($ $continue k src ($ $primcall 'ash (a b)))) ($ $continue k src ($ $primcall 'ash #f (a b))))
(match (intmap-ref cps k) (match (intmap-ref cps k)
(($ $kargs (_) (result)) (($ $kargs (_) (result))
(call-with-values (lambda () (call-with-values (lambda ()
@ -391,7 +391,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
(letk kneg ($kargs ('bits) (bits) ,body)) (letk kneg ($kargs ('bits) (bits) ,body))
(build-term (build-term
($continue kneg src ($continue kneg src
($primcall 'sub (zero b)))))) ($primcall 'sub #f (zero b))))))
(setk label ($kargs names vars ,body)))) (setk label ($kargs names vars ,body))))
(else (else
(with-cps cps (with-cps cps
@ -401,7 +401,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
sigbits)))))) sigbits))))))
(($ $kargs names vars (($ $kargs names vars
($ $continue k src ($ $continue k src
($ $primcall (and op (or 'logand 'logior 'logsub 'logxor)) (a b)))) ($ $primcall (and op (or 'logand 'logior 'logsub 'logxor)) #f (a b))))
(match (intmap-ref cps k) (match (intmap-ref cps k)
(($ $kargs (_) (result)) (($ $kargs (_) (result))
(values (values
@ -431,7 +431,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
types sigbits)))) types sigbits))))
(($ $kargs names vars (($ $kargs names vars
($ $continue k src ($ $continue k src
($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b))))) ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) #f (a b)))))
(values (values
(cond (cond
((f64-operands? a b) ((f64-operands? a b)
@ -531,7 +531,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
(match (intmap-ref cps label) (match (intmap-ref cps label)
(($ $kargs _ _ ($ $continue k _ exp)) (($ $kargs _ _ ($ $continue k _ exp))
(match exp (match exp
(($ $primcall (? (lambda (op) (memq op unbox-ops))) (var)) (($ $primcall (? (lambda (op) (memq op unbox-ops))) #f (var))
(intset-add unbox-uses var)) (intset-add unbox-uses var))
(($ $values vars) (($ $values vars)
(match (intmap-ref cps k) (match (intmap-ref cps k)
@ -560,7 +560,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
;; Can the result of EXP definitely be unboxed as an f64? ;; Can the result of EXP definitely be unboxed as an f64?
(define (exp-result-f64? exp) (define (exp-result-f64? exp)
(match exp (match exp
((or ($ $primcall 'f64->scm (_)) ((or ($ $primcall 'f64->scm #f (_))
($ $const (and (? number?) (? inexact?) (? real?)))) ($ $const (and (? number?) (? inexact?) (? real?))))
#t) #t)
(_ #f))) (_ #f)))
@ -572,8 +572,8 @@ BITS indicating the significant bits needed for a variable. BITS may be
;; Can the result of EXP definitely be unboxed as a u64? ;; Can the result of EXP definitely be unboxed as a u64?
(define (exp-result-u64? exp) (define (exp-result-u64? exp)
(match exp (match exp
((or ($ $primcall 'u64->scm (_)) ((or ($ $primcall 'u64->scm #f (_))
($ $primcall 'u64->scm/unlikely (_)) ($ $primcall 'u64->scm/unlikely #f (_))
($ $const (and (? number?) (? exact-integer?) ($ $const (and (? number?) (? exact-integer?)
(? (lambda (n) (<= 0 n #xffffffffffffffff)))))) (? (lambda (n) (<= 0 n #xffffffffffffffff))))))
#t) #t)
@ -638,7 +638,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
(let$ body (have-arg unboxed)) (let$ body (have-arg unboxed))
(letk kunboxed ($kargs ('unboxed) (unboxed) ,body)) (letk kunboxed ($kargs ('unboxed) (unboxed) ,body))
(build-term (build-term
($continue kunboxed #f ($primcall (unbox-op def-var) (arg))))) ($continue kunboxed #f ($primcall (unbox-op def-var) #f (arg)))))
(have-arg cps arg))) (have-arg cps arg)))
(define (unbox-args cps args def-vars have-args) (define (unbox-args cps args def-vars have-args)
(match args (match args
@ -677,7 +677,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
(letv boxed) (letv boxed)
(letk kunbox ($kargs ('boxed) (boxed) (letk kunbox ($kargs ('boxed) (boxed)
($continue k src ($continue k src
($primcall (unbox-op def) (boxed))))) ($primcall (unbox-op def) #f (boxed)))))
(setk label ($kargs names vars (setk label ($kargs names vars
($continue kunbox src ,exp))))))))))))) ($continue kunbox src ,exp)))))))))))))
(compute-unbox-labels) (compute-unbox-labels)
@ -707,7 +707,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
(letk kboxed ($kargs (name) (var) ,term)) (letk kboxed ($kargs (name) (var) ,term))
(build-term (build-term
($continue kboxed #f ($continue kboxed #f
($primcall (box-op var) (unboxed))))) ($primcall (box-op var) #f (unboxed)))))
(done cps)))) (done cps))))
(define (box-vars cps names vars done) (define (box-vars cps names vars done)
(match vars (match vars

28
module/language/cps/specialize-primcalls.scm
View file

@ -49,9 +49,9 @@
(define (f64? var) (define (f64? var)
(let ((val (intmap-ref constants var (lambda (_) #f)))) (let ((val (intmap-ref constants var (lambda (_) #f))))
(and (number? val) (inexact? val) (real? val)))) (and (number? val) (inexact? val) (real? val))))
(define (specialize-primcall name args) (define (specialize-primcall name param args)
(define (rename name) (define (rename name)
(build-exp ($primcall name args))) (build-exp ($primcall name param args)))
(match (cons name args) (match (cons name args)
(('make-vector (? u8? n) init) (rename 'make-vector/immediate)) (('make-vector (? u8? n) init) (rename 'make-vector/immediate))
(('vector-ref v (? u8? n)) (rename 'vector-ref/immediate)) (('vector-ref v (? u8? n)) (rename 'vector-ref/immediate))
@ -59,16 +59,16 @@
(('allocate-struct v (? u8? n)) (rename 'allocate-struct/immediate)) (('allocate-struct v (? u8? n)) (rename 'allocate-struct/immediate))
(('struct-ref s (? u8? n)) (rename 'struct-ref/immediate)) (('struct-ref s (? u8? n)) (rename 'struct-ref/immediate))
(('struct-set! s (? u8? n) x) (rename 'struct-set!/immediate)) (('struct-set! s (? u8? n) x) (rename 'struct-set!/immediate))
(('add x (? u8? y)) (build-exp ($primcall 'add/immediate (x y)))) (('add x (? u8? y)) (build-exp ($primcall 'add/immediate #f (x y))))
(('add (? u8? x) y) (build-exp ($primcall 'add/immediate (y x)))) (('add (? u8? x) y) (build-exp ($primcall 'add/immediate #f (y x))))
(('sub x (? u8? y)) (build-exp ($primcall 'sub/immediate (x y)))) (('sub x (? u8? y)) (build-exp ($primcall 'sub/immediate #f (x y))))
(('uadd x (? u8? y)) (build-exp ($primcall 'uadd/immediate (x y)))) (('uadd x (? u8? y)) (build-exp ($primcall 'uadd/immediate #f (x y))))
(('uadd (? u8? x) y) (build-exp ($primcall 'uadd/immediate (y x)))) (('uadd (? u8? x) y) (build-exp ($primcall 'uadd/immediate #f (y x))))
(('usub x (? u8? y)) (build-exp ($primcall 'usub/immediate (x y)))) (('usub x (? u8? y)) (build-exp ($primcall 'usub/immediate #f (x y))))
(('umul x (? u8? y)) (build-exp ($primcall 'umul/immediate (x y)))) (('umul x (? u8? y)) (build-exp ($primcall 'umul/immediate #f (x y))))
(('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate (y x)))) (('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate #f (y x))))
(('ursh x (? u6? y)) (build-exp ($primcall 'ursh/immediate (x y)))) (('ursh x (? u6? y)) (build-exp ($primcall 'ursh/immediate #f (x y))))
(('ulsh x (? u6? y)) (build-exp ($primcall 'ulsh/immediate (x y)))) (('ulsh x (? u6? y)) (build-exp ($primcall 'ulsh/immediate #f (x y))))
(('scm->f64 (? f64?)) (rename 'load-f64)) (('scm->f64 (? f64?)) (rename 'load-f64))
(('scm->u64 (? u64?)) (rename 'load-u64)) (('scm->u64 (? u64?)) (rename 'load-u64))
(('scm->u64/truncate (? u64?)) (rename 'load-u64)) (('scm->u64/truncate (? u64?)) (rename 'load-u64))
@ -77,8 +77,8 @@
(intmap-map (intmap-map
(lambda (label cont) (lambda (label cont)
(match cont (match cont
(($ $kargs names vars ($ $continue k src ($ $primcall name args))) (($ $kargs names vars ($ $continue k src ($ $primcall name param args)))
(let ((exp* (specialize-primcall name args))) (let ((exp* (specialize-primcall name param args)))
(if exp* (if exp*
(build-cont (build-cont
($kargs names vars ($continue k src ,exp*))) ($kargs names vars ($continue k src ,exp*)))

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

@ -87,9 +87,9 @@ references."
(add-uses args uses)) (add-uses args uses))
(($ $call proc args) (($ $call proc args)
(add-use proc (add-uses args uses))) (add-use proc (add-uses args uses)))
(($ $branch kt ($ $primcall name args)) (($ $branch kt ($ $primcall name param args))
(add-uses args uses)) (add-uses args uses))
(($ $primcall name args) (($ $primcall name param args)
(add-uses args uses)) (add-uses args uses))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(add-use tag uses))))) (add-use tag uses)))))

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -39,8 +39,8 @@
"Elide &type-check effects from EFFECTS for the function starting at "Elide &type-check effects from EFFECTS for the function starting at
KFUN where we can prove that no assertion will be raised at run-time." KFUN where we can prove that no assertion will be raised at run-time."
(let ((types (infer-types conts kfun))) (let ((types (infer-types conts kfun)))
(define (visit-primcall effects fx label name args) (define (visit-primcall effects fx label name param args)
(if (primcall-types-check? types label name args) (if (primcall-types-check? types label name param args)
(intmap-replace! effects label (logand fx (lognot &type-check))) (intmap-replace! effects label (logand fx (lognot &type-check)))
effects)) effects))
(persistent-intmap (persistent-intmap
@ -52,11 +52,11 @@ KFUN where we can prove that no assertion will be raised at run-time."
(match (intmap-ref conts label) (match (intmap-ref conts label)
(($ $kargs _ _ exp) (($ $kargs _ _ exp)
(match exp (match exp
(($ $continue k src ($ $primcall name args)) (($ $continue k src ($ $primcall name param args))
(visit-primcall effects fx label name args)) (visit-primcall effects fx label name param args))
(($ $continue k src (($ $continue k src
($ $branch _ ($primcall name args))) ($ $branch _ ($primcall name param args)))
(visit-primcall effects fx label name args)) (visit-primcall effects fx label name param args))
(_ effects))) (_ effects)))
(_ effects))) (_ effects)))
(else effects)))) (else effects))))

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

@ -52,12 +52,12 @@
(hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from))) (hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from)))
(define-syntax-rule (define-unary-branch-folder (name arg min max) body ...) (define-syntax-rule (define-unary-branch-folder (name arg min max) body ...)
(define-branch-folder name (lambda (arg min max) body ...))) (define-branch-folder name (lambda (param arg min max) body ...)))
(define-syntax-rule (define-binary-branch-folder (name arg0 min0 max0 (define-syntax-rule (define-binary-branch-folder (name arg0 min0 max0
arg1 min1 max1) arg1 min1 max1)
body ...) body ...)
(define-branch-folder name (lambda (arg0 min0 max0 arg1 min1 max1) body ...))) (define-branch-folder name (lambda (param arg0 min0 max0 arg1 min1 max1) body ...)))
(define-syntax-rule (define-special-immediate-predicate-folder name imin imax) (define-syntax-rule (define-special-immediate-predicate-folder name imin imax)
(define-unary-branch-folder (name type min max) (define-unary-branch-folder (name type min max)
@ -198,7 +198,7 @@
arg type min max) arg type min max)
body ...) body ...)
(define-primcall-reducer name (define-primcall-reducer name
(lambda (cps k src arg type min max) (lambda (cps k src param arg type min max)
body ...))) body ...)))
(define-syntax-rule (define-binary-primcall-reducer (name cps k src (define-syntax-rule (define-binary-primcall-reducer (name cps k src
@ -206,7 +206,7 @@
arg1 type1 min1 max1) arg1 type1 min1 max1)
body ...) body ...)
(define-primcall-reducer name (define-primcall-reducer name
(lambda (cps k src arg0 type0 min0 max0 arg1 type1 min1 max1) (lambda (cps k src param arg0 type0 min0 max0 arg1 type1 min1 max1)
body ...))) body ...)))
(define-binary-primcall-reducer (mul cps k src (define-binary-primcall-reducer (mul cps k src
@ -217,7 +217,7 @@
(with-cps cps (with-cps cps
($ (with-cps-constants ((zero 0)) ($ (with-cps-constants ((zero 0))
(build-term (build-term
($continue k src ($primcall 'sub (zero arg)))))))) ($continue k src ($primcall 'sub #f (zero arg))))))))
(define (zero) (define (zero)
(with-cps cps (with-cps cps
(build-term ($continue k src ($const 0))))) (build-term ($continue k src ($const 0)))))
@ -226,13 +226,13 @@
(build-term ($continue k src ($values (arg)))))) (build-term ($continue k src ($values (arg))))))
(define (double arg) (define (double arg)
(with-cps cps (with-cps cps
(build-term ($continue k src ($primcall 'add (arg arg)))))) (build-term ($continue k src ($primcall 'add #f (arg arg))))))
(define (power-of-two constant arg) (define (power-of-two constant arg)
(let ((n (let lp ((bits 0) (constant constant)) (let ((n (let lp ((bits 0) (constant constant))
(if (= constant 1) bits (lp (1+ bits) (ash constant -1)))))) (if (= constant 1) bits (lp (1+ bits) (ash constant -1))))))
(with-cps cps (with-cps cps
($ (with-cps-constants ((bits n)) ($ (with-cps-constants ((bits n))
(build-term ($continue k src ($primcall 'ash (arg bits))))))))) (build-term ($continue k src ($primcall 'ash #f (arg bits)))))))))
(define (mul/constant constant constant-type arg arg-type) (define (mul/constant constant constant-type arg arg-type)
(cond (cond
((not (or (type<=? constant-type &exact-integer) ((not (or (type<=? constant-type &exact-integer)
@ -278,7 +278,7 @@
(with-cps cps (with-cps cps
($ (with-cps-constants ((one 1)) ($ (with-cps-constants ((one 1))
(build-term (build-term
($continue kmask src ($primcall 'ash (one arg0))))))))) ($continue kmask src ($primcall 'ash #f (one arg0)))))))))
(with-cps cps (with-cps cps
(letv mask test) (letv mask test)
(letk kt ($kargs () () (letk kt ($kargs () ()
@ -288,12 +288,12 @@
(let$ body (with-cps-constants ((zero 0)) (let$ body (with-cps-constants ((zero 0))
(build-term (build-term
($continue kt src ($continue kt src
($branch kf ($primcall 'eq? (test zero))))))) ($branch kf ($primcall 'eq? #f (test zero)))))))
(letk kand ($kargs (#f) (test) (letk kand ($kargs (#f) (test)
,body)) ,body))
(letk kmask ($kargs (#f) (mask) (letk kmask ($kargs (#f) (mask)
($continue kand src ($continue kand src
($primcall 'logand (mask arg1))))) ($primcall 'logand #f (mask arg1)))))
($ (compute-mask kmask src)))) ($ (compute-mask kmask src))))
;; Hairiness because we are converting from a primcall with unknown ;; Hairiness because we are converting from a primcall with unknown
;; arity to a branching primcall. ;; arity to a branching primcall.
@ -316,7 +316,7 @@
(with-cps cps (with-cps cps
(letv bool) (letv bool)
(letk kbool ($kargs (#f) (bool) (letk kbool ($kargs (#f) (bool)
($continue k src ($primcall 'values (bool))))) ($continue k src ($primcall 'values #f (bool)))))
($ (convert-to-logtest kbool)))))) ($ (convert-to-logtest kbool))))))
(($ $ktail) (($ $ktail)
(with-cps cps (with-cps cps
@ -350,7 +350,7 @@
(else (error "unhandled immediate" val)))) (else (error "unhandled immediate" val))))
(else (error "unhandled type" type val)))) (else (error "unhandled type" type val))))
(let ((types (infer-types cps start))) (let ((types (infer-types cps start)))
(define (fold-primcall cps label names vars k src name args def) (define (fold-primcall cps label names vars k src name param args def)
(call-with-values (lambda () (lookup-post-type types label def 0)) (call-with-values (lambda () (lookup-post-type types label def 0))
(lambda (type min max) (lambda (type min max)
(and (not (zero? type)) (and (not (zero? type))
@ -367,8 +367,8 @@
;; possible. ;; possible.
(setk label (setk label
($kargs names vars ($kargs names vars
($continue k* src ($primcall name args)))))))))) ($continue k* src ($primcall name param args))))))))))
(define (reduce-primcall cps label names vars k src name args) (define (reduce-primcall cps label names vars k src name param args)
(and=> (and=>
(hashq-ref *primcall-reducers* name) (hashq-ref *primcall-reducers* name)
(lambda (reducer) (lambda (reducer)
@ -377,7 +377,8 @@
(call-with-values (lambda () (lookup-pre-type types label arg0)) (call-with-values (lambda () (lookup-pre-type types label arg0))
(lambda (type0 min0 max0) (lambda (type0 min0 max0)
(call-with-values (lambda () (call-with-values (lambda ()
(reducer cps k src arg0 type0 min0 max0)) (reducer cps k src param
arg0 type0 min0 max0))
(lambda (cps term) (lambda (cps term)
(and term (and term
(with-cps cps (with-cps cps
@ -388,20 +389,21 @@
(call-with-values (lambda () (lookup-pre-type types label arg1)) (call-with-values (lambda () (lookup-pre-type types label arg1))
(lambda (type1 min1 max1) (lambda (type1 min1 max1)
(call-with-values (lambda () (call-with-values (lambda ()
(reducer cps k src arg0 type0 min0 max0 (reducer cps k src param
arg0 type0 min0 max0
arg1 type1 min1 max1)) arg1 type1 min1 max1))
(lambda (cps term) (lambda (cps term)
(and term (and term
(with-cps cps (with-cps cps
(setk label ($kargs names vars ,term))))))))))) (setk label ($kargs names vars ,term)))))))))))
(_ #f))))) (_ #f)))))
(define (fold-unary-branch cps label names vars kf kt src name arg) (define (fold-unary-branch cps label names vars kf kt src name param arg)
(and=> (and=>
(hashq-ref *branch-folders* name) (hashq-ref *branch-folders* name)
(lambda (folder) (lambda (folder)
(call-with-values (lambda () (lookup-pre-type types label arg)) (call-with-values (lambda () (lookup-pre-type types label arg))
(lambda (type min max) (lambda (type min max)
(call-with-values (lambda () (folder type min max)) (call-with-values (lambda () (folder param type min max))
(lambda (f? v) (lambda (f? v)
;; (when f? (pk 'folded-unary-branch label name arg v)) ;; (when f? (pk 'folded-unary-branch label name arg v))
(and f? (and f?
@ -410,7 +412,7 @@
($kargs names vars ($kargs names vars
($continue (if v kt kf) src ($continue (if v kt kf) src
($values ()))))))))))))) ($values ())))))))))))))
(define (fold-binary-branch cps label names vars kf kt src name arg0 arg1) (define (fold-binary-branch cps label names vars kf kt src name param arg0 arg1)
(and=> (and=>
(hashq-ref *branch-folders* name) (hashq-ref *branch-folders* name)
(lambda (folder) (lambda (folder)
@ -419,7 +421,7 @@
(call-with-values (lambda () (lookup-pre-type types label arg1)) (call-with-values (lambda () (lookup-pre-type types label arg1))
(lambda (type1 min1 max1) (lambda (type1 min1 max1)
(call-with-values (lambda () (call-with-values (lambda ()
(folder type0 min0 max0 type1 min1 max1)) (folder param type0 min0 max0 type1 min1 max1))
(lambda (f? v) (lambda (f? v)
;; (when f? (pk 'folded-binary-branch label name arg0 arg1 v)) ;; (when f? (pk 'folded-binary-branch label name arg0 arg1 v))
(and f? (and f?
@ -430,24 +432,24 @@
($values ()))))))))))))))) ($values ())))))))))))))))
(define (visit-expression cps label names vars k src exp) (define (visit-expression cps label names vars k src exp)
(match exp (match exp
(($ $primcall name args) (($ $primcall name param args)
;; We might be able to fold primcalls that define a value. ;; We might be able to fold primcalls that define a value.
(match (intmap-ref cps k) (match (intmap-ref cps k)
(($ $kargs (_) (def)) (($ $kargs (_) (def))
(or (fold-primcall cps label names vars k src name args def) (or (fold-primcall cps label names vars k src name param args def)
(reduce-primcall cps label names vars k src name args) (reduce-primcall cps label names vars k src name param args)
cps)) cps))
(_ (_
(or (reduce-primcall cps label names vars k src name args) (or (reduce-primcall cps label names vars k src name param args)
cps)))) cps))))
(($ $branch kt ($ $primcall name args)) (($ $branch kt ($ $primcall name param args))
;; We might be able to fold primcalls that branch. ;; We might be able to fold primcalls that branch.
(match args (match args
((x) ((x)
(or (fold-unary-branch cps label names vars k kt src name x) (or (fold-unary-branch cps label names vars k kt src name param x)
cps)) cps))
((x y) ((x y)
(or (fold-binary-branch cps label names vars k kt src name x y) (or (fold-binary-branch cps label names vars k kt src name param x y)
cps)))) cps))))
(_ cps))) (_ cps)))
(let lp ((label start) (cps cps)) (let lp ((label start) (cps cps))

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

@ -412,7 +412,7 @@ minimum, and maximum."
(hashq-set! (hashq-set!
*type-checkers* *type-checkers*
'name 'name
(lambda (typeset arg ...) (lambda (typeset param arg ...)
(syntax-parameterize (syntax-parameterize
((&type (syntax-rules () ((_ val) (var-type typeset val)))) ((&type (syntax-rules () ((_ val) (var-type typeset val))))
(&min (syntax-rules () ((_ val) (var-min typeset val)))) (&min (syntax-rules () ((_ val) (var-min typeset val))))
@ -430,7 +430,7 @@ minimum, and maximum."
(hashq-set! (hashq-set!
*type-inferrers* *type-inferrers*
'name 'name
(lambda (in succ var ...) (lambda (in succ param var ...)
(let ((out in)) (let ((out in))
(syntax-parameterize (syntax-parameterize
((define! ((define!
@ -1625,13 +1625,13 @@ maximum, where type is a bitset as a fixnum."
((var . vars) ((var . vars)
(adjoin-vars (adjoin-var types var entry) vars entry)))) (adjoin-vars (adjoin-var types var entry) vars entry))))
(define (infer-primcall types succ name args result) (define (infer-primcall types succ name param args result)
(cond (cond
((hashq-ref *type-inferrers* name) ((hashq-ref *type-inferrers* name)
=> (lambda (inferrer) => (lambda (inferrer)
;; FIXME: remove the apply? ;; FIXME: remove the apply?
;; (pk 'primcall name args result) ;; (pk 'primcall name args result)
(apply inferrer types succ (apply inferrer types succ param
(if result (if result
(append args (list result)) (append args (list result))
args)))) args))))
@ -1688,19 +1688,19 @@ maximum, where type is a bitset as a fixnum."
(values (append changed0 changed1) typev))) (values (append changed0 changed1) typev)))
;; Each of these branches must propagate to its successors. ;; Each of these branches must propagate to its successors.
(match exp (match exp
(($ $branch kt ($ $primcall name args)) (($ $branch kt ($ $primcall name param args))
;; The "normal" continuation is the #f branch. ;; The "normal" continuation is the #f branch.
(let ((kf-types (infer-primcall types 0 name args #f)) (let ((kf-types (infer-primcall types 0 name param args #f))
(kt-types (infer-primcall types 1 name args #f))) (kt-types (infer-primcall types 1 name param args #f)))
(propagate2 k kf-types kt kt-types))) (propagate2 k kf-types kt kt-types)))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
;; The "normal" continuation enters the prompt. ;; The "normal" continuation enters the prompt.
(propagate2 k types handler types)) (propagate2 k types handler types))
(($ $primcall name args) (($ $primcall name param args)
(propagate1 k (propagate1 k
(match (intmap-ref conts k) (match (intmap-ref conts k)
(($ $kargs _ defs) (($ $kargs _ defs)
(infer-primcall types 0 name args (infer-primcall types 0 name param args
(match defs ((var) var) (() #f)))) (match defs ((var) var) (() #f))))
(_ (_
;; (pk 'warning-no-restrictions name) ;; (pk 'warning-no-restrictions name)
@ -1787,9 +1787,9 @@ maximum, where type is a bitset as a fixnum."
(type-entry-min tentry) (type-entry-min tentry)
(type-entry-max tentry)))) (type-entry-max tentry))))
(define (primcall-types-check? types label name args) (define (primcall-types-check? types label name param args)
(match (hashq-ref *type-checkers* name) (match (hashq-ref *type-checkers* name)
(#f #f) (#f #f)
(checker (checker
(let ((entry (intmap-ref types label))) (let ((entry (intmap-ref types label)))
(apply checker (vector-ref entry 0) args))))) (apply checker (vector-ref entry 0) param args)))))

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -205,22 +205,22 @@ disjoint, an error will be signalled."
(intmap-fold (intmap-fold
(lambda (var exp out) (lambda (var exp out)
(match exp (match exp
(($ $primcall (or 'load-f64 'load-u64 'load-s64) (val)) (($ $primcall (or 'load-f64 'load-u64 'load-s64) #f (val))
(intmap-add! out var (intmap-ref out val))) (intmap-add! out var (intmap-ref out val)))
;; Punch through type conversions to allow uadd to specialize ;; Punch through type conversions to allow uadd to specialize
;; to uadd/immediate. ;; to uadd/immediate.
(($ $primcall 'scm->f64 (val)) (($ $primcall 'scm->f64 #f (val))
(let ((f64 (intmap-ref out val (lambda (_) #f)))) (let ((f64 (intmap-ref out val (lambda (_) #f))))
(if (and f64 (number? f64) (inexact? f64) (real? f64)) (if (and f64 (number? f64) (inexact? f64) (real? f64))
(intmap-add! out var f64) (intmap-add! out var f64)
out))) out)))
(($ $primcall (or 'scm->u64 'scm->u64/truncate) (val)) (($ $primcall (or 'scm->u64 'scm->u64/truncate) #f (val))
(let ((u64 (intmap-ref out val (lambda (_) #f)))) (let ((u64 (intmap-ref out val (lambda (_) #f))))
(if (and u64 (number? u64) (exact-integer? u64) (if (and u64 (number? u64) (exact-integer? u64)
(<= 0 u64 #xffffFFFFffffFFFF)) (<= 0 u64 #xffffFFFFffffFFFF))
(intmap-add! out var u64) (intmap-add! out var u64)
out))) out)))
(($ $primcall 'scm->s64 (val)) (($ $primcall 'scm->s64 #f (val))
(let ((s64 (intmap-ref out val (lambda (_) #f)))) (let ((s64 (intmap-ref out val (lambda (_) #f))))
(if (and s64 (number? s64) (exact-integer? s64) (if (and s64 (number? s64) (exact-integer? s64)
(<= (- #x8000000000000000) s64 #x7fffFFFFffffFFFF)) (<= (- #x8000000000000000) s64 #x7fffFFFFffffFFFF))

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

@ -160,10 +160,10 @@ definitions that are available at LABEL."
(check-use proc) (check-use proc)
(for-each check-use args) (for-each check-use args)
(visit-first-order kfun)) (visit-first-order kfun))
(($ $branch kt ($ $primcall name args)) (($ $branch kt ($ $primcall name param args))
(for-each check-use args) (for-each check-use args)
first-order) first-order)
(($ $primcall name args) (($ $primcall name param args)
(for-each check-use args) (for-each check-use args)
first-order) first-order)
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
@ -242,7 +242,7 @@ definitions that are available at LABEL."
(match (intmap-ref conts kt) (match (intmap-ref conts kt)
(($ $kargs () ()) #t) (($ $kargs () ()) #t)
(cont (error "bad kt" cont)))) (cont (error "bad kt" cont))))
(($ $primcall name args) (($ $primcall name param args)
(match cont (match cont
(($ $kargs names) (($ $kargs names)
(match (prim-arity name) (match (prim-arity name)

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

@ -91,13 +91,13 @@
(#f (#f
(with-cps cps (with-cps cps
(build-term ($continue k src (build-term ($continue k src
($primcall 'resolve (name bound?)))))) ($primcall 'resolve #f (name bound?))))))
(scope-id (scope-id
(with-cps cps (with-cps cps
($ (with-cps-constants ((scope scope-id)) ($ (with-cps-constants ((scope scope-id))
(build-term (build-term
($continue k src ($continue k src
($primcall 'cached-toplevel-box (scope name bound?)))))))))) ($primcall 'cached-toplevel-box #f (scope name bound?))))))))))
(with-cps cps (with-cps cps
(letv box) (letv box)
(let$ body (val-proc box)) (let$ body (val-proc box))
@ -116,7 +116,7 @@
(public? public?) (public? public?)
(bound? bound?)) (bound? bound?))
(build-term ($continue kbox src (build-term ($continue kbox src
($primcall 'cached-module-box ($primcall 'cached-module-box #f
(module name public? bound?)))))))) (module name public? bound?))))))))
(define (capture-toplevel-scope cps src scope-id k) (define (capture-toplevel-scope cps src scope-id k)
@ -125,10 +125,10 @@
(let$ body (with-cps-constants ((scope scope-id)) (let$ body (with-cps-constants ((scope scope-id))
(build-term (build-term
($continue k src ($continue k src
($primcall 'cache-current-module! (module scope)))))) ($primcall 'cache-current-module! #f (module scope))))))
(letk kmodule ($kargs ('module) (module) ,body)) (letk kmodule ($kargs ('module) (module) ,body))
(build-term ($continue kmodule src (build-term ($continue kmodule src
($primcall 'current-module ()))))) ($primcall 'current-module #f ())))))
(define (fold-formals proc seed arity gensyms inits) (define (fold-formals proc seed arity gensyms inits)
(match arity (match arity
@ -176,7 +176,7 @@
($ (with-cps-constants ((unbound (pointer->scm ($ (with-cps-constants ((unbound (pointer->scm
(make-pointer unbound-bits)))) (make-pointer unbound-bits))))
(build-term ($continue kf src (build-term ($continue kf src
($branch kt ($primcall 'eq? (var unbound))))))))) ($branch kt ($primcall 'eq? #f (var unbound)))))))))
(define (init-default-value cps name sym subst init body) (define (init-default-value cps name sym subst init body)
(match (hashq-ref subst sym) (match (hashq-ref subst sym)
@ -187,7 +187,7 @@
(with-cps cps (with-cps cps
(letv phi) (letv phi)
(letk kbox ($kargs (name) (phi) (letk kbox ($kargs (name) (phi)
($continue k src ($primcall 'box (phi))))) ($continue k src ($primcall 'box #f (phi)))))
($ (make-body kbox))) ($ (make-body kbox)))
(make-body cps k))) (make-body cps k)))
(with-cps cps (with-cps cps
@ -278,7 +278,7 @@
(let$ void (with-cps-constants ((unspecified *unspecified*)) (let$ void (with-cps-constants ((unspecified *unspecified*))
(build-term (build-term
($continue k src ($continue k src
($primcall 'values (unspecified)))))) ($primcall 'values #f (unspecified))))))
(letk kvoid ($kargs () () ,void)) (letk kvoid ($kargs () () ,void))
kvoid)))))) kvoid))))))
(1 (1
@ -296,7 +296,7 @@
(letv val) (letv val)
(let$ body (with-cps-constants ((nil '())) (let$ body (with-cps-constants ((nil '()))
(build-term (build-term
($continue kargs src ($primcall 'cons (val nil)))))) ($continue kargs src ($primcall 'cons #f (val nil))))))
(letk kval ($kargs ('val) (val) ,body)) (letk kval ($kargs ('val) (val) ,body))
kval)) kval))
(($ $arity (_) () #f () #f) (($ $arity (_) () #f () #f)
@ -316,7 +316,7 @@
(letv val) (letv val)
(letk kval ($kargs ('val) (val) (letk kval ($kargs ('val) (val)
($continue k src ($continue k src
($primcall 'values (val))))) ($primcall 'values #f (val)))))
kval)))))))) kval))))))))
;; cps exp k-name alist -> cps term ;; cps exp k-name alist -> cps term
@ -331,7 +331,7 @@
(letv unboxed) (letv unboxed)
(let$ body (k unboxed)) (let$ body (k unboxed))
(letk kunboxed ($kargs ('unboxed) (unboxed) ,body)) (letk kunboxed ($kargs ('unboxed) (unboxed) ,body))
(build-term ($continue kunboxed src ($primcall 'box-ref (box)))))) (build-term ($continue kunboxed src ($primcall 'box-ref #f (box))))))
((orig-var subst-var #f) (k cps subst-var)) ((orig-var subst-var #f) (k cps subst-var))
(var (k cps var)))) (var (k cps var))))
(else (else
@ -356,7 +356,7 @@
((orig-var subst-var #t) ((orig-var subst-var #t)
(with-cps cps (with-cps cps
(letk k ($kargs (name) (subst-var) ,body)) (letk k ($kargs (name) (subst-var) ,body))
(build-term ($continue k #f ($primcall 'box (orig-var)))))) (build-term ($continue k #f ($primcall 'box #f (orig-var))))))
(else (else
(with-cps cps body)))) (with-cps cps body))))
(define (box-bound-vars cps names syms body) (define (box-bound-vars cps names syms body)
@ -376,7 +376,7 @@
(with-cps cps (with-cps cps
(let$ k (adapt-arity k src 1)) (let$ k (adapt-arity k src 1))
(rewrite-term (hashq-ref subst sym) (rewrite-term (hashq-ref subst sym)
((orig-var box #t) ($continue k src ($primcall 'box-ref (box)))) ((orig-var box #t) ($continue k src ($primcall 'box-ref #f (box))))
((orig-var subst-var #f) ($continue k src ($values (subst-var)))) ((orig-var subst-var #f) ($continue k src ($values (subst-var))))
(var ($continue k src ($values (var))))))) (var ($continue k src ($values (var)))))))
@ -456,7 +456,7 @@
(lambda (cps box) (lambda (cps box)
(with-cps cps (with-cps cps
(let$ k (adapt-arity k src 1)) (let$ k (adapt-arity k src 1))
(build-term ($continue k src ($primcall 'box-ref (box)))))))) (build-term ($continue k src ($primcall 'box-ref #f (box))))))))
(($ <module-set> src mod name public? exp) (($ <module-set> src mod name public? exp)
(convert-arg cps exp (convert-arg cps exp
@ -467,7 +467,7 @@
(with-cps cps (with-cps cps
(let$ k (adapt-arity k src 0)) (let$ k (adapt-arity k src 0))
(build-term (build-term
($continue k src ($primcall 'box-set! (box val)))))))))) ($continue k src ($primcall 'box-set! #f (box val))))))))))
(($ <toplevel-ref> src name) (($ <toplevel-ref> src name)
(toplevel-box (toplevel-box
@ -475,7 +475,7 @@
(lambda (cps box) (lambda (cps box)
(with-cps cps (with-cps cps
(let$ k (adapt-arity k src 1)) (let$ k (adapt-arity k src 1))
(build-term ($continue k src ($primcall 'box-ref (box)))))))) (build-term ($continue k src ($primcall 'box-ref #f (box))))))))
(($ <toplevel-set> src name exp) (($ <toplevel-set> src name exp)
(convert-arg cps exp (convert-arg cps exp
@ -486,7 +486,7 @@
(with-cps cps (with-cps cps
(let$ k (adapt-arity k src 0)) (let$ k (adapt-arity k src 0))
(build-term (build-term
($continue k src ($primcall 'box-set! (box val)))))))))) ($continue k src ($primcall 'box-set! #f (box val))))))))))
(($ <toplevel-define> src name exp) (($ <toplevel-define> src name exp)
(convert-arg cps exp (convert-arg cps exp
@ -495,10 +495,10 @@
(let$ k (adapt-arity k src 0)) (let$ k (adapt-arity k src 0))
(letv box) (letv box)
(letk kset ($kargs ('box) (box) (letk kset ($kargs ('box) (box)
($continue k src ($primcall 'box-set! (box val))))) ($continue k src ($primcall 'box-set! #f (box val)))))
($ (with-cps-constants ((name name)) ($ (with-cps-constants ((name name))
(build-term (build-term
($continue kset src ($primcall 'define! (name)))))))))) ($continue kset src ($primcall 'define! #f (name))))))))))
(($ <call> src proc args) (($ <call> src proc args)
(convert-args cps (cons proc args) (convert-args cps (cons proc args)
@ -535,7 +535,7 @@
(with-cps cps (with-cps cps
(build-term (build-term
($continue k src ($continue k src
($primcall 'cons (head tail)))))))) ($primcall 'cons #f (head tail))))))))
(letk ktail ($kargs ('tail) (tail) ,body)) (letk ktail ($kargs ('tail) (tail) ,body))
($ (lp args ktail))))))))))) ($ (lp args ktail)))))))))))
((prim-instruction name) ((prim-instruction name)
@ -547,7 +547,7 @@
(letv f64) (letv f64)
(let$ k (adapt-arity k src out)) (let$ k (adapt-arity k src out))
(letk kbox ($kargs ('f64) (f64) (letk kbox ($kargs ('f64) (f64)
($continue k src ($primcall 'f64->scm (f64))))) ($continue k src ($primcall 'f64->scm #f (f64)))))
kbox)) kbox))
((char->integer ((char->integer
string-length vector-length string-length vector-length
@ -556,14 +556,14 @@
(letv u64) (letv u64)
(let$ k (adapt-arity k src out)) (let$ k (adapt-arity k src out))
(letk kbox ($kargs ('u64) (u64) (letk kbox ($kargs ('u64) (u64)
($continue k src ($primcall 'u64->scm (u64))))) ($continue k src ($primcall 'u64->scm #f (u64)))))
kbox)) kbox))
((bv-s8-ref bv-s16-ref bv-s32-ref bv-s64-ref) ((bv-s8-ref bv-s16-ref bv-s32-ref bv-s64-ref)
(with-cps cps (with-cps cps
(letv s64) (letv s64)
(let$ k (adapt-arity k src out)) (let$ k (adapt-arity k src out))
(letk kbox ($kargs ('s64) (s64) (letk kbox ($kargs ('s64) (s64)
($continue k src ($primcall 's64->scm (s64))))) ($continue k src ($primcall 's64->scm #f (s64)))))
kbox)) kbox))
(else (else
(adapt-arity cps k src out)))) (adapt-arity cps k src out))))
@ -573,7 +573,7 @@
(let$ body (have-arg unboxed)) (let$ body (have-arg unboxed))
(letk kunboxed ($kargs ('unboxed) (unboxed) ,body)) (letk kunboxed ($kargs ('unboxed) (unboxed) ,body))
(build-term (build-term
($continue kunboxed src ($primcall unbox-op (arg)))))) ($continue kunboxed src ($primcall unbox-op #f (arg))))))
(define (unbox-args cps args have-args) (define (unbox-args cps args have-args)
(case instruction (case instruction
((bv-f32-ref bv-f64-ref ((bv-f32-ref bv-f64-ref
@ -671,7 +671,7 @@
(with-cps cps (with-cps cps
(build-term (build-term
($continue k src ($continue k src
($primcall instruction args)))))))) ($primcall instruction #f args))))))))
(with-cps cps (with-cps cps
(letv prim) (letv prim)
(letk kprim ($kargs ('prim) (prim) (letk kprim ($kargs ('prim) (prim)
@ -685,7 +685,7 @@
(lambda (cps args) (lambda (cps args)
(with-cps cps (with-cps cps
(build-term (build-term
($continue k src ($primcall name args))))))))) ($continue k src ($primcall name #f args)))))))))
;; Prompts with inline handlers. ;; Prompts with inline handlers.
(($ <prompt> src escape-only? tag body (($ <prompt> src escape-only? tag body
@ -718,7 +718,7 @@
(with-cps cps (with-cps cps
(letk kbody ($kargs () () (letk kbody ($kargs () ()
($continue krest (tree-il-src body) ($continue krest (tree-il-src body)
($primcall 'call-thunk/no-inline ($primcall 'call-thunk/no-inline #f
(thunk))))) (thunk)))))
(build-term ($continue kbody (tree-il-src body) (build-term ($continue kbody (tree-il-src body)
($prompt #f tag khargs)))))))) ($prompt #f tag khargs))))))))
@ -729,11 +729,11 @@
(letk khbody ($kargs hnames bound-vars ,hbody)) (letk khbody ($kargs hnames bound-vars ,hbody))
(letk khargs ($kreceive hreq hrest khbody)) (letk khargs ($kreceive hreq hrest khbody))
(letk kprim ($kargs ('prim) (prim) (letk kprim ($kargs ('prim) (prim)
($continue k src ($primcall 'apply (prim vals))))) ($continue k src ($primcall 'apply #f (prim vals)))))
(letk kret ($kargs () () (letk kret ($kargs () ()
($continue kprim src ($prim 'values)))) ($continue kprim src ($prim 'values))))
(letk kpop ($kargs ('rest) (vals) (letk kpop ($kargs ('rest) (vals)
($continue kret src ($primcall 'unwind ())))) ($continue kret src ($primcall 'unwind #f ()))))
;; FIXME: Attach hsrc to $kreceive. ;; FIXME: Attach hsrc to $kreceive.
(letk krest ($kreceive '() 'rest kpop)) (letk krest ($kreceive '() 'rest kpop))
($ (convert-body khargs krest))))))) ($ (convert-body khargs krest)))))))
@ -743,7 +743,7 @@
(lambda (cps args*) (lambda (cps args*)
(with-cps cps (with-cps cps
(build-term (build-term
($continue k src ($primcall 'abort-to-prompt args*))))))) ($continue k src ($primcall 'abort-to-prompt #f args*)))))))
(($ <abort> src tag args tail) (($ <abort> src tag args tail)
(convert-args cps (convert-args cps
@ -752,7 +752,7 @@
(list tail)) (list tail))
(lambda (cps args*) (lambda (cps args*)
(with-cps cps (with-cps cps
(build-term ($continue k src ($primcall 'apply args*))))))) (build-term ($continue k src ($primcall 'apply #f args*)))))))
(($ <conditional> src test consequent alternate) (($ <conditional> src test consequent alternate)
(define (convert-test cps test kt kf) (define (convert-test cps test kt kf)
@ -764,13 +764,13 @@
(with-cps cps (with-cps cps
(letk kt* ($kargs () () (letk kt* ($kargs () ()
($continue kf src ($continue kf src
($branch kt ($primcall name args))))) ($branch kt ($primcall name #f args)))))
(build-term (build-term
($continue kf src ($continue kf src
($branch kt* ($primcall 'heap-object? args))))) ($branch kt* ($primcall 'heap-object? #f args)))))
(with-cps cps (with-cps cps
(build-term ($continue kf src (build-term ($continue kf src
($branch kt ($primcall name args))))))))) ($branch kt ($primcall name #f args)))))))))
(($ <conditional> src test consequent alternate) (($ <conditional> src test consequent alternate)
(with-cps cps (with-cps cps
(let$ t (convert-test consequent kt kf)) (let$ t (convert-test consequent kt kf))
@ -785,7 +785,7 @@
(lambda (cps test) (lambda (cps test)
(with-cps cps (with-cps cps
(build-term ($continue kt src (build-term ($continue kt src
($branch kf ($primcall 'false? (test))))))))))) ($branch kf ($primcall 'false? #f (test)))))))))))
(with-cps cps (with-cps cps
(let$ t (convert consequent k subst)) (let$ t (convert consequent k subst))
(let$ f (convert alternate k subst)) (let$ f (convert alternate k subst))
@ -801,7 +801,7 @@
(with-cps cps (with-cps cps
(let$ k (adapt-arity k src 0)) (let$ k (adapt-arity k src 0))
(build-term (build-term
($continue k src ($primcall 'box-set! (box exp)))))))))) ($continue k src ($primcall 'box-set! #f (box exp))))))))))
(($ <seq> src head tail) (($ <seq> src head tail)
(with-cps cps (with-cps cps