diff --git a/module/language/cps.scm b/module/language/cps.scm index f83b62533..42ebb0fe6 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -131,7 +131,7 @@ ;; Expressions. $const $prim $fun $rec $const-fun $code - $call $callk $primcall $values + $call $callk $calli $primcall $values ;; Building macros. build-cont build-term build-exp @@ -193,6 +193,7 @@ (define-cps-type $code label) ; First-order. (define-cps-type $call proc args) (define-cps-type $callk k proc args) ; First-order. +(define-cps-type $calli args callee) ; First-order. (define-cps-type $primcall name param args) (define-cps-type $values args) @@ -247,7 +248,7 @@ (define-syntax build-exp (syntax-rules (unquote $const $prim $fun $rec $const-fun $code - $call $callk $primcall $values) + $call $callk $calli $primcall $values) ((_ (unquote exp)) exp) ((_ ($const val)) (make-$const val)) ((_ ($prim name)) (make-$prim name)) @@ -261,6 +262,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)) + ((_ ($calli (unquote args) callee)) (make-$calli args callee)) + ((_ ($calli (arg ...) callee)) (make-$calli (list arg ...) callee)) + ((_ ($calli args callee)) (make-$calli args callee)) ((_ ($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)) @@ -328,6 +332,8 @@ (build-exp ($call proc arg))) (('callk k proc arg ...) (build-exp ($callk k proc arg))) + (('calli arg ... callee) + (build-exp ($calli arg callee))) (('primcall name param arg ...) (build-exp ($primcall name param arg))) (('values arg ...) @@ -383,6 +389,8 @@ `(call ,proc ,@args)) (($ $callk k proc args) `(callk ,k ,proc ,@args)) + (($ $calli args callee) + `(callk ,@args ,callee)) (($ $primcall name param args) `(primcall ,name ,param ,@args)) (($ $values args) diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm index cc337467f..72f0a12ca 100644 --- a/module/language/cps/closure-conversion.scm +++ b/module/language/cps/closure-conversion.scm @@ -72,6 +72,8 @@ (if proc (add-use proc uses) uses))) + (($ $calli args callee) + (add-uses args (add-use callee uses))) (($ $primcall name param args) (add-uses args uses)))) (($ $kargs _ _ ($ $branch kf kt src op param args)) @@ -205,6 +207,8 @@ shared closures to use the appropriate 'self' variable, if possible." ((closure . label) ($callk label closure ,args))))) (($ $callk label proc args) ($callk label (and proc (subst proc)) ,(map subst args))) + (($ $calli args callee) + ($calli ,(map subst args) (subst callee))) (($ $primcall name param args) ($primcall name param ,(map subst args))) (($ $values args) @@ -346,6 +350,8 @@ references." (if proc (add-use proc uses) uses))) + (($ $calli args callee) + (add-uses args (add-use callee uses))) (($ $primcall name param args) (add-uses args uses)))) (($ $branch kf kt src op param args) @@ -786,6 +792,15 @@ bound to @var{closure}, 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 ($ $calli args callee)) + (convert-args cps args + (lambda (cps args) + (convert-arg cps callee + (lambda (cps callee) + (with-cps cps + (build-term + ($continue k src ($calli args callee))))))))) + (($ $continue k src ($ $primcall name param args)) (convert-args cps args (lambda (cps args) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 494bb5a0c..d6d1737b3 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013-2021 Free Software Foundation, Inc. +;; Copyright (C) 2013-2021, 2023 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 @@ -578,6 +578,8 @@ (compile-call #f proc args)) (($ $callk kfun proc args) (compile-call kfun proc args)) + (($ $calli args callee) + (error "unreachable")) (_ (match cont (($ $kargs names vars) diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm index 5167e4d3a..285cf746a 100644 --- a/module/language/cps/contification.scm +++ b/module/language/cps/contification.scm @@ -206,8 +206,12 @@ $call, and are always called with a compatible arity." (match cont (($ $kargs _ _ ($ $continue _ _ exp)) (match exp - ((or ($ $const) ($ $prim) ($ $const-fun) ($ $code) ($ $fun) ($ $rec)) + ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) functions) + (($ $const-fun kfun) + (intmap-remove functions kfun)) + (($ $code kfun) + (intmap-remove functions kfun)) (($ $values args) (exclude-vars functions args)) (($ $call proc args) @@ -226,6 +230,10 @@ $call, and are always called with a compatible arity." (restrict-arity functions proc (length args)))) (($ $callk k proc args) (exclude-vars functions (if proc (cons proc args) args))) + (($ $calli args callee) + ;; While callee is a var and not a label, it is a var that + ;; holds a code label, not a function value. + (exclude-vars functions args)) (($ $primcall name param args) (exclude-vars functions args)))) (($ $kargs _ _ ($ $branch kf kt src op param args)) @@ -466,7 +474,7 @@ function set." (match (intmap-ref conts k*) (($ $kreceive ($ $arity req () rest () #f) kargs) (match exp - ((or ($ $call) ($ $callk)) + ((or ($ $call) ($ $callk) ($ $calli)) (with-cps cps (build-term ($continue k* src ,exp)))) ;; We need to punch through the $kreceive; otherwise we'd ;; have to rewrite as a call to the 'values primitive. diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 3382b9915..bf11a6092 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -473,6 +473,7 @@ for a label, it isn't known to be constant at that label." (($ $code label) (cons 'code label)) (($ $call proc args) #f) (($ $callk k proc args) #f) + (($ $calli args callee) #f) (($ $primcall name param args) (cons* name param args)) (($ $values args) #f))) (define (compute-term-key term) @@ -562,6 +563,8 @@ for a label, it isn't known to be constant at that label." ($call (subst-var proc) ,(map subst-var args))) (($ $callk k proc args) ($callk k (and proc (subst-var proc)) ,(map subst-var args))) + (($ $calli args callee) + ($calli ,(map subst-var args) (subst-var callee))) (($ $primcall name param args) ($primcall name param ,(map subst-var args))) (($ $values args) diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm index 6c55245a5..634419ec3 100644 --- a/module/language/cps/dce.scm +++ b/module/language/cps/dce.scm @@ -160,6 +160,8 @@ sites." (adjoin-vars args (if proc (adjoin-var proc live-vars) live-vars)))) + (($ $calli args callee) + (values live-labels (adjoin-var callee (adjoin-vars args live-vars)))) (($ $primcall name param args) (values live-labels (adjoin-vars args live-vars))) (($ $values args) diff --git a/module/language/cps/devirtualize-integers.scm b/module/language/cps/devirtualize-integers.scm index 471ca81f9..6fa38a3db 100644 --- a/module/language/cps/devirtualize-integers.scm +++ b/module/language/cps/devirtualize-integers.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2017-2020 Free Software Foundation, Inc. +;; Copyright (C) 2017-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 @@ -71,6 +71,8 @@ (add-uses (add-use use-counts proc) args)) (($ $callk kfun proc args) (add-uses (if proc (add-use use-counts proc) use-counts) args)) + (($ $calli args callee) + (add-use (add-uses use-counts args) callee)) (($ $primcall name param args) (add-uses use-counts args)))) (($ $branch kf kt src op param args) diff --git a/module/language/cps/dump.scm b/module/language/cps/dump.scm index 0950c2f0b..cf2174ca9 100644 --- a/module/language/cps/dump.scm +++ b/module/language/cps/dump.scm @@ -163,6 +163,9 @@ (arg-list (cons (if proc (format-var proc) "_") (map format-var args))))) + (($ $calli args callee) + (format #f "calli ~a(~a)" + (format-var callee) (arg-list (map format-var args)))) (($ $primcall name param args) (format-primcall name param args)) (($ $values args) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index e697d2e29..c82dc9d0e 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -738,7 +738,7 @@ the LABELS that are clobbered by the effects of LABEL." &no-effects) ((or ($ $fun) ($ $rec)) (&allocate &unknown-memory-kinds)) - ((or ($ $call) ($ $callk)) + ((or ($ $call) ($ $callk) ($ $calli)) &all-effects) (($ $primcall name param args) (primitive-effects param name args)))) diff --git a/module/language/cps/guile-vm/lower-primcalls.scm b/module/language/cps/guile-vm/lower-primcalls.scm index e0cf19e46..5a46c87c3 100644 --- a/module/language/cps/guile-vm/lower-primcalls.scm +++ b/module/language/cps/guile-vm/lower-primcalls.scm @@ -603,6 +603,9 @@ (intmap-fold (lambda (label cont cps) (match cont + (($ $kargs names vars + ($ $continue k src ($ $calli))) + (error "$calli unsupported by guile-vm backend")) (($ $kargs names vars ($ $continue k src ($ $primcall op param args))) (match (hashq-ref *primcall-lowerers* op) diff --git a/module/language/cps/guile-vm/reify-primitives.scm b/module/language/cps/guile-vm/reify-primitives.scm index a78284fab..ea5ee92a6 100644 --- a/module/language/cps/guile-vm/reify-primitives.scm +++ b/module/language/cps/guile-vm/reify-primitives.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013-2021, 2023 Free Software Foundation, Inc. +;; Copyright (C) 2013-2021,2023 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/peel-loops.scm b/module/language/cps/peel-loops.scm index c28654f62..088fee085 100644 --- a/module/language/cps/peel-loops.scm +++ b/module/language/cps/peel-loops.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013-2020 Free Software Foundation, Inc. +;; Copyright (C) 2013-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 @@ -149,6 +149,8 @@ ($call (rename-var proc) ,(map rename-var args))) (($ $callk k proc args) ($callk k (and proc (rename-var proc)) ,(map rename-var args))) + (($ $calli args callee) + ($calli ,(map rename-var args) (rename-var callee))) (($ $primcall name param args) ($primcall name param ,(map rename-var args))))) (define (rename-term term) diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm index c170f5c82..d5a75c1c7 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-2020 Free Software Foundation, Inc. +;; Copyright (C) 2013-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 @@ -152,8 +152,6 @@ (($ $kargs names syms ($ $continue k src ($ $code kfun))) (maybe-visit-fun kfun labels vars)) (($ $kargs names syms ($ $continue k src ($ $callk kfun))) - ;; Well-known functions never have a $const-fun created for them - ;; and are only referenced by their $callk call sites. (maybe-visit-fun kfun labels vars)) (_ (values labels vars)))) (define (visit-fun kfun labels vars) @@ -188,6 +186,8 @@ (($ $callk k proc args) ($callk (rename-label k) (and proc (rename-var proc)) ,(map rename-var args))) + (($ $calli args callee) + ($calli ,(map rename-var args) (rename-var callee))) (($ $primcall name param args) ($primcall name param ,(map rename-var args))))) (define (rename-arity arity) diff --git a/module/language/cps/rotate-loops.scm b/module/language/cps/rotate-loops.scm index caa1da3bd..39fa95f04 100644 --- a/module/language/cps/rotate-loops.scm +++ b/module/language/cps/rotate-loops.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013-2020 Free Software Foundation, Inc. +;; Copyright (C) 2013-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 @@ -117,6 +117,8 @@ corresponding var from REPLACEMENTS; otherwise return VAR." ($call (rename proc) ,(rename* args))) (($ $callk k proc args) ($callk k (and proc (rename proc)) ,(rename* args))) + (($ $calli args callee) + ($calli ,(rename* args) (rename callee))) (($ $primcall name param args) ($primcall name param ,(rename* args)))))) (($ $branch kf kt src op param args) diff --git a/module/language/cps/self-references.scm b/module/language/cps/self-references.scm index 990ce65ec..8e2e67a1b 100644 --- a/module/language/cps/self-references.scm +++ b/module/language/cps/self-references.scm @@ -43,6 +43,8 @@ ($call (subst proc) ,(map subst args))) (($ $callk k proc args) ($callk k (and proc (subst proc)) ,(map subst args))) + (($ $calli args callee) + ($calli ,(map subst args) (subst callee))) (($ $primcall name param args) ($primcall name param ,(map subst args))) (($ $values args) diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm index ef7b86f79..3fd7df505 100644 --- a/module/language/cps/simplify.scm +++ b/module/language/cps/simplify.scm @@ -74,6 +74,8 @@ (ref* (cons proc args))) (($ $callk k proc args) (ref* (if proc (cons proc args) args))) + (($ $calli args callee) + (ref* (cons callee args))) (($ $primcall name param args) (ref* args)) (($ $values args) @@ -241,6 +243,8 @@ ($call (subst proc) ,(map subst args))) (($ $callk k proc args) ($callk k (and proc (subst proc)) ,(map subst args))) + (($ $calli args callee) + ($calli ,(map subst args) (subst callee))) (($ $primcall name param args) ($primcall name param ,(map subst args))) (($ $values args) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index b08150f8d..8c0c8d44b 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -1,6 +1,6 @@ ;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013-2021 Free Software Foundation, Inc. +;; Copyright (C) 2013-2021,2023 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 @@ -73,8 +73,8 @@ (call-allocs allocation-call-allocs) ;; A map of LABEL to /parallel moves/. Parallel moves shuffle locals - ;; into position for a $call, $callk, or $values, or shuffle returned - ;; values back into place at a return continuation. + ;; into position for a $call, $callk, $calli, or $values, or shuffle + ;; returned values back into place for a $kreceive. ;; ;; A set of moves is expressed as an ordered list of (SRC . DST) ;; moves, where SRC and DST are slots. This may involve a temporary @@ -237,6 +237,9 @@ is an active call." (let ((args (list->intset args))) (intset-subtract (if proc (intset-add args proc) args) (intmap-ref live-out label)))) + (($ $kargs _ _ ($ $continue _ _ ($ $calli args callee))) + (intset-subtract (list->intset (cons callee args)) + (intmap-ref live-out label))) (($ $kargs _ _ ($ $continue k _($ $values args))) (match (intmap-ref cps k) (($ $ktail) (list->intset args)) @@ -492,6 +495,8 @@ are comparable with eqv?. A tmp slot may be used." (add-call-shuffles label k (cons proc args) shuffles)) (($ $callk _ proc args) (add-call-shuffles label k (if proc (cons proc args) args) shuffles)) + (($ $calli args callee) + (add-call-shuffles label k (append args (list callee)) shuffles)) (($ $values args) (add-values-shuffles label k args shuffles)) (_ shuffles))) @@ -538,6 +543,8 @@ are comparable with eqv?. A tmp slot may be used." (($ $continue _ _ ($ $callk _ proc args)) (let ((nclosure (if proc 1 0))) (call-size label (+ nclosure (length args)) size))) + (($ $continue _ _ ($ $calli args callee)) + (call-size label (1+ (length args)) size)) (($ $continue _ _ ($ $values args)) (shuffle-size (get-shuffles label) size)) (($ $prompt) @@ -624,6 +631,8 @@ are comparable with eqv?. A tmp slot may be used." (allocate-call label (cons proc args) slots)) (($ $callk _ proc args) (allocate-call label (if proc (cons proc args) args) slots)) + (($ $calli args callee) + (allocate-call label (append args (list callee)) slots)) (($ $values args) (allocate-values label k args slots)) (_ slots))) @@ -825,6 +834,9 @@ are comparable with eqv?. A tmp slot may be used." (($ $continue k src ($ $callk _ proc args)) (allocate-call label k (if proc (cons proc args) args) slots call-allocs live)) + (($ $continue k src ($ $calli args callee)) + (allocate-call label k (append args (list callee)) + slots call-allocs live)) (($ $continue k src ($ $values args)) (allocate-values label k args slots call-allocs)) (($ $prompt k kh src escape? tag) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 574962421..72d893b80 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2015-2020 Free Software Foundation, Inc. +;; Copyright (C) 2015-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 @@ -361,6 +361,8 @@ BITS indicating the significant bits needed for a variable. BITS may be (if proc (add-unknown-use out proc) out))) + (($ $calli args callee) + (add-unknown-uses (add-unknown-use out callee) args)) (($ $primcall name param args) (let ((h (significant-bits-handler name))) (if h diff --git a/module/language/cps/split-rec.scm b/module/language/cps/split-rec.scm index 11b4cc611..318f39663 100644 --- a/module/language/cps/split-rec.scm +++ b/module/language/cps/split-rec.scm @@ -94,6 +94,8 @@ references." (if proc (add-use proc uses) uses))) + (($ $calli args callee) + (add-uses args (add-use callee uses))) (($ $primcall name param args) (add-uses args uses)))) (($ $branch kf kt src op param args) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index f0579d175..095b4f7e2 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -2102,7 +2102,7 @@ maximum, where type is a bitset as a fixnum." (adjoin-var out def (var-type-entry in arg)))))))) (_ (propagate1 k types)))) - ((or ($ $call) ($ $callk)) + ((or ($ $call) ($ $callk) ($ $calli)) (propagate1 k types)) (($ $rec names vars funs) (let ((proc-type (make-type-entry &procedure -inf.0 +inf.0))) diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm index 4b20100d4..fd0650a06 100644 --- a/module/language/cps/utils.scm +++ b/module/language/cps/utils.scm @@ -351,6 +351,8 @@ by a label, respectively." (($ $callk _ proc args) (let ((args (vars->intset args))) (return (get-defs k) (if proc (intset-add args proc) args)))) + (($ $calli args callee) + (return (get-defs k) (intset-add (vars->intset args) callee))) (($ $primcall name param args) (return (get-defs k) (vars->intset args))) (($ $values args) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm index 58317ae63..c3896420f 100644 --- a/module/language/cps/verify.scm +++ b/module/language/cps/verify.scm @@ -1,5 +1,5 @@ ;;; Diagnostic checker for CPS -;;; Copyright (C) 2014-2021 Free Software Foundation, Inc. +;;; Copyright (C) 2014-2021,2023 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 @@ -174,6 +174,10 @@ definitions that are available at LABEL." (when proc (check-use proc)) (for-each check-use args) (visit-first-order kfun)) + (($ $calli args callee) + (for-each check-use args) + (check-use callee) + first-order) (($ $primcall name param args) (for-each check-use args) first-order))) @@ -211,6 +215,10 @@ definitions that are available at LABEL." (when proc (check-use proc)) (for-each check-use args) (visit-first-order kfun)) + (($ $calli args callee) + (for-each check-use args) + (check-use callee) + first-order) (($ $primcall name param args) (for-each check-use args) first-order))) @@ -290,7 +298,7 @@ definitions that are available at LABEL." (match cont ((or ($ $kreceive) ($ $ktail)) #t) (_ (error "expected $kreceive or $ktail continuation" cont)))) - (($ $callk k proc args) + ((or ($ $calli) ($ $callk)) (match cont ((or ($ $kargs) ($ $kreceive) ($ $ktail)) #t) (_ (error "expected $kargs, $kreceive or $ktail continuation" cont))))