[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/16: $primcall has a "param" member
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/16: $primcall has a "param" member |
|
Date: |
Sun, 5 Nov 2017 09:00:40 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit c54c151eb60971c7553146acfb0caa036016f02d
Author: Andy Wingo <address@hidden>
Date: Wed Nov 1 11:57:16 2017 +0100
$primcall has a "param" member
* 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.
---
module/language/cps.scm | 18 +-
module/language/cps/closure-conversion.scm | 48 ++---
module/language/cps/compile-bytecode.scm | 234 ++++++++++++-------------
module/language/cps/constructors.scm | 18 +-
module/language/cps/contification.scm | 6 +-
module/language/cps/cse.scm | 84 ++++-----
module/language/cps/dce.scm | 6 +-
module/language/cps/effects-analysis.scm | 2 +-
module/language/cps/elide-values.scm | 6 +-
module/language/cps/handle-interrupts.scm | 4 +-
module/language/cps/licm.scm | 6 +-
module/language/cps/peel-loops.scm | 8 +-
module/language/cps/prune-bailouts.scm | 2 +-
module/language/cps/prune-top-level-scopes.scm | 6 +-
module/language/cps/reify-primitives.scm | 35 ++--
module/language/cps/renumber.scm | 6 +-
module/language/cps/rotate-loops.scm | 8 +-
module/language/cps/self-references.scm | 8 +-
module/language/cps/simplify.scm | 14 +-
module/language/cps/slot-allocation.scm | 36 ++--
module/language/cps/specialize-numbers.scm | 80 ++++-----
module/language/cps/specialize-primcalls.scm | 28 +--
module/language/cps/split-rec.scm | 4 +-
module/language/cps/type-checks.scm | 14 +-
module/language/cps/type-fold.scm | 56 +++---
module/language/cps/types.scm | 22 +--
module/language/cps/utils.scm | 10 +-
module/language/cps/verify.scm | 6 +-
module/language/tree-il/compile-cps.scm | 72 ++++----
29 files changed, 427 insertions(+), 420 deletions(-)
diff --git a/module/language/cps.scm b/module/language/cps.scm
index 5d48269..eae5fdc 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@@ -189,7 +189,7 @@
(define-cps-type $branch kt exp)
(define-cps-type $call proc args)
(define-cps-type $callk k proc args) ; First-order.
-(define-cps-type $primcall name args)
+(define-cps-type $primcall name param args)
(define-cps-type $values args)
(define-cps-type $prompt escape? tag handler)
@@ -241,9 +241,9 @@
((_ ($callk k proc (unquote args))) (make-$callk k proc args))
((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
((_ ($callk k proc args)) (make-$callk k proc args))
- ((_ ($primcall name (unquote args))) (make-$primcall name args))
- ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
- ((_ ($primcall name args)) (make-$primcall name args))
+ ((_ ($primcall name param (unquote args))) (make-$primcall name param
args))
+ ((_ ($primcall name param (arg ...))) (make-$primcall name param (list arg
...)))
+ ((_ ($primcall name param args)) (make-$primcall name param args))
((_ ($values (unquote args))) (make-$values args))
((_ ($values (arg ...))) (make-$values (list arg ...)))
((_ ($values args)) (make-$values args))
@@ -299,8 +299,8 @@
(build-exp ($call proc arg)))
(('callk k proc arg ...)
(build-exp ($callk k proc arg)))
- (('primcall name arg ...)
- (build-exp ($primcall name arg)))
+ (('primcall name param arg ...)
+ (build-exp ($primcall name param arg)))
(('branch k exp)
(build-exp ($branch k ,(parse-cps exp))))
(('values arg ...)
@@ -346,8 +346,8 @@
`(call ,proc ,@args))
(($ $callk k proc args)
`(callk ,k ,proc ,@args))
- (($ $primcall name args)
- `(primcall ,name ,@args))
+ (($ $primcall name param args)
+ `(primcall ,name ,param ,@args))
(($ $branch k exp)
`(branch ,k ,(unparse-cps exp)))
(($ $values args)
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index fb07061..bb15908 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -89,9 +89,9 @@ conts."
(add-uses args uses))
(($ $call proc args)
(add-uses args uses))
- (($ $branch kt ($ $primcall name args))
+ (($ $branch kt ($ $primcall name param args))
(add-uses args uses))
- (($ $primcall name args)
+ (($ $primcall name param args)
(add-uses args uses))
(($ $prompt escape? tag handler)
(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))
(#f ($call proc ,args))
((closure . label) ($callk label closure ,args)))))
- (($ $primcall name args)
- ($primcall name ,(map subst args)))
- (($ $branch k ($ $primcall name args))
- ($branch k ($primcall name ,(map subst args))))
+ (($ $primcall name param args)
+ ($primcall name param ,(map subst args)))
+ (($ $branch k ($ $primcall name param args))
+ ($branch k ($primcall name param ,(map subst args))))
(($ $values args)
($values ,(map subst args)))
(($ $prompt escape? tag handler)
@@ -369,9 +369,9 @@ references."
(add-use proc (add-uses args uses)))
(($ $callk label proc args)
(add-use proc (add-uses args uses)))
- (($ $branch kt ($ $primcall name args))
+ (($ $branch kt ($ $primcall name param args))
(add-uses args uses))
- (($ $primcall name args)
+ (($ $primcall name param args)
(add-uses args uses))
(($ $prompt escape? tag handler)
(add-use tag uses)))))
@@ -482,7 +482,7 @@ Otherwise @var{var} is bound, so @var{k} is called with
@var{var}."
(letv var*)
(let$ body (k var*))
(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)))
(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 kunbox ($kargs ('idx) (u64)
($continue k* #f
- ($primcall 'vector-ref (self u64)))))
+ ($primcall 'vector-ref #f (self u64)))))
($ (with-cps-constants ((idx idx))
(build-term
($continue kunbox #f
- ($primcall 'scm->u64 (idx))))))))
+ ($primcall 'scm->u64 #f (idx))))))))
(else
(with-cps cps
(letv var*)
@@ -506,7 +506,7 @@ Otherwise @var{var} is bound, so @var{k} is called with
@var{var}."
($ (with-cps-constants ((idx idx))
(build-term
($continue k* #f
- ($primcall 'free-ref (self idx)))))))))))))
+ ($primcall 'free-ref #f (self idx)))))))))))))
(else
(with-cps cps
($ (k var))))))
@@ -540,7 +540,7 @@ term."
(with-cps cps
($ (with-cps-constants ((false #f))
(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
;; is a vector.
(#(#t nfree)
@@ -552,9 +552,9 @@ term."
(letv u64)
(letk kunbox ($kargs ('nfree) (u64)
($continue k src
- ($primcall 'make-vector (u64 false)))))
+ ($primcall 'make-vector #f (u64 false)))))
(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)
"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
(build-term
($continue k src
- ($primcall 'set-cdr! (var v1))))))))
+ ($primcall 'set-cdr! #f (var v1))))))))
(letk kcdr ($kargs () () ,body))
(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!,
;; 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
($kargs ('idx) (u64)
($continue k src
- ($primcall 'vector-set! (var u64 v)))))
+ ($primcall 'vector-set! #f (var u64
v)))))
($ (with-cps-constants ((idx idx))
(build-term
($continue kunbox src
- ($primcall 'scm->u64 (idx))))))))
+ ($primcall 'scm->u64 #f (idx))))))))
(else
(with-cps cps
($ (with-cps-constants ((idx idx))
(build-term
($continue k src
- ($primcall 'free-set!
+ ($primcall 'free-set! #f
(var idx v)))))))))))))))))))
(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))
(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
(lambda (cps args)
(with-cps cps
(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
(lambda (cps args)
(with-cps cps
(build-term
($continue k src
- ($branch kt ($primcall name args))))))))
+ ($branch kt ($primcall name param args))))))))
(($ $continue k src ($ $values args))
(convert-args cps args
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index a4150ac..8d95884 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -143,138 +143,138 @@
(emit-current-module asm (from-sp dst)))
(($ $primcall 'current-thread)
(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)
(constant scope) (constant name)
(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)
(constant mod) (constant name)
(constant public?) (constant bound?)))
- (($ $primcall 'define! (sym))
+ (($ $primcall 'define! #f (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?)
(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))
(constant idx)))
- (($ $primcall 'vector-ref (vector index))
+ (($ $primcall 'vector-ref #f (vector index))
(emit-vector-ref asm (from-sp dst) (from-sp (slot vector))
(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))
(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)
(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))
(constant index)))
- (($ $primcall 'allocate-struct (vtable nfields))
+ (($ $primcall 'allocate-struct #f (vtable nfields))
(emit-allocate-struct asm (from-sp dst) (from-sp (slot vtable))
(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)
(from-sp (slot vtable))
(constant nfields)))
- (($ $primcall 'struct-ref (struct n))
+ (($ $primcall 'struct-ref #f (struct n))
(emit-struct-ref asm (from-sp dst) (from-sp (slot struct))
(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))
(constant n)))
- (($ $primcall 'char->integer (src))
+ (($ $primcall 'char->integer #f (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))))
- (($ $primcall 'add/immediate (x y))
+ (($ $primcall 'add/immediate #f (x 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)))
- (($ $primcall 'uadd/immediate (x y))
+ (($ $primcall 'uadd/immediate #f (x y))
(emit-uadd/immediate asm (from-sp dst) (from-sp (slot x))
(constant y)))
- (($ $primcall 'usub/immediate (x y))
+ (($ $primcall 'usub/immediate #f (x y))
(emit-usub/immediate asm (from-sp dst) (from-sp (slot x))
(constant y)))
- (($ $primcall 'umul/immediate (x y))
+ (($ $primcall 'umul/immediate #f (x y))
(emit-umul/immediate asm (from-sp dst) (from-sp (slot x))
(constant y)))
- (($ $primcall 'ursh/immediate (x y))
+ (($ $primcall 'ursh/immediate #f (x y))
(emit-ursh/immediate asm (from-sp dst) (from-sp (slot x))
(constant y)))
- (($ $primcall 'ulsh/immediate (x y))
+ (($ $primcall 'ulsh/immediate #f (x y))
(emit-ulsh/immediate asm (from-sp dst) (from-sp (slot x))
(constant y)))
- (($ $primcall 'builtin-ref (name))
+ (($ $primcall 'builtin-ref #f (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))))
- (($ $primcall 'load-f64 (src))
+ (($ $primcall 'load-f64 #f (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))))
- (($ $primcall 'scm->u64 (src))
+ (($ $primcall 'scm->u64 #f (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))))
- (($ $primcall 'load-u64 (src))
+ (($ $primcall 'load-u64 #f (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))))
- (($ $primcall 'scm->s64 (src))
+ (($ $primcall 'scm->s64 #f (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)))
- (($ $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))))
- (($ $primcall 'bv-length (bv))
+ (($ $primcall 'bv-length #f (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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))))
- (($ $primcall 'atomic-box-ref (box))
+ (($ $primcall 'atomic-box-ref #f (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))
(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!
asm (from-sp dst) (from-sp (slot box))
(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))))
- (($ $primcall name args)
+ (($ $primcall name #f args)
;; FIXME: Inline all the cases.
(let ((inst (prim-instruction name)))
(emit-text asm `((,inst ,(from-sp dst)
@@ -305,79 +305,79 @@
(lookup-parallel-moves handler allocation))
(emit-reset-frame asm frame-size)
(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)))
- (($ $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))
(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))))
- (($ $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))
(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))
(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))
(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))
(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))
(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))))
- (($ $primcall 'set-cdr! (pair value))
+ (($ $primcall 'set-cdr! #f (pair 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))))
- (($ $primcall 'pop-fluid ())
+ (($ $primcall 'pop-fluid #f ())
(emit-pop-fluid asm))
- (($ $primcall 'push-dynamic-state (state))
+ (($ $primcall 'push-dynamic-state #f (state))
(emit-push-dynamic-state asm (from-sp (slot state))))
- (($ $primcall 'pop-dynamic-state ())
+ (($ $primcall 'pop-dynamic-state #f ())
(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))))
- (($ $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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))
(from-sp (slot val))))
- (($ $primcall 'unwind ())
+ (($ $primcall 'unwind #f ())
(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))))
- (($ $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))))
- (($ $primcall 'handle-interrupts ())
+ (($ $primcall 'handle-interrupts #f ())
(emit-handle-interrupts asm))))
(define (compile-values label exp syms)
@@ -417,48 +417,48 @@
(define (binary-test op a b)
(binary op emit-je emit-jne a b))
(match exp
- (($ $primcall 'heap-object? (a)) (unary emit-heap-object? a))
- (($ $primcall 'null? (a)) (unary emit-null? a))
- (($ $primcall 'nil? (a)) (unary emit-nil? a))
- (($ $primcall 'false? (a)) (unary emit-false? a))
- (($ $primcall 'pair? (a)) (unary emit-pair? a))
- (($ $primcall 'struct? (a)) (unary emit-struct? a))
- (($ $primcall 'char? (a)) (unary emit-char? a))
- (($ $primcall 'symbol? (a)) (unary emit-symbol? a))
- (($ $primcall 'variable? (a)) (unary emit-variable? a))
- (($ $primcall 'vector? (a)) (unary emit-vector? a))
- (($ $primcall 'string? (a)) (unary emit-string? a))
- (($ $primcall 'bytevector? (a)) (unary emit-bytevector? a))
- (($ $primcall 'bitvector? (a)) (unary emit-bitvector? a))
- (($ $primcall 'keyword? (a)) (unary emit-keyword? a))
- (($ $primcall 'heap-number? (a)) (unary emit-heap-number? a))
- (($ $primcall 'fixnum? (a)) (unary emit-fixnum? a))
+ (($ $primcall 'heap-object? #f (a)) (unary emit-heap-object? a))
+ (($ $primcall 'null? #f (a)) (unary emit-null? a))
+ (($ $primcall 'nil? #f (a)) (unary emit-nil? a))
+ (($ $primcall 'false? #f (a)) (unary emit-false? a))
+ (($ $primcall 'pair? #f (a)) (unary emit-pair? a))
+ (($ $primcall 'struct? #f (a)) (unary emit-struct? a))
+ (($ $primcall 'char? #f (a)) (unary emit-char? a))
+ (($ $primcall 'symbol? #f (a)) (unary emit-symbol? a))
+ (($ $primcall 'variable? #f (a)) (unary emit-variable? a))
+ (($ $primcall 'vector? #f (a)) (unary emit-vector? a))
+ (($ $primcall 'string? #f (a)) (unary emit-string? a))
+ (($ $primcall 'bytevector? #f (a)) (unary emit-bytevector? a))
+ (($ $primcall 'bitvector? #f (a)) (unary emit-bitvector? a))
+ (($ $primcall 'keyword? #f (a)) (unary emit-keyword? a))
+ (($ $primcall 'heap-number? #f (a)) (unary emit-heap-number? a))
+ (($ $primcall 'fixnum? #f (a)) (unary emit-fixnum? a))
;; Add more TC7 tests here. Keep in sync with
;; *branching-primcall-arities* in (language cps primitives) and
;; the set of macro-instructions in assembly.scm.
- (($ $primcall 'eq? (a b)) (binary-test emit-eq? a b))
- (($ $primcall 'heap-numbers-equal? (a b))
+ (($ $primcall 'eq? #f (a b)) (binary-test emit-eq? a b))
+ (($ $primcall 'heap-numbers-equal? #f (a b))
(binary-test emit-heap-numbers-equal? a b))
- (($ $primcall '< (a b)) (binary emit-<? emit-jl emit-jnl a b))
- (($ $primcall '<= (a b)) (binary emit-<? emit-jge emit-jnge b a))
- (($ $primcall '= (a b)) (binary-test emit-=? a b))
- (($ $primcall '>= (a b)) (binary emit-<? emit-jge emit-jnge a b))
- (($ $primcall '> (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-<= (a b)) (binary emit-u64<? emit-jnl emit-jl b a))
- (($ $primcall 'u64-= (a b)) (binary-test emit-u64=? a b))
- (($ $primcall 'u64->= (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 's64-< (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-= (a b)) (binary-test emit-s64=? a b))
- (($ $primcall 's64->= (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 'f64-< (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-= (a b)) (binary-test emit-f64=? a b))
- (($ $primcall 'f64->= (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 '< #f (a b)) (binary emit-<? emit-jl emit-jnl a b))
+ (($ $primcall '<= #f (a b)) (binary emit-<? emit-jge emit-jnge b a))
+ (($ $primcall '= #f (a b)) (binary-test emit-=? a b))
+ (($ $primcall '>= #f (a b)) (binary emit-<? emit-jge emit-jnge a b))
+ (($ $primcall '> #f (a b)) (binary emit-<? emit-jl emit-jnl b a))
+ (($ $primcall 'u64-< #f (a b)) (binary emit-u64<? emit-jl emit-jnl a
b))
+ (($ $primcall 'u64-<= #f (a b)) (binary emit-u64<? emit-jnl emit-jl b
a))
+ (($ $primcall 'u64-= #f (a b)) (binary-test emit-u64=? a b))
+ (($ $primcall 'u64->= #f (a b)) (binary emit-u64<? emit-jnl emit-jl a
b))
+ (($ $primcall 'u64-> #f (a b)) (binary emit-u64<? emit-jl emit-jnl b
a))
+ (($ $primcall 's64-< #f (a b)) (binary emit-s64<? emit-jl emit-jnl a
b))
+ (($ $primcall 's64-<= #f (a b)) (binary emit-s64<? emit-jnl emit-jl b
a))
+ (($ $primcall 's64-= #f (a b)) (binary-test emit-s64=? a b))
+ (($ $primcall 's64->= #f (a b)) (binary emit-s64<? emit-jnl emit-jl a
b))
+ (($ $primcall 's64-> #f (a b)) (binary emit-s64<? emit-jl emit-jnl b
a))
+ (($ $primcall 'f64-< #f (a b)) (binary emit-f64<? emit-jl emit-jnl a
b))
+ (($ $primcall 'f64-<= #f (a b)) (binary emit-f64<? emit-jge emit-jnge
b a))
+ (($ $primcall 'f64-= #f (a b)) (binary-test emit-f64=? a b))
+ (($ $primcall 'f64->= #f (a b)) (binary emit-f64<? emit-jge emit-jnge
a b))
+ (($ $primcall 'f64-> #f (a b)) (binary emit-f64<? emit-jl emit-jnl b
a))))
(define (compile-trunc label k exp nreq rest-var)
(define (do-call proc args emit-call)
diff --git a/module/language/cps/constructors.scm
b/module/language/cps/constructors.scm
index 170f0f1..ce6ec84 100644
--- a/module/language/cps/constructors.scm
+++ b/module/language/cps/constructors.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@@ -42,13 +42,13 @@
(letv tail)
(letk ktail ($kargs ('tail) (tail)
($continue k src
- ($primcall 'cons (arg tail)))))
+ ($primcall 'cons #f (arg tail)))))
($ (build-list args ktail))))))
(with-cps out
(letv val)
(letk kvalues ($kargs ('val) (val)
($continue k src
- ($primcall 'values (val)))))
+ ($primcall 'values #f (val)))))
($ (build-list args kvalues))))
(define (inline-vector out k src args)
@@ -56,7 +56,7 @@
(match args
(()
(with-cps out
- (build-term ($continue k src ($primcall 'values (vec))))))
+ (build-term ($continue k src ($primcall 'values #f (vec))))))
((arg . args)
(with-cps out
(let$ next (initialize vec args (1+ n)))
@@ -64,10 +64,10 @@
(letv u64)
(letk kunbox ($kargs ('idx) (u64)
($continue knext src
- ($primcall 'vector-set! (vec u64 arg)))))
+ ($primcall 'vector-set! #f (vec u64 arg)))))
($ (with-cps-constants ((idx n))
(build-term ($continue kunbox src
- ($primcall 'scm->u64 (idx))))))))))
+ ($primcall 'scm->u64 #f (idx))))))))))
(with-cps out
(letv vec)
(let$ body (initialize vec args 0))
@@ -77,9 +77,9 @@
(letv u64)
(letk kunbox ($kargs ('len) (u64)
($continue kalloc src
- ($primcall 'make-vector (u64 init)))))
+ ($primcall 'make-vector #f (u64 init)))))
(build-term ($continue kunbox src
- ($primcall 'scm->u64 (len))))))))
+ ($primcall 'scm->u64 #f (len))))))))
(define (find-constructor-inliner name)
(match name
@@ -93,7 +93,7 @@
(intmap-fold
(lambda (label cont out)
(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)))
(if inline
(call-with-values (lambda () (inline out k src args))
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index 3fbfb36..a913a71 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -186,9 +186,9 @@ $call, and are always called with a compatible arity."
(restrict-arity functions proc (length args))))
(($ $callk k proc args)
(exclude-vars functions (cons proc args)))
- (($ $branch kt ($ $primcall name args))
+ (($ $branch kt ($ $primcall name param args))
(exclude-vars functions args))
- (($ $primcall name args)
+ (($ $primcall name param args)
(exclude-vars functions args))
(($ $prompt escape? tag handler)
(exclude-var functions tag))))
@@ -394,7 +394,7 @@ function set."
;; continue to $kreceive.
(($ $primcall) exp)
(($ $values vals)
- (build-exp ($primcall 'values vals)))))
+ (build-exp ($primcall 'values #f vals)))))
(($ $ktail) exp)))))))
(define (visit-exp k src exp)
(match exp
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 2623e4a..f50a164 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -249,10 +249,10 @@ false. It could be that both true and false proofs are
available."
(($ $closure label nfree) #f)
(($ $call proc args) #f)
(($ $callk k proc args) #f)
- (($ $primcall name args)
- (cons* 'primcall name (subst-vars var-substs args)))
- (($ $branch _ ($ $primcall name args))
- (cons* 'primcall name (subst-vars var-substs args)))
+ (($ $primcall name param args)
+ (cons* 'primcall name param (subst-vars var-substs args)))
+ (($ $branch _ ($ $primcall name param args))
+ (cons* 'primcall name param (subst-vars var-substs args)))
(($ $values args) #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
(acons label (list var) equiv))))
(match exp-key
- (('primcall 'box val)
+ (('primcall 'box #f val)
(match defs
((box)
- (add-def! `(primcall box-ref ,(subst box)) val))))
- (('primcall 'box-set! box val)
- (add-def! `(primcall box-ref ,box) val))
- (('primcall 'cons car cdr)
+ (add-def! `(primcall box-ref #f ,(subst box)) val))))
+ (('primcall 'box-set! #f box val)
+ (add-def! `(primcall box-ref #f ,box) val))
+ (('primcall 'cons #f car cdr)
(match defs
((pair)
- (add-def! `(primcall car ,(subst pair)) car)
- (add-def! `(primcall cdr ,(subst pair)) cdr))))
- (('primcall 'set-car! pair car)
- (add-def! `(primcall car ,pair) car))
- (('primcall 'set-cdr! pair cdr)
- (add-def! `(primcall cdr ,pair) cdr))
- (('primcall (or 'make-vector 'make-vector/immediate) len fill)
+ (add-def! `(primcall car #f ,(subst pair)) car)
+ (add-def! `(primcall cdr #f ,(subst pair)) cdr))))
+ (('primcall 'set-car! #f pair car)
+ (add-def! `(primcall car #f ,pair) car))
+ (('primcall 'set-cdr! #f pair cdr)
+ (add-def! `(primcall cdr #f ,pair) cdr))
+ (('primcall (or 'make-vector 'make-vector/immediate) #f len fill)
(match defs
((vec)
- (add-def! `(primcall vector-length ,(subst vec)) len))))
- (('primcall 'vector-set! vec idx val)
- (add-def! `(primcall vector-ref ,vec ,idx) val))
- (('primcall 'vector-set!/immediate vec idx val)
- (add-def! `(primcall vector-ref/immediate ,vec ,idx) val))
- (('primcall (or 'allocate-struct 'allocate-struct/immediate)
+ (add-def! `(primcall vector-length #f ,(subst vec)) len))))
+ (('primcall 'vector-set! #f vec idx val)
+ (add-def! `(primcall vector-ref #f ,vec ,idx) val))
+ (('primcall 'vector-set!/immediate #f vec idx val)
+ (add-def! `(primcall vector-ref/immediate #f ,vec ,idx) val))
+ (('primcall (or 'allocate-struct 'allocate-struct/immediate) #f
vtable size)
(match defs
((struct)
- (add-def! `(primcall struct-vtable ,(subst struct))
+ (add-def! `(primcall struct-vtable #f ,(subst struct))
vtable))))
- (('primcall 'struct-set! struct n val)
- (add-def! `(primcall struct-ref ,struct ,n) val))
- (('primcall 'struct-set!/immediate struct n val)
- (add-def! `(primcall struct-ref/immediate ,struct ,n) val))
- (('primcall 'scm->f64 scm)
+ (('primcall 'struct-set! #f struct n val)
+ (add-def! `(primcall struct-ref #f ,struct ,n) val))
+ (('primcall 'struct-set!/immediate #f struct n val)
+ (add-def! `(primcall struct-ref/immediate #f ,struct ,n) val))
+ (('primcall 'scm->f64 #f scm)
(match defs
((f64)
- (add-def! `(primcall f64->scm ,f64) scm))))
- (('primcall 'f64->scm f64)
+ (add-def! `(primcall f64->scm #f ,f64) scm))))
+ (('primcall 'f64->scm #f f64)
(match defs
((scm)
- (add-def! `(primcall scm->f64 ,scm) f64))))
- (('primcall 'scm->u64 scm)
+ (add-def! `(primcall scm->f64 #f ,scm) f64))))
+ (('primcall 'scm->u64 #f scm)
(match defs
((u64)
- (add-def! `(primcall u64->scm ,u64) scm))))
- (('primcall (or 'u64->scm 'u64->scm/unlikely) u64)
+ (add-def! `(primcall u64->scm #f ,u64) scm))))
+ (('primcall (or 'u64->scm 'u64->scm/unlikely) #f u64)
(match defs
((scm)
- (add-def! `(primcall scm->u64 ,scm) u64)
- (add-def! `(primcall scm->u64/truncate ,scm) u64))))
- (('primcall 'scm->s64 scm)
+ (add-def! `(primcall scm->u64 #f ,scm) u64)
+ (add-def! `(primcall scm->u64/truncate #f ,scm) u64))))
+ (('primcall 'scm->s64 #f scm)
(match defs
((s64)
- (add-def! `(primcall s64->scm ,s64) scm))))
- (('primcall (or 's64->scm 's64->scm/unlikely) s64)
+ (add-def! `(primcall s64->scm #f ,s64) scm))))
+ (('primcall (or 's64->scm 's64->scm/unlikely) #f s64)
(match defs
((scm)
- (add-def! `(primcall scm->s64 ,scm) s64))))
+ (add-def! `(primcall scm->s64 #f ,scm) s64))))
(_ #t))))
(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)))
(($ $callk k proc args)
($callk k (subst-var proc) ,(map subst-var args)))
- (($ $primcall name args)
- ($primcall name ,(map subst-var args)))
+ (($ $primcall name param args)
+ ($primcall name param ,(map subst-var args)))
(($ $branch k exp)
($branch k ,(visit-exp exp)))
(($ $values args)
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 2330d42..efead75 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -149,9 +149,9 @@ sites."
(($ $callk kfun proc args)
(values (intset-add live-labels kfun)
(adjoin-vars args (adjoin-var proc live-vars))))
- (($ $primcall name args)
+ (($ $primcall name param args)
(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 args)
(values live-labels
@@ -191,7 +191,7 @@ sites."
(($ $primcall
(or 'vector-set! 'vector-set!/immediate
'set-car! 'set-cdr!
- 'box-set!)
+ 'box-set!) #f
(obj . _))
(or (var-live? obj live-vars)
(not (intset-ref known-allocations obj))))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index be97788..50531f3 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -538,7 +538,7 @@ is or might be a read or a write to the same location as A."
&all-effects)
(($ $branch k exp)
(expression-effects exp constants))
- (($ $primcall name args)
+ (($ $primcall name param args)
(primitive-effects constants name args))))
(define (compute-effects conts)
diff --git a/module/language/cps/elide-values.scm
b/module/language/cps/elide-values.scm
index 81ccfc2..c0c91c5 100644
--- a/module/language/cps/elide-values.scm
+++ b/module/language/cps/elide-values.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@@ -59,7 +59,7 @@
(with-cps cps
(letv 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))))))
(with-cps cps
(letv rest)
@@ -76,7 +76,7 @@
(intmap-fold
(lambda (label cont out)
(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))
(lambda (out term)
(if term
diff --git a/module/language/cps/handle-interrupts.scm
b/module/language/cps/handle-interrupts.scm
index 55d25f2..758637c 100644
--- a/module/language/cps/handle-interrupts.scm
+++ b/module/language/cps/handle-interrupts.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@@ -62,7 +62,7 @@
(setk label
($kargs names vars
($continue k* src
- ($primcall 'handle-interrupts ()))))))))
+ ($primcall 'handle-interrupts #f ()))))))))
(let* ((cps (renumber cps))
(safepoints (compute-safepoints cps)))
(with-fresh-name-state cps
diff --git a/module/language/cps/licm.scm b/module/language/cps/licm.scm
index 3b343a6..5d9db9d 100644
--- a/module/language/cps/licm.scm
+++ b/module/language/cps/licm.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@@ -70,8 +70,8 @@
((or ($ $const) ($ $prim) ($ $closure)) #t)
(($ $prompt) #f) ;; ?
(($ $branch) #f)
- (($ $primcall 'values) #f)
- (($ $primcall name args)
+ (($ $primcall 'values #f) #f)
+ (($ $primcall name param args)
(and-map (lambda (arg) (not (intset-ref loop-vars arg)))
args))
(($ $values args)
diff --git a/module/language/cps/peel-loops.scm
b/module/language/cps/peel-loops.scm
index e73c6c7..c93bbc8 100644
--- a/module/language/cps/peel-loops.scm
+++ b/module/language/cps/peel-loops.scm
@@ -141,10 +141,10 @@
($call (rename-var proc) ,(map rename-var args)))
(($ $callk k proc args)
($callk k (rename-var proc) ,(map rename-var args)))
- (($ $branch kt ($ $primcall name args))
- ($branch (rename-label kt) ($primcall name ,(map rename-var args))))
- (($ $primcall name args)
- ($primcall name ,(map rename-var args)))
+ (($ $branch kt ($ $primcall name param args))
+ ($branch (rename-label kt) ($primcall name param ,(map rename-var
args))))
+ (($ $primcall name param args)
+ ($primcall name param ,(map rename-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) (rename-label handler)))))
(rewrite-cont cont
diff --git a/module/language/cps/prune-bailouts.scm
b/module/language/cps/prune-bailouts.scm
index 7c10319..6a46798 100644
--- a/module/language/cps/prune-bailouts.scm
+++ b/module/language/cps/prune-bailouts.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
diff --git a/module/language/cps/prune-top-level-scopes.scm
b/module/language/cps/prune-top-level-scopes.scm
index 1970d1b..ae33426 100644
--- a/module/language/cps/prune-top-level-scopes.scm
+++ b/module/language/cps/prune-top-level-scopes.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@@ -37,7 +37,7 @@
(match cont
(($ $kargs _ _
($ $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)))
(_
used-scopes)))
@@ -52,7 +52,7 @@
(match cont
(($ $kargs names vars
($ $continue k src
- ($ $primcall 'cache-current-module!
+ ($ $primcall 'cache-current-module! #f
(module (? (lambda (scope)
(let ((val (intmap-ref constants scope)))
(not (intset-ref used-scopes val)))))))))
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index 60be330..d2b173e 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@@ -44,7 +44,7 @@
(public? public?)
(bound? bound?))
(build-term ($continue kbox src
- ($primcall 'cached-module-box
+ ($primcall 'cached-module-box #f
(module name public? bound?))))))))
(define (primitive-module name)
@@ -95,13 +95,13 @@
(lambda (cps box)
(with-cps cps
(build-term
- ($continue k src ($primcall 'box-ref (box))))))))
+ ($continue k src ($primcall 'box-ref #f (box))))))))
(define (builtin-ref cps idx k src)
(with-cps cps
($ (with-cps-constants ((idx idx))
(build-term
- ($continue k src ($primcall 'builtin-ref (idx))))))))
+ ($continue k src ($primcall 'builtin-ref #f (idx))))))))
(define (reify-clause cps ktail)
(with-cps cps
@@ -149,20 +149,23 @@
(let$ body (resolve-prim name k src))
(setk label ($kargs names vars ,body))))
(($ $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
(setk label ($kargs names vars ($continue k src ($call proc ()))))))
- (($ $kargs names vars ($ $continue k src ($ $primcall name args)))
- (if (or (prim-instruction name) (branching-primitive? name))
- ;; Assume arities are correct.
- cps
- (with-cps cps
- (letv proc)
- (let$ k (uniquify-receive k))
- (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 ($ $primcall name param args)))
+ (cond
+ ((or (prim-instruction name) (branching-primitive? name))
+ ;; Assume arities are correct.
+ cps)
+ (param (error "unexpected param to reified primcall" name))
+ (else
+ (with-cps cps
+ (letv proc)
+ (let$ k (uniquify-receive k))
+ (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)))
(with-cps cps
(let$ k (uniquify-receive k))
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index 8bab863..fdd1271 100644
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; 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)))
(($ $branch kt exp)
($branch (rename-label kt) ,(rename-exp exp)))
- (($ $primcall name args)
- ($primcall name ,(map rename-var args)))
+ (($ $primcall name param args)
+ ($primcall name param ,(map rename-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) (rename-label handler)))))
(define (rename-arity arity)
diff --git a/module/language/cps/rotate-loops.scm
b/module/language/cps/rotate-loops.scm
index 3abd50f..93ac0b3 100644
--- a/module/language/cps/rotate-loops.scm
+++ b/module/language/cps/rotate-loops.scm
@@ -108,10 +108,10 @@
($call (rename-var proc) ,(map rename-var args)))
(($ $callk k proc args)
($callk k (rename-var proc) ,(map rename-var args)))
- (($ $branch kt ($ $primcall name args))
- ($branch kt ($primcall name ,(map rename-var args))))
- (($ $primcall name args)
- ($primcall name ,(map rename-var args)))
+ (($ $branch kt ($ $primcall name param args))
+ ($branch kt ($primcall name param ,(map rename-var args))))
+ (($ $primcall name param args)
+ ($primcall name param ,(map rename-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) handler))))
(define (attach-trampoline label src names vars args)
diff --git a/module/language/cps/self-references.scm
b/module/language/cps/self-references.scm
index 5b4d6e7..e874f0e 100644
--- a/module/language/cps/self-references.scm
+++ b/module/language/cps/self-references.scm
@@ -43,10 +43,10 @@
($call (subst proc) ,(map subst args)))
(($ $callk k proc args)
($callk k (subst proc) ,(map subst args)))
- (($ $primcall name args)
- ($primcall name ,(map subst args)))
- (($ $branch k ($ $primcall name args))
- ($branch k ($primcall name ,(map subst args))))
+ (($ $primcall name param args)
+ ($primcall name param ,(map subst args)))
+ (($ $branch k ($ $primcall name param args))
+ ($branch k ($primcall name param ,(map subst args))))
(($ $values args)
($values ,(map subst args)))
(($ $prompt escape? tag handler)
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index f3ff835..4625569 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -74,11 +74,11 @@
(ref* (cons proc args)))
(($ $callk k proc args)
(ref* (cons proc args)))
- (($ $primcall name args)
+ (($ $primcall name param args)
(ref* args))
(($ $values args)
(ref* args))
- (($ $branch kt ($ $primcall name args))
+ (($ $branch kt ($ $primcall name param args))
(ref* args))
(($ $prompt escape? tag handler)
(ref tag))))
@@ -152,7 +152,7 @@
(($ $kargs (_)
((? (lambda (var) (intset-ref singly-used var))
var))
- ($ $continue kf _ ($ $branch kt ($ $primcall 'false?
(var)))))
+ ($ $continue kf _ ($ $branch kt ($ $primcall 'false? #f
(var)))))
(build-cont
($kargs names syms
($continue (subst (if val kf kt)) src ($values ())))))
@@ -249,12 +249,12 @@
($call (subst proc) ,(map subst args)))
(($ $callk k proc args)
($callk k (subst proc) ,(map subst args)))
- (($ $primcall name args)
- ($primcall name ,(map subst args)))
+ (($ $primcall name param args)
+ ($primcall name param ,(map subst args)))
(($ $values args)
($values ,(map subst args)))
- (($ $branch kt ($ $primcall name args))
- ($branch kt ($primcall name ,(map subst args))))
+ (($ $branch kt ($ $primcall name param args))
+ ($branch kt ($primcall name param ,(map subst args))))
(($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler)))))))
(transform-conts
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index f223a50..278210d 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -172,9 +172,9 @@ by a label, respectively."
(return (get-defs k) (intset-add (vars->intset args) proc)))
(($ $callk _ proc args)
(return (get-defs k) (intset-add (vars->intset args) proc)))
- (($ $primcall name args)
+ (($ $primcall name param 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)))
(($ $values 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
(($ $const)
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)
- (($ $primcall 'free-ref (closure slot))
+ (($ $primcall 'free-ref #f (closure slot))
(defs+ closure))
- (($ $primcall 'free-set! (closure slot value))
+ (($ $primcall 'free-set! #f (closure slot value))
(defs+* (intset closure value)))
- (($ $primcall 'cache-current-module! (mod . _))
+ (($ $primcall 'cache-current-module! #f (mod . _))
(defs+ mod))
- (($ $primcall 'cached-toplevel-box _)
+ (($ $primcall 'cached-toplevel-box #f _)
defs)
- (($ $primcall 'cached-module-box _)
+ (($ $primcall 'cached-module-box #f _)
defs)
- (($ $primcall 'resolve (name bound?))
+ (($ $primcall 'resolve #f (name bound?))
(defs+ name))
- (($ $primcall 'make-vector/immediate (len init))
+ (($ $primcall 'make-vector/immediate #f (len init))
(defs+ init))
- (($ $primcall 'vector-ref/immediate (v i))
+ (($ $primcall 'vector-ref/immediate #f (v i))
(defs+ v))
- (($ $primcall 'vector-set!/immediate (v i x))
+ (($ $primcall 'vector-set!/immediate #f (v i x))
(defs+* (intset v x)))
- (($ $primcall 'allocate-struct/immediate (vtable nfields))
+ (($ $primcall 'allocate-struct/immediate #f (vtable nfields))
(defs+ vtable))
- (($ $primcall 'struct-ref/immediate (s n))
+ (($ $primcall 'struct-ref/immediate #f (s n))
(defs+ s))
- (($ $primcall 'struct-set!/immediate (s n x))
+ (($ $primcall 'struct-set!/immediate #f (s n x))
(defs+* (intset s x)))
(($ $primcall (or 'add/immediate 'sub/immediate
'uadd/immediate 'usub/immediate 'umul/immediate
- 'ursh/immediate 'ulsh/immediate)
+ 'ursh/immediate 'ulsh/immediate) #f
(x y))
(defs+ x))
- (($ $primcall 'builtin-ref (idx))
+ (($ $primcall 'builtin-ref #f (idx))
defs)
(_
(defs+* (get-uses label))))))
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index ffc67ed..3551a9c 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -71,16 +71,16 @@
(letv f64-a f64-b result)
(letk kbox ($kargs ('result) (result)
($continue k src
- ($primcall 'f64->scm (result)))))
+ ($primcall 'f64->scm #f (result)))))
(letk kop ($kargs ('f64-b) (f64-b)
($continue kbox src
- ($primcall fop (f64-a f64-b)))))
+ ($primcall fop #f (f64-a f64-b)))))
(letk kunbox-b ($kargs ('f64-a) (f64-a)
($continue kop src
- ($primcall 'scm->f64 (b)))))
+ ($primcall 'scm->f64 #f (b)))))
(build-term
($continue kunbox-b src
- ($primcall 'scm->f64 (a)))))))
+ ($primcall 'scm->f64 #f (a)))))))
(define* (specialize-u64-binop cps k src op a b #:key
(unbox-a 'scm->u64)
@@ -99,26 +99,26 @@
(letv u64-a u64-b result)
(letk kbox ($kargs ('result) (result)
($continue k src
- ($primcall 'u64->scm (result)))))
+ ($primcall 'u64->scm #f (result)))))
(letk kop ($kargs ('u64-b) (u64-b)
($continue kbox src
- ($primcall uop (u64-a u64-b)))))
+ ($primcall uop #f (u64-a u64-b)))))
(letk kunbox-b ($kargs ('u64-a) (u64-a)
($continue kop src
- ($primcall unbox-b (b)))))
+ ($primcall unbox-b #f (b)))))
(build-term
($continue kunbox-b src
- ($primcall unbox-a (a)))))))
+ ($primcall unbox-a #f (a)))))))
(define (truncate-u64 cps k src scm)
(with-cps cps
(letv u64)
(letk kbox ($kargs ('u64) (u64)
($continue k src
- ($primcall 'u64->scm (u64)))))
+ ($primcall 'u64->scm #f (u64)))))
(build-term
($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)
(let ((op (symbol-append 'u64- op)))
@@ -126,13 +126,13 @@
(letv u64-a u64-b)
(letk kop ($kargs ('u64-b) (u64-b)
($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)
($continue kop src
- ($primcall 'scm->u64 (b)))))
+ ($primcall 'scm->u64 #f (b)))))
(build-term
($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)
(let ((u64-op (symbol-append 'u64- op)))
@@ -140,33 +140,33 @@
(letv u64 s64 zero z64 sunk)
(letk kheap ($kargs ('sunk) (sunk)
($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
;; marked u64->scm to avoid CSE from hoisting the allocation
;; again. Instaed we should just use a-u64 directly and implement
;; an allocation sinking pass that should handle this..
(letk kretag ($kargs () ()
($continue kheap src
- ($primcall 'u64->scm/unlikely (u64)))))
+ ($primcall 'u64->scm/unlikely #f (u64)))))
(letk kcmp ($kargs () ()
($continue kf src
- ($branch kt ($primcall u64-op (u64 s64))))))
+ ($branch kt ($primcall u64-op #f (u64 s64))))))
(letk kz64 ($kargs ('z64) (z64)
($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)
- ($continue kz64 src ($primcall 'load-s64 (zero)))))
+ ($continue kz64 src ($primcall 'load-s64 #f (zero)))))
(letk ks64 ($kargs ('s64) (s64)
($continue kzero src ($const 0))))
(letk kfix ($kargs () ()
($continue ks64 src
- ($primcall 'untag-fixnum (b-scm)))))
+ ($primcall 'untag-fixnum #f (b-scm)))))
(letk ku64 ($kargs ('u64) (u64)
($continue kretag src
- ($branch kfix ($primcall 'fixnum? (b-scm))))))
+ ($branch kfix ($primcall 'fixnum? #f (b-scm))))))
(build-term
($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)
(let ((op (symbol-append 'f64- op)))
@@ -174,13 +174,13 @@
(letv f64-a f64-b)
(letk kop ($kargs ('f64-b) (f64-b)
($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)
($continue kop src
- ($primcall 'scm->f64 (b)))))
+ ($primcall 'scm->f64 #f (b)))))
(build-term
($continue kunbox-b src
- ($primcall 'scm->f64 (a)))))))
+ ($primcall 'scm->f64 #f (a)))))))
(define (sigbits-union x y)
(and x y (logior x y)))
@@ -217,7 +217,7 @@
((primop label types out def ...) arg ...)
body ...)
(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 ...)))))))
(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))
(($ $callk label proc args)
(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))
- (($ $primcall name args)
+ (($ $primcall name param args)
(let ((h (significant-bits-handler name)))
(if h
(match (intmap-ref cps k)
(($ $kargs _ defs)
- (h label types out args defs)))
+ (h label types out param args defs)))
(add-unknown-uses out args))))
(($ $prompt escape? tag handler)
(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))))
(($ $kargs names vars
($ $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)
(($ $kargs (_) (result))
(call-with-values (lambda ()
@@ -360,7 +360,7 @@ BITS indicating the significant bits needed for a variable.
BITS may be
types
sigbits))))))
(($ $kargs names vars
- ($ $continue k src ($ $primcall 'ash (a b))))
+ ($ $continue k src ($ $primcall 'ash #f (a b))))
(match (intmap-ref cps k)
(($ $kargs (_) (result))
(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))
(build-term
($continue kneg src
- ($primcall 'sub (zero b))))))
+ ($primcall 'sub #f (zero b))))))
(setk label ($kargs names vars ,body))))
(else
(with-cps cps
@@ -401,7 +401,7 @@ BITS indicating the significant bits needed for a variable.
BITS may be
sigbits))))))
(($ $kargs names vars
($ $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)
(($ $kargs (_) (result))
(values
@@ -431,7 +431,7 @@ BITS indicating the significant bits needed for a variable.
BITS may be
types sigbits))))
(($ $kargs names vars
($ $continue k src
- ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a
b)))))
+ ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) #f (a
b)))))
(values
(cond
((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)
(($ $kargs _ _ ($ $continue k _ 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))
(($ $values vars)
(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?
(define (exp-result-f64? exp)
(match exp
- ((or ($ $primcall 'f64->scm (_))
+ ((or ($ $primcall 'f64->scm #f (_))
($ $const (and (? number?) (? inexact?) (? real?))))
#t)
(_ #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?
(define (exp-result-u64? exp)
(match exp
- ((or ($ $primcall 'u64->scm (_))
- ($ $primcall 'u64->scm/unlikely (_))
+ ((or ($ $primcall 'u64->scm #f (_))
+ ($ $primcall 'u64->scm/unlikely #f (_))
($ $const (and (? number?) (? exact-integer?)
(? (lambda (n) (<= 0 n #xffffffffffffffff))))))
#t)
@@ -638,7 +638,7 @@ BITS indicating the significant bits needed for a variable.
BITS may be
(let$ body (have-arg unboxed))
(letk kunboxed ($kargs ('unboxed) (unboxed) ,body))
(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)))
(define (unbox-args cps args def-vars have-args)
(match args
@@ -677,7 +677,7 @@ BITS indicating the significant bits needed for a variable.
BITS may be
(letv boxed)
(letk kunbox ($kargs ('boxed) (boxed)
($continue k src
- ($primcall (unbox-op def) (boxed)))))
+ ($primcall (unbox-op def) #f (boxed)))))
(setk label ($kargs names vars
($continue kunbox src ,exp)))))))))))))
(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))
(build-term
($continue kboxed #f
- ($primcall (box-op var) (unboxed)))))
+ ($primcall (box-op var) #f (unboxed)))))
(done cps))))
(define (box-vars cps names vars done)
(match vars
diff --git a/module/language/cps/specialize-primcalls.scm
b/module/language/cps/specialize-primcalls.scm
index a52e344..5b3c6df 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -49,9 +49,9 @@
(define (f64? var)
(let ((val (intmap-ref constants var (lambda (_) #f))))
(and (number? val) (inexact? val) (real? val))))
- (define (specialize-primcall name args)
+ (define (specialize-primcall name param args)
(define (rename name)
- (build-exp ($primcall name args)))
+ (build-exp ($primcall name param args)))
(match (cons name args)
(('make-vector (? u8? n) init) (rename 'make-vector/immediate))
(('vector-ref v (? u8? n)) (rename 'vector-ref/immediate))
@@ -59,16 +59,16 @@
(('allocate-struct v (? u8? n)) (rename 'allocate-struct/immediate))
(('struct-ref s (? u8? n)) (rename 'struct-ref/immediate))
(('struct-set! s (? u8? n) x) (rename 'struct-set!/immediate))
- (('add x (? u8? y)) (build-exp ($primcall 'add/immediate (x y))))
- (('add (? u8? x) y) (build-exp ($primcall 'add/immediate (y x))))
- (('sub x (? u8? y)) (build-exp ($primcall 'sub/immediate (x y))))
- (('uadd x (? u8? y)) (build-exp ($primcall 'uadd/immediate (x y))))
- (('uadd (? u8? x) y) (build-exp ($primcall 'uadd/immediate (y x))))
- (('usub x (? u8? y)) (build-exp ($primcall 'usub/immediate (x y))))
- (('umul x (? u8? y)) (build-exp ($primcall 'umul/immediate (x y))))
- (('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate (y x))))
- (('ursh x (? u6? y)) (build-exp ($primcall 'ursh/immediate (x y))))
- (('ulsh x (? u6? y)) (build-exp ($primcall 'ulsh/immediate (x y))))
+ (('add x (? u8? y)) (build-exp ($primcall 'add/immediate #f (x y))))
+ (('add (? u8? x) y) (build-exp ($primcall 'add/immediate #f (y x))))
+ (('sub x (? u8? y)) (build-exp ($primcall 'sub/immediate #f (x y))))
+ (('uadd x (? u8? y)) (build-exp ($primcall 'uadd/immediate #f (x y))))
+ (('uadd (? u8? x) y) (build-exp ($primcall 'uadd/immediate #f (y x))))
+ (('usub x (? u8? y)) (build-exp ($primcall 'usub/immediate #f (x y))))
+ (('umul x (? u8? y)) (build-exp ($primcall 'umul/immediate #f (x y))))
+ (('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate #f (y x))))
+ (('ursh x (? u6? y)) (build-exp ($primcall 'ursh/immediate #f (x y))))
+ (('ulsh x (? u6? y)) (build-exp ($primcall 'ulsh/immediate #f (x y))))
(('scm->f64 (? f64?)) (rename 'load-f64))
(('scm->u64 (? u64?)) (rename 'load-u64))
(('scm->u64/truncate (? u64?)) (rename 'load-u64))
@@ -77,8 +77,8 @@
(intmap-map
(lambda (label cont)
(match cont
- (($ $kargs names vars ($ $continue k src ($ $primcall name args)))
- (let ((exp* (specialize-primcall name args)))
+ (($ $kargs names vars ($ $continue k src ($ $primcall name param
args)))
+ (let ((exp* (specialize-primcall name param args)))
(if exp*
(build-cont
($kargs names vars ($continue k src ,exp*)))
diff --git a/module/language/cps/split-rec.scm
b/module/language/cps/split-rec.scm
index 5a8119b..c733c38 100644
--- a/module/language/cps/split-rec.scm
+++ b/module/language/cps/split-rec.scm
@@ -87,9 +87,9 @@ references."
(add-uses args uses))
(($ $call proc args)
(add-use proc (add-uses args uses)))
- (($ $branch kt ($ $primcall name args))
+ (($ $branch kt ($ $primcall name param args))
(add-uses args uses))
- (($ $primcall name args)
+ (($ $primcall name param args)
(add-uses args uses))
(($ $prompt escape? tag handler)
(add-use tag uses)))))
diff --git a/module/language/cps/type-checks.scm
b/module/language/cps/type-checks.scm
index 864371d..a022c3a 100644
--- a/module/language/cps/type-checks.scm
+++ b/module/language/cps/type-checks.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; 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
KFUN where we can prove that no assertion will be raised at run-time."
(let ((types (infer-types conts kfun)))
- (define (visit-primcall effects fx label name args)
- (if (primcall-types-check? types label name args)
+ (define (visit-primcall effects fx label name param args)
+ (if (primcall-types-check? types label name param args)
(intmap-replace! effects label (logand fx (lognot &type-check)))
effects))
(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)
(($ $kargs _ _ exp)
(match exp
- (($ $continue k src ($ $primcall name args))
- (visit-primcall effects fx label name args))
+ (($ $continue k src ($ $primcall name param args))
+ (visit-primcall effects fx label name param
args))
(($ $continue k src
- ($ $branch _ ($primcall name args)))
- (visit-primcall effects fx label name args))
+ ($ $branch _ ($primcall name param args)))
+ (visit-primcall effects fx label name param
args))
(_ effects)))
(_ effects)))
(else effects))))
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index 8086b0c..ce280b9 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -52,12 +52,12 @@
(hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from)))
(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
arg1 min1 max1)
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-unary-branch-folder (name type min max)
@@ -198,7 +198,7 @@
arg type min max)
body ...)
(define-primcall-reducer name
- (lambda (cps k src arg type min max)
+ (lambda (cps k src param arg type min max)
body ...)))
(define-syntax-rule (define-binary-primcall-reducer (name cps k src
@@ -206,7 +206,7 @@
arg1 type1 min1 max1)
body ...)
(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 ...)))
(define-binary-primcall-reducer (mul cps k src
@@ -217,7 +217,7 @@
(with-cps cps
($ (with-cps-constants ((zero 0))
(build-term
- ($continue k src ($primcall 'sub (zero arg))))))))
+ ($continue k src ($primcall 'sub #f (zero arg))))))))
(define (zero)
(with-cps cps
(build-term ($continue k src ($const 0)))))
@@ -226,13 +226,13 @@
(build-term ($continue k src ($values (arg))))))
(define (double arg)
(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)
(let ((n (let lp ((bits 0) (constant constant))
(if (= constant 1) bits (lp (1+ bits) (ash constant -1))))))
(with-cps cps
($ (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)
(cond
((not (or (type<=? constant-type &exact-integer)
@@ -278,7 +278,7 @@
(with-cps cps
($ (with-cps-constants ((one 1))
(build-term
- ($continue kmask src ($primcall 'ash (one arg0)))))))))
+ ($continue kmask src ($primcall 'ash #f (one arg0)))))))))
(with-cps cps
(letv mask test)
(letk kt ($kargs () ()
@@ -288,12 +288,12 @@
(let$ body (with-cps-constants ((zero 0))
(build-term
($continue kt src
- ($branch kf ($primcall 'eq? (test zero)))))))
+ ($branch kf ($primcall 'eq? #f (test zero)))))))
(letk kand ($kargs (#f) (test)
,body))
(letk kmask ($kargs (#f) (mask)
($continue kand src
- ($primcall 'logand (mask arg1)))))
+ ($primcall 'logand #f (mask arg1)))))
($ (compute-mask kmask src))))
;; Hairiness because we are converting from a primcall with unknown
;; arity to a branching primcall.
@@ -316,7 +316,7 @@
(with-cps cps
(letv bool)
(letk kbool ($kargs (#f) (bool)
- ($continue k src ($primcall 'values (bool)))))
+ ($continue k src ($primcall 'values #f (bool)))))
($ (convert-to-logtest kbool))))))
(($ $ktail)
(with-cps cps
@@ -350,7 +350,7 @@
(else (error "unhandled immediate" val))))
(else (error "unhandled type" type val))))
(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))
(lambda (type min max)
(and (not (zero? type))
@@ -367,8 +367,8 @@
;; possible.
(setk label
($kargs names vars
- ($continue k* src ($primcall name args))))))))))
- (define (reduce-primcall cps label names vars k src name args)
+ ($continue k* src ($primcall name param
args))))))))))
+ (define (reduce-primcall cps label names vars k src name param args)
(and=>
(hashq-ref *primcall-reducers* name)
(lambda (reducer)
@@ -377,7 +377,8 @@
(call-with-values (lambda () (lookup-pre-type types label arg0))
(lambda (type0 min0 max0)
(call-with-values (lambda ()
- (reducer cps k src arg0 type0 min0 max0))
+ (reducer cps k src param
+ arg0 type0 min0 max0))
(lambda (cps term)
(and term
(with-cps cps
@@ -388,20 +389,21 @@
(call-with-values (lambda () (lookup-pre-type types label
arg1))
(lambda (type1 min1 max1)
(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))
(lambda (cps term)
(and term
(with-cps cps
(setk label ($kargs names vars ,term)))))))))))
(_ #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=>
(hashq-ref *branch-folders* name)
(lambda (folder)
(call-with-values (lambda () (lookup-pre-type types label arg))
(lambda (type min max)
- (call-with-values (lambda () (folder type min max))
+ (call-with-values (lambda () (folder param type min max))
(lambda (f? v)
;; (when f? (pk 'folded-unary-branch label name arg v))
(and f?
@@ -410,7 +412,7 @@
($kargs names vars
($continue (if v kt kf) src
($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=>
(hashq-ref *branch-folders* name)
(lambda (folder)
@@ -419,7 +421,7 @@
(call-with-values (lambda () (lookup-pre-type types label arg1))
(lambda (type1 min1 max1)
(call-with-values (lambda ()
- (folder type0 min0 max0 type1 min1 max1))
+ (folder param type0 min0 max0 type1 min1
max1))
(lambda (f? v)
;; (when f? (pk 'folded-binary-branch label name arg0
arg1 v))
(and f?
@@ -430,24 +432,24 @@
($values ())))))))))))))))
(define (visit-expression cps label names vars k src exp)
(match exp
- (($ $primcall name args)
+ (($ $primcall name param args)
;; We might be able to fold primcalls that define a value.
(match (intmap-ref cps k)
(($ $kargs (_) (def))
- (or (fold-primcall cps label names vars k src name args def)
- (reduce-primcall cps label names vars k src name args)
+ (or (fold-primcall cps label names vars k src name param args def)
+ (reduce-primcall cps label names vars k src name param args)
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))))
- (($ $branch kt ($ $primcall name args))
+ (($ $branch kt ($ $primcall name param args))
;; We might be able to fold primcalls that branch.
(match args
((x)
- (or (fold-unary-branch cps label names vars k kt src name x)
+ (or (fold-unary-branch cps label names vars k kt src name param x)
cps))
((x y)
- (or (fold-binary-branch cps label names vars k kt src name x y)
+ (or (fold-binary-branch cps label names vars k kt src name param x
y)
cps))))
(_ cps)))
(let lp ((label start) (cps cps))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 6ea7ced..72570e4 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -412,7 +412,7 @@ minimum, and maximum."
(hashq-set!
*type-checkers*
'name
- (lambda (typeset arg ...)
+ (lambda (typeset param arg ...)
(syntax-parameterize
((&type (syntax-rules () ((_ val) (var-type typeset val))))
(&min (syntax-rules () ((_ val) (var-min typeset val))))
@@ -430,7 +430,7 @@ minimum, and maximum."
(hashq-set!
*type-inferrers*
'name
- (lambda (in succ var ...)
+ (lambda (in succ param var ...)
(let ((out in))
(syntax-parameterize
((define!
@@ -1625,13 +1625,13 @@ maximum, where type is a bitset as a fixnum."
((var . vars)
(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
((hashq-ref *type-inferrers* name)
=> (lambda (inferrer)
;; FIXME: remove the apply?
;; (pk 'primcall name args result)
- (apply inferrer types succ
+ (apply inferrer types succ param
(if result
(append args (list result))
args))))
@@ -1688,19 +1688,19 @@ maximum, where type is a bitset as a fixnum."
(values (append changed0 changed1) typev)))
;; Each of these branches must propagate to its successors.
(match exp
- (($ $branch kt ($ $primcall name args))
+ (($ $branch kt ($ $primcall name param args))
;; The "normal" continuation is the #f branch.
- (let ((kf-types (infer-primcall types 0 name args #f))
- (kt-types (infer-primcall types 1 name args #f)))
+ (let ((kf-types (infer-primcall types 0 name param args #f))
+ (kt-types (infer-primcall types 1 name param args #f)))
(propagate2 k kf-types kt kt-types)))
(($ $prompt escape? tag handler)
;; The "normal" continuation enters the prompt.
(propagate2 k types handler types))
- (($ $primcall name args)
+ (($ $primcall name param args)
(propagate1 k
(match (intmap-ref conts k)
(($ $kargs _ defs)
- (infer-primcall types 0 name args
+ (infer-primcall types 0 name param args
(match defs ((var) var) (() #f))))
(_
;; (pk 'warning-no-restrictions name)
@@ -1787,9 +1787,9 @@ maximum, where type is a bitset as a fixnum."
(type-entry-min 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)
(#f #f)
(checker
(let ((entry (intmap-ref types label)))
- (apply checker (vector-ref entry 0) args)))))
+ (apply checker (vector-ref entry 0) param args)))))
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index 3fce00a..40445cf 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@@ -205,22 +205,22 @@ disjoint, an error will be signalled."
(intmap-fold
(lambda (var exp out)
(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)))
;; Punch through type conversions to allow uadd to specialize
;; to uadd/immediate.
- (($ $primcall 'scm->f64 (val))
+ (($ $primcall 'scm->f64 #f (val))
(let ((f64 (intmap-ref out val (lambda (_) #f))))
(if (and f64 (number? f64) (inexact? f64) (real? f64))
(intmap-add! out var f64)
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))))
(if (and u64 (number? u64) (exact-integer? u64)
(<= 0 u64 #xffffFFFFffffFFFF))
(intmap-add! out var u64)
out)))
- (($ $primcall 'scm->s64 (val))
+ (($ $primcall 'scm->s64 #f (val))
(let ((s64 (intmap-ref out val (lambda (_) #f))))
(if (and s64 (number? s64) (exact-integer? s64)
(<= (- #x8000000000000000) s64 #x7fffFFFFffffFFFF))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index f41d8e3..e55cf83 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -160,10 +160,10 @@ definitions that are available at LABEL."
(check-use proc)
(for-each check-use args)
(visit-first-order kfun))
- (($ $branch kt ($ $primcall name args))
+ (($ $branch kt ($ $primcall name param args))
(for-each check-use args)
first-order)
- (($ $primcall name args)
+ (($ $primcall name param args)
(for-each check-use args)
first-order)
(($ $prompt escape? tag handler)
@@ -242,7 +242,7 @@ definitions that are available at LABEL."
(match (intmap-ref conts kt)
(($ $kargs () ()) #t)
(cont (error "bad kt" cont))))
- (($ $primcall name args)
+ (($ $primcall name param args)
(match cont
(($ $kargs names)
(match (prim-arity name)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 510dceb..670d72f 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -91,13 +91,13 @@
(#f
(with-cps cps
(build-term ($continue k src
- ($primcall 'resolve (name bound?))))))
+ ($primcall 'resolve #f (name bound?))))))
(scope-id
(with-cps cps
($ (with-cps-constants ((scope scope-id))
(build-term
($continue k src
- ($primcall 'cached-toplevel-box (scope name bound?))))))))))
+ ($primcall 'cached-toplevel-box #f (scope name
bound?))))))))))
(with-cps cps
(letv box)
(let$ body (val-proc box))
@@ -116,7 +116,7 @@
(public? public?)
(bound? bound?))
(build-term ($continue kbox src
- ($primcall 'cached-module-box
+ ($primcall 'cached-module-box #f
(module name public? bound?))))))))
(define (capture-toplevel-scope cps src scope-id k)
@@ -125,10 +125,10 @@
(let$ body (with-cps-constants ((scope scope-id))
(build-term
($continue k src
- ($primcall 'cache-current-module! (module scope))))))
+ ($primcall 'cache-current-module! #f (module scope))))))
(letk kmodule ($kargs ('module) (module) ,body))
(build-term ($continue kmodule src
- ($primcall 'current-module ())))))
+ ($primcall 'current-module #f ())))))
(define (fold-formals proc seed arity gensyms inits)
(match arity
@@ -176,7 +176,7 @@
($ (with-cps-constants ((unbound (pointer->scm
(make-pointer unbound-bits))))
(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)
(match (hashq-ref subst sym)
@@ -187,7 +187,7 @@
(with-cps cps
(letv phi)
(letk kbox ($kargs (name) (phi)
- ($continue k src ($primcall 'box (phi)))))
+ ($continue k src ($primcall 'box #f (phi)))))
($ (make-body kbox)))
(make-body cps k)))
(with-cps cps
@@ -278,7 +278,7 @@
(let$ void (with-cps-constants ((unspecified *unspecified*))
(build-term
($continue k src
- ($primcall 'values (unspecified))))))
+ ($primcall 'values #f (unspecified))))))
(letk kvoid ($kargs () () ,void))
kvoid))))))
(1
@@ -296,7 +296,7 @@
(letv val)
(let$ body (with-cps-constants ((nil '()))
(build-term
- ($continue kargs src ($primcall 'cons (val
nil))))))
+ ($continue kargs src ($primcall 'cons #f (val
nil))))))
(letk kval ($kargs ('val) (val) ,body))
kval))
(($ $arity (_) () #f () #f)
@@ -316,7 +316,7 @@
(letv val)
(letk kval ($kargs ('val) (val)
($continue k src
- ($primcall 'values (val)))))
+ ($primcall 'values #f (val)))))
kval))))))))
;; cps exp k-name alist -> cps term
@@ -331,7 +331,7 @@
(letv unboxed)
(let$ body (k unboxed))
(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))
(var (k cps var))))
(else
@@ -356,7 +356,7 @@
((orig-var subst-var #t)
(with-cps cps
(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
(with-cps cps body))))
(define (box-bound-vars cps names syms body)
@@ -376,7 +376,7 @@
(with-cps cps
(let$ k (adapt-arity k src 1))
(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))))
(var ($continue k src ($values (var)))))))
@@ -456,7 +456,7 @@
(lambda (cps box)
(with-cps cps
(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)
(convert-arg cps exp
@@ -467,7 +467,7 @@
(with-cps cps
(let$ k (adapt-arity k src 0))
(build-term
- ($continue k src ($primcall 'box-set! (box val))))))))))
+ ($continue k src ($primcall 'box-set! #f (box val))))))))))
(($ <toplevel-ref> src name)
(toplevel-box
@@ -475,7 +475,7 @@
(lambda (cps box)
(with-cps cps
(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)
(convert-arg cps exp
@@ -486,7 +486,7 @@
(with-cps cps
(let$ k (adapt-arity k src 0))
(build-term
- ($continue k src ($primcall 'box-set! (box val))))))))))
+ ($continue k src ($primcall 'box-set! #f (box val))))))))))
(($ <toplevel-define> src name exp)
(convert-arg cps exp
@@ -495,10 +495,10 @@
(let$ k (adapt-arity k src 0))
(letv 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))
(build-term
- ($continue kset src ($primcall 'define! (name))))))))))
+ ($continue kset src ($primcall 'define! #f (name))))))))))
(($ <call> src proc args)
(convert-args cps (cons proc args)
@@ -535,7 +535,7 @@
(with-cps cps
(build-term
($continue k src
- ($primcall 'cons (head tail))))))))
+ ($primcall 'cons #f (head
tail))))))))
(letk ktail ($kargs ('tail) (tail) ,body))
($ (lp args ktail)))))))))))
((prim-instruction name)
@@ -547,7 +547,7 @@
(letv f64)
(let$ k (adapt-arity k src out))
(letk kbox ($kargs ('f64) (f64)
- ($continue k src ($primcall 'f64->scm (f64)))))
+ ($continue k src ($primcall 'f64->scm #f
(f64)))))
kbox))
((char->integer
string-length vector-length
@@ -556,14 +556,14 @@
(letv u64)
(let$ k (adapt-arity k src out))
(letk kbox ($kargs ('u64) (u64)
- ($continue k src ($primcall 'u64->scm (u64)))))
+ ($continue k src ($primcall 'u64->scm #f
(u64)))))
kbox))
((bv-s8-ref bv-s16-ref bv-s32-ref bv-s64-ref)
(with-cps cps
(letv s64)
(let$ k (adapt-arity k src out))
(letk kbox ($kargs ('s64) (s64)
- ($continue k src ($primcall 's64->scm (s64)))))
+ ($continue k src ($primcall 's64->scm #f
(s64)))))
kbox))
(else
(adapt-arity cps k src out))))
@@ -573,7 +573,7 @@
(let$ body (have-arg unboxed))
(letk kunboxed ($kargs ('unboxed) (unboxed) ,body))
(build-term
- ($continue kunboxed src ($primcall unbox-op (arg))))))
+ ($continue kunboxed src ($primcall unbox-op #f (arg))))))
(define (unbox-args cps args have-args)
(case instruction
((bv-f32-ref bv-f64-ref
@@ -671,7 +671,7 @@
(with-cps cps
(build-term
($continue k src
- ($primcall instruction args))))))))
+ ($primcall instruction #f args))))))))
(with-cps cps
(letv prim)
(letk kprim ($kargs ('prim) (prim)
@@ -685,7 +685,7 @@
(lambda (cps args)
(with-cps cps
(build-term
- ($continue k src ($primcall name args)))))))))
+ ($continue k src ($primcall name #f args)))))))))
;; Prompts with inline handlers.
(($ <prompt> src escape-only? tag body
@@ -718,7 +718,7 @@
(with-cps cps
(letk kbody ($kargs () ()
($continue krest (tree-il-src body)
- ($primcall 'call-thunk/no-inline
+ ($primcall 'call-thunk/no-inline #f
(thunk)))))
(build-term ($continue kbody (tree-il-src body)
($prompt #f tag khargs))))))))
@@ -729,11 +729,11 @@
(letk khbody ($kargs hnames bound-vars ,hbody))
(letk khargs ($kreceive hreq hrest khbody))
(letk kprim ($kargs ('prim) (prim)
- ($continue k src ($primcall 'apply (prim vals)))))
+ ($continue k src ($primcall 'apply #f (prim
vals)))))
(letk kret ($kargs () ()
($continue kprim src ($prim 'values))))
(letk kpop ($kargs ('rest) (vals)
- ($continue kret src ($primcall 'unwind ()))))
+ ($continue kret src ($primcall 'unwind #f ()))))
;; FIXME: Attach hsrc to $kreceive.
(letk krest ($kreceive '() 'rest kpop))
($ (convert-body khargs krest)))))))
@@ -743,7 +743,7 @@
(lambda (cps args*)
(with-cps cps
(build-term
- ($continue k src ($primcall 'abort-to-prompt args*)))))))
+ ($continue k src ($primcall 'abort-to-prompt #f args*)))))))
(($ <abort> src tag args tail)
(convert-args cps
@@ -752,7 +752,7 @@
(list tail))
(lambda (cps args*)
(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)
(define (convert-test cps test kt kf)
@@ -764,13 +764,13 @@
(with-cps cps
(letk kt* ($kargs () ()
($continue kf src
- ($branch kt ($primcall name args)))))
+ ($branch kt ($primcall name #f args)))))
(build-term
($continue kf src
- ($branch kt* ($primcall 'heap-object? args)))))
+ ($branch kt* ($primcall 'heap-object? #f args)))))
(with-cps cps
(build-term ($continue kf src
- ($branch kt ($primcall name args)))))))))
+ ($branch kt ($primcall name #f args)))))))))
(($ <conditional> src test consequent alternate)
(with-cps cps
(let$ t (convert-test consequent kt kf))
@@ -785,7 +785,7 @@
(lambda (cps test)
(with-cps cps
(build-term ($continue kt src
- ($branch kf ($primcall 'false? (test)))))))))))
+ ($branch kf ($primcall 'false? #f
(test)))))))))))
(with-cps cps
(let$ t (convert consequent k subst))
(let$ f (convert alternate k subst))
@@ -801,7 +801,7 @@
(with-cps cps
(let$ k (adapt-arity k src 0))
(build-term
- ($continue k src ($primcall 'box-set! (box exp))))))))))
+ ($continue k src ($primcall 'box-set! #f (box exp))))))))))
(($ <seq> src head tail)
(with-cps cps
- [Guile-commits] 15/16: error, scm-error primcalls expand to `throw', (continued)
- [Guile-commits] 15/16: error, scm-error primcalls expand to `throw', Andy Wingo, 2017/11/05
- [Guile-commits] 07/16: builtin-ref takes immediate parameter, Andy Wingo, 2017/11/05
- [Guile-commits] 09/16: reify-primitives reifies constants for out-of-range imm params, Andy Wingo, 2017/11/05
- [Guile-commits] 03/16: load-f64, etc take immediate parameters, Andy Wingo, 2017/11/05
- [Guile-commits] 04/16: free-ref, free-set take immediate parameters, Andy Wingo, 2017/11/05
- [Guile-commits] 11/16: (system base types) uses target's idea of max size_t, Andy Wingo, 2017/11/05
- [Guile-commits] 16/16: Add new "throw" VM ops, Andy Wingo, 2017/11/05
- [Guile-commits] 14/16: Add lsh, rsh instructions, Andy Wingo, 2017/11/05
- [Guile-commits] 06/16: Immediate parameter for struct-ref et al, Andy Wingo, 2017/11/05
- [Guile-commits] 08/16: Remaining /immediate instructions take primcall imm param, Andy Wingo, 2017/11/05
- [Guile-commits] 01/16: $primcall has a "param" member,
Andy Wingo <=