summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2017-11-05 14:47:18 +0100
committerAndy Wingo <wingo@pobox.com>2017-11-05 15:00:16 +0100
commitf96a670332b224326b89ce135a0edfb77a70c46e (patch)
tree9db32959b5f53e2d245bce5735214d462caffa3c /module
parentcf486700b78a72f1bcab5b450394a63cf3ec7bff (diff)
downloadguile-f96a670332b224326b89ce135a0edfb77a70c46e.tar.gz
Add new "throw" VM ops
* libguile/throw.h (scm_ithrow, scm_throw): Mark as SCM_NORETURN. * libguile/throw.c (scm_throw, scm_ithrow): Adapt to not return. * libguile/vm-engine.c (throw, throw/value, throw/value+data): New instructions. * libguile/vm.c (vm_throw, vm_throw_with_value) (vm_throw_with_value_and_data): New helpers. * module/language/cps/compile-bytecode.scm (compile-function): Add cases for new instructions. * module/language/cps/prune-bailouts.scm (prune-bailouts): More simple, now that there are no $kreceives in play. * module/language/cps/reify-primitives.scm (reify-clause): Update reification of no-clause functions to use new throw op. * module/language/tree-il/compile-cps.scm (convert): Convert invocations of the variable-arity 'throw primitive from Tree-IL to the new fixed-arity CPS instructions. * module/system/vm/assembler.scm (emit-throw/value*) (emit-throw/value+data*, emit-throw): Export new instructions. * module/system/vm/disassembler.scm (code-annotation): Add annotation.
Diffstat (limited to 'module')
-rw-r--r--module/language/cps/compile-bytecode.scm8
-rw-r--r--module/language/cps/prune-bailouts.scm34
-rw-r--r--module/language/cps/reify-primitives.scm14
-rw-r--r--module/language/tree-il/compile-cps.scm38
-rw-r--r--module/system/vm/assembler.scm10
-rw-r--r--module/system/vm/disassembler.scm3
6 files changed, 74 insertions, 33 deletions
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 2b5d7591a..1284e6541 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -375,7 +375,13 @@
(($ $primcall 'atomic-box-set! #f (box val))
(emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val))))
(($ $primcall 'handle-interrupts #f ())
- (emit-handle-interrupts asm))))
+ (emit-handle-interrupts asm))
+ (($ $primcall 'throw #f (key args))
+ (emit-throw asm (from-sp (slot key)) (from-sp (slot args))))
+ (($ $primcall 'throw/value param (val))
+ (emit-throw/value asm (from-sp (slot val)) param))
+ (($ $primcall 'throw/value+data param (val))
+ (emit-throw/value+data asm (from-sp (slot val)) param))))
(define (compile-values label exp syms)
(match exp
diff --git a/module/language/cps/prune-bailouts.scm b/module/language/cps/prune-bailouts.scm
index 412087231..dece1a0de 100644
--- a/module/language/cps/prune-bailouts.scm
+++ b/module/language/cps/prune-bailouts.scm
@@ -49,22 +49,6 @@ unreferenced terms. In that case TAIL-LABEL is either absent or #f."
conts
empty-intmap))
-(define (prune-bailout out tails k src exp)
- (match (intmap-ref out k)
- (($ $ktail)
- (with-cps out #f))
- (_
- (match (intmap-ref tails k (lambda (_) #f))
- (#f
- (with-cps out #f))
- (ktail
- (with-cps out
- (letv prim rest)
- (letk kresult ($kargs ('rest) (rest)
- ($continue ktail src ($values ()))))
- (letk kreceive ($kreceive '() 'rest kresult))
- (build-term ($continue kreceive src ,exp))))))))
-
(define (prune-bailouts conts)
(let ((tails (compute-tails conts)))
(with-fresh-name-state conts
@@ -73,13 +57,17 @@ unreferenced terms. In that case TAIL-LABEL is either absent or #f."
(lambda (label cont out)
(match cont
(($ $kargs names vars
- ($ $continue k src (and exp ($ $primcall 'throw))))
- (call-with-values (lambda () (prune-bailout out tails k src exp))
- (lambda (out term)
- (if term
- (let ((cont (build-cont ($kargs names vars ,term))))
- (intmap-replace! out label cont))
- out))))
+ ($ $continue k src
+ (and exp ($ $primcall
+ (or 'throw 'throw/value 'throw/value+data)))))
+ (match (intmap-ref tails k (lambda (_) #f))
+ (#f out)
+ (ktail
+ (with-cps out
+ (letk knil ($kargs () ()
+ ($continue ktail src ($values ()))))
+ (setk label ($kargs names vars
+ ($continue knil src ,exp)))))))
(_ out)))
conts
conts)))))
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 47982ea87..0823584d4 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -100,17 +100,13 @@
(define (reify-clause cps ktail)
(with-cps cps
- (letv throw)
- (let$ throw-body
+ (letk knil ($kargs () () ($continue ktail #f ($values ()))))
+ (let$ body
(with-cps-constants ((wna 'wrong-number-of-args)
- (false #f)
- (str "Wrong number of arguments")
- (eol '()))
+ (args '(#f "Wrong number of arguments" () #f)))
(build-term
- ($continue ktail #f
- ($call throw (wna false str eol false))))))
- (letk kthrow ($kargs ('throw) (throw) ,throw-body))
- (let$ body (primitive-ref 'throw kthrow #f))
+ ($continue knil #f
+ ($primcall 'throw #f (wna args))))))
(letk kbody ($kargs () () ,body))
(letk kclause ($kclause ('() '() #f '() #f) kbody #f))
kclause))
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 8d906ffc2..9ff497a2b 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -533,6 +533,41 @@
($primcall 'cons #f (head tail))))))))
(letk ktail ($kargs ('tail) (tail) ,body))
($ (lp args ktail)))))))))))
+ ((eq? name 'throw)
+ (let ()
+ (define (fallback)
+ (match args
+ ((key . args)
+ (convert-args cps (list key (make-primcall src 'list args))
+ (lambda (cps args)
+ (with-cps cps
+ (let$ k (adapt-arity k src 0))
+ (build-term
+ ($continue k src ($primcall 'throw #f args)))))))))
+ (define (specialize op param . args)
+ (convert-args cps args
+ (lambda (cps args)
+ (with-cps cps
+ (let$ k (adapt-arity k src 0))
+ (build-term
+ ($continue k src ($primcall op param args)))))))
+ (match args
+ ((($ <const> _ key) ($ <const> _ subr) ($ <const> _ msg) args data)
+ ;; Specialize `throw' invocations corresponding to common
+ ;; "error" invocations.
+ (let ()
+ (match (vector args data)
+ (#(($ <primcall> _ 'list (x)) ($ <primcall> _ 'list (x)))
+ (specialize 'throw/value+data `#(,key ,subr ,msg) x))
+ (#(($ <primcall> _ 'cons (x ($ <const> _ ())))
+ ($ <primcall> _ 'cons (x ($ <const> _ ()))))
+ (specialize 'throw/value+data `#(,key ,subr ,msg) x))
+ (#(($ <primcall> _ 'list (x)) ($ <const> _ #f))
+ (specialize 'throw/value `#(,key ,subr ,msg) x))
+ (#(($ <primcall> _ 'cons (x ($ <const> _ ()))) ($ <const> _ #f))
+ (specialize 'throw/value `#(,key ,subr ,msg) x))
+ (_ (fallback)))))
+ (_ (fallback)))))
((prim-instruction name)
=> (lambda (instruction)
(define (box+adapt-arity cps k src out)
@@ -1131,6 +1166,9 @@ integer."
(($ <primcall> src 'logand (($ <primcall> _ 'lognot (y)) x))
(make-primcall src 'logsub (list x y)))
+ (($ <primcall> src 'throw ())
+ (make-call src (make-primitive-ref src 'throw) '()))
+
(($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 67ef7676a..5fccd866d 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -99,6 +99,10 @@
emit-untag-fixnum
+ emit-throw
+ (emit-throw/value* . emit-throw/value)
+ (emit-throw/value+data* . emit-throw/value+data)
+
emit-pair?
emit-struct?
emit-symbol?
@@ -975,6 +979,12 @@ later by the linker."
(emit-fmov* asm dst (1+ proc))
(emit-reset-frame asm nlocals))))
+(define (emit-throw/value* asm val param)
+ (emit-throw/value asm val (intern-non-immediate asm param)))
+
+(define (emit-throw/value+data* asm val param)
+ (emit-throw/value+data asm val (intern-non-immediate asm param)))
+
(define (emit-text asm instructions)
"Assemble @var{instructions} using the assembler @var{asm}.
@var{instructions} is a sequence of instructions, expressed as a list of
diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index 5183b2d2e..89acf6090 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -260,6 +260,8 @@ address of that offset."
(when (program? val)
(push-addr! (program-code val) val))
(list "~@Y" val)))
+ (((or 'throw/value 'throw/value+data) dst target)
+ (list "~@Y" (reference-scm target)))
(('builtin-ref dst idx)
(list "~A" (builtin-index->name idx)))
(((or 'static-ref 'static-set!) _ target)
@@ -511,6 +513,7 @@ address of that offset."
(define (instruction-has-fallthrough? code pos)
(define non-fallthrough-set
(static-opcode-set halt
+ throw throw/value throw/value+data
tail-call tail-call-label tail-call/shuffle
return-values
subr-call foreign-call continuation-call