diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 0baa30992..b4daf6999 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -125,7 +125,9 @@ (for-each (match-lambda ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) (lookup-parallel-moves label allocation)) - (emit-return-values asm (1+ (length args)))))) + (emit-return-values asm (1+ (length args)))) + (($ $primcall (or 'throw 'throw/value 'throw/value+data)) + (compile-effect label exp #f)))) (define (compile-value label exp dst) (match exp diff --git a/module/language/cps/prune-bailouts.scm b/module/language/cps/prune-bailouts.scm index dece1a0de..5d2f7c3b5 100644 --- a/module/language/cps/prune-bailouts.scm +++ b/module/language/cps/prune-bailouts.scm @@ -51,23 +51,20 @@ unreferenced terms. In that case TAIL-LABEL is either absent or #f." (define (prune-bailouts conts) (let ((tails (compute-tails conts))) - (with-fresh-name-state conts - (persistent-intmap - (intmap-fold - (lambda (label cont out) - (match cont - (($ $kargs names vars - ($ $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))))) + (persistent-intmap + (intmap-fold + (lambda (label cont out) + (match cont + (($ $kargs names vars + ($ $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 + (setk label ($kargs names vars + ($continue ktail src ,exp))))))) + (_ out))) + conts + conts)))) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index 71e1ba92e..e5b92e3d9 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -100,12 +100,11 @@ (define (reify-clause cps ktail) (with-cps cps - (letk knil ($kargs () () ($continue ktail #f ($values ())))) (let$ body (with-cps-constants ((wna 'wrong-number-of-args) (args '(#f "Wrong number of arguments" () #f))) (build-term - ($continue knil #f + ($continue ktail #f ($primcall 'throw #f (wna args)))))) (letk kbody ($kargs () () ,body)) (letk kclause ($kclause ('() '() #f '() #f) kbody #f)) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm index e55cf8377..67a83046f 100644 --- a/module/language/cps/verify.scm +++ b/module/language/cps/verify.scm @@ -255,7 +255,8 @@ definitions that are available at LABEL." (when (false-if-exception (prim-arity name)) (error "primitive should continue to $kargs, not $kreceive" name))) (($ $ktail) - (error "primitive should continue to $kargs, not $ktail" name)))) + (unless (memv name '(throw throw/value throw/value+data)) + (error "primitive should continue to $kargs, not $ktail" name))))) (($ $prompt escape? tag handler) (assert-nullary) (match (intmap-ref conts handler)