diff options
author | Andy Wingo <wingo@pobox.com> | 2017-11-05 14:47:18 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2017-11-05 15:00:16 +0100 |
commit | f96a670332b224326b89ce135a0edfb77a70c46e (patch) | |
tree | 9db32959b5f53e2d245bce5735214d462caffa3c /module | |
parent | cf486700b78a72f1bcab5b450394a63cf3ec7bff (diff) | |
download | guile-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.scm | 8 | ||||
-rw-r--r-- | module/language/cps/prune-bailouts.scm | 34 | ||||
-rw-r--r-- | module/language/cps/reify-primitives.scm | 14 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 38 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 10 | ||||
-rw-r--r-- | module/system/vm/disassembler.scm | 3 |
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 |