mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Add new $calli expression type.

Browse source 
* module/language/cps.scm ($calli): New expression type which calls a
function entry as originally captured via $code.  Adapt all callers.
This commit is contained in:
Andy Wingo 2021-05-25 13:48:23 +02:00
parent f8b1607602
commit dc4fe9741f
22 changed files with 102 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

12
module/language/cps.scm
View file

@ -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)

15
module/language/cps/closure-conversion.scm
View file

@ -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)

4
module/language/cps/compile-bytecode.scm
View file

@ -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)

12
module/language/cps/contification.scm
View file

@ -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.

3
module/language/cps/cse.scm
View file

@ -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)

2
module/language/cps/dce.scm
View file

@ -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)

4
module/language/cps/devirtualize-integers.scm
View file

@ -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)

3
module/language/cps/dump.scm
View file

@ -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)

2
module/language/cps/effects-analysis.scm
View file

@ -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))))

3
module/language/cps/guile-vm/lower-primcalls.scm
View file

@ -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)

2
module/language/cps/guile-vm/reify-primitives.scm
View file

@ -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

4
module/language/cps/peel-loops.scm
View file

@ -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)

6
module/language/cps/renumber.scm
View file

@ -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)

4
module/language/cps/rotate-loops.scm
View file

@ -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)

2
module/language/cps/self-references.scm
View file

@ -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)

4
module/language/cps/simplify.scm
View file

@ -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)

18
module/language/cps/slot-allocation.scm
View file

@ -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)

4
module/language/cps/specialize-numbers.scm
View file

@ -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

2
module/language/cps/split-rec.scm
View file

@ -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)

2
module/language/cps/types.scm
View file

@ -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)))

2
module/language/cps/utils.scm
View file

@ -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)

12
module/language/cps/verify.scm
View file

@ -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))))