diff options
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 2 | ||||
-rw-r--r-- | module/language/cps/contification.scm | 9 | ||||
-rw-r--r-- | module/language/cps/reify-primitives.scm | 20 | ||||
-rw-r--r-- | module/language/cps/utils.scm | 8 | ||||
-rw-r--r-- | module/language/cps/verify.scm | 14 |
5 files changed, 23 insertions, 30 deletions
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 58d908b1c..53a252444 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -135,6 +135,8 @@ (emit-fmov asm dst src) (lp moves reset-frame?))))))) (match cont + (($ $kargs) + (shuffle-results)) (($ $kreceive ($ $arity req () rest () #f) kargs) (let ((nreq (length req)) (rest-var (and rest diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm index 8f07f7910..7a05fa241 100644 --- a/module/language/cps/contification.scm +++ b/module/language/cps/contification.scm @@ -469,8 +469,9 @@ function set." (if (eq? k k*) (with-cps cps (build-term ($continue k src ,exp))) ;; We are contifying this return. It must be a call or a - ;; $values expression. k* will be either a $ktail or a - ;; $kreceive continuation. + ;; $values expression. k* will be a $ktail or a $kreceive + ;; continuation, or a $kargs continuation for a + ;; known-number-of-values return. (match (intmap-ref conts k*) (($ $kreceive ($ $arity req () rest () #f) kargs) (match exp @@ -480,6 +481,10 @@ function set." ;; have to rewrite as a call to the 'values primitive. (($ $values vals) (inline-return cps k* kargs src (length req) rest vals)))) + (($ $kargs) + (match exp + ((or ($ $callk) ($ $values)) + (with-cps cps (build-term ($continue k* src ,exp)))))) (($ $ktail) (with-cps cps (build-term ($continue k* src ,exp)))))))) (define (contify-unchecked-function cps kfun) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index d0441ff5f..5f4241565 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -102,16 +102,6 @@ (letk kclause ($kclause ('() '() #f '() #f) kbody #f)) kclause)) -;; A $kreceive continuation should have only one predecessor. -(define (uniquify-receive cps k) - (match (intmap-ref cps k) - (($ $kreceive ($ $arity req () rest () #f) kargs) - (with-cps cps - (letk k ($kreceive req rest kargs)) - k)) - (_ - (with-cps cps k)))) - (define (wrap-unary cps k src wrap unwrap op param a) (with-cps cps (letv a* res*) @@ -619,16 +609,6 @@ ((imm-s64-< (s12? a) b) load-s64 (s64-< a b)) ((eq-constant? (imm16? b) a) load-const (eq? a b)) (_ cps)))) - (($ $kargs names vars ($ $continue k src ($ $call proc args))) - (with-cps cps - (let$ k (uniquify-receive k)) - (setk label ($kargs names vars - ($continue k src ($call proc args)))))) - (($ $kargs names vars ($ $continue k src ($ $callk k* proc args))) - (with-cps cps - (let$ k (uniquify-receive k)) - (setk label ($kargs names vars - ($continue k src ($callk k* proc args)))))) (_ cps))) (with-fresh-name-state cps diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm index 2b0c91c4b..584fb3ba5 100644 --- a/module/language/cps/utils.scm +++ b/module/language/cps/utils.scm @@ -389,6 +389,8 @@ by a label, respectively." (($ $values (arg)) (intmap-add representations var (intmap-ref representations arg))) + (($ $callk) + (intmap-add representations var 'scm)) (($ $primcall (or 'scm->f64 'load-f64 's64->f64 'f32-ref 'f64-ref 'fadd 'fsub 'fmul 'fdiv 'fsqrt 'fabs @@ -425,7 +427,11 @@ by a label, respectively." (fold (lambda (arg var representations) (intmap-add representations var (intmap-ref representations arg))) - representations args vars)))))) + representations args vars)) + (($ $callk) + (fold1 (lambda (var representations) + (intmap-add representations var 'scm)) + vars representations)))))) (($ $kargs _ _ (or ($ $branch) ($ $switch) ($ $prompt) ($ $throw))) representations) (($ $kfun src meta self tail entry) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm index 88dcbc0c0..58317ae63 100644 --- a/module/language/cps/verify.scm +++ b/module/language/cps/verify.scm @@ -1,5 +1,5 @@ ;;; Diagnostic checker for CPS -;;; Copyright (C) 2014-2020 Free Software Foundation, Inc. +;;; Copyright (C) 2014-2021 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 License as @@ -271,10 +271,6 @@ definitions that are available at LABEL." (unless (= (length vars) n) (error "expected n-ary continuation" n cont))) (_ (error "expected $kargs continuation" cont)))) - (define (assert-kreceive-or-ktail) - (match cont - ((or ($ $kreceive) ($ $ktail)) #t) - (_ (error "expected $kreceive or $ktail continuation" cont)))) (match exp ((or ($ $const) ($ $prim) ($ $const-fun) ($ $code) ($ $fun)) (assert-unary)) @@ -291,9 +287,13 @@ definitions that are available at LABEL." (($ $ktail) #t) (_ (assert-n-ary (length args))))) (($ $call proc args) - (assert-kreceive-or-ktail)) + (match cont + ((or ($ $kreceive) ($ $ktail)) #t) + (_ (error "expected $kreceive or $ktail continuation" cont)))) (($ $callk k proc args) - (assert-kreceive-or-ktail)) + (match cont + ((or ($ $kargs) ($ $kreceive) ($ $ktail)) #t) + (_ (error "expected $kargs, $kreceive or $ktail continuation" cont)))) (($ $primcall name param args) (match cont (($ $kargs) #t) |