mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 20:30:28 +02:00
Code Activity

Add VM and compiler support for calls to known procedures

Browse source 
* module/language/cps.scm ($callk): New expression type, for calls to
  known labels.  Part of "low CPS".
* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-bytecode.scm:
* module/language/cps/dce.scm:
* module/language/cps/dfg.scm:
* module/language/cps/effects-analysis.scm:
* module/language/cps/simplify.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/verify.scm: Adapt call sites.

* libguile/vm-engine.c (call-label, tail-call-label): New instructions.
  Renumber the rest; this is an ABI change.

* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION):
* module/system/vm/assembler.scm (*bytecode-minor-version*): Bump.

* doc/ref/compiler.texi (CPS in Guile): Document $callk.
This commit is contained in:
Andy Wingo 2014-02-02 23:19:22 +01:00
parent 0320b1fc3f
commit b3ae2b5068
14 changed files with 257 additions and 147 deletions
Download patch file Download diff file Expand all files Collapse all files

11
module/language/cps.scm
View file

@ -121,7 +121,7 @@
$kif $kreceive $kargs $kentry $ktail $kclause
;; Expressions.
$void $const $prim $fun $call $primcall $values $prompt
$void $const $prim $fun $call $callk $primcall $values $prompt
;; Building macros.
let-gensyms
@ -182,6 +182,7 @@
(define-cps-type $prim name)
(define-cps-type $fun src meta free body)
(define-cps-type $call proc args)
(define-cps-type $callk k proc args)
(define-cps-type $primcall name args)
(define-cps-type $values args)
(define-cps-type $prompt escape? tag handler)
@ -226,7 +227,7 @@
(define-syntax build-cps-exp
(syntax-rules (unquote
$void $const $prim $fun $call $primcall $values $prompt)
$void $const $prim $fun $call $callk $primcall $values $prompt)
((_ (unquote exp)) exp)
((_ ($void)) (make-$void))
((_ ($const val)) (make-$const val))
@ -235,6 +236,8 @@
(make-$fun src meta free (build-cps-cont body)))
((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
((_ ($call proc args)) (make-$call proc args))
((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
((_ ($callk k proc args)) (make-$callk k proc args))
((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
((_ ($primcall name args)) (make-$primcall name args))
((_ ($values (arg ...))) (make-$values (list arg ...)))
@ -336,6 +339,8 @@
($letrec name sym (map parse-cps fun) ,(parse-cps body))))
(('call proc arg ...)
(build-cps-exp ($call proc arg)))
(('callk k proc arg ...)
(build-cps-exp ($callk k proc arg)))
(('primcall name arg ...)
(build-cps-exp ($primcall name arg)))
(('values arg ...)
@ -392,6 +397,8 @@
,(unparse-cps body)))
(($ $call proc args)
`(call ,proc ,@args))
(($ $callk k proc args)
`(callk ,k ,proc ,@args))
(($ $primcall name args)
`(primcall ,name ,@args))
(($ $values args)

8
module/language/cps/arities.scm
View file

@ -136,11 +136,11 @@
,(adapt-exp 1 k src exp))
(($ $fun)
,(adapt-exp 1 k src (fix-arities exp)))
(($ $call)
((or ($ $call) ($ $callk))
;; In general, calls have unknown return arity. For that
;; reason every non-tail call has an implicit adaptor
;; continuation to adapt the return to the target
;; continuation, and we don't need to do any adapting here.
;; reason every non-tail call has a $kreceive continuation to
;; adapt the return to the target continuation, and we don't
;; need to do any adapting here.
($continue k src ,exp))
(($ $primcall 'return (arg))
;; Primcalls to return are in tail position.

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

@ -198,6 +198,14 @@ convert functions to flat closures."
($continue k src ($call proc args)))
'())))))
(($ $continue k src ($ $callk k* proc args))
(convert-free-vars (cons proc args) self bound
(match-lambda
((proc . args)
(values (build-cps-term
($continue k src ($callk k* proc args)))
'())))))
(($ $continue k src ($ $primcall name args))
(convert-free-vars args self bound
(lambda (args)

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

@ -226,6 +226,13 @@
(let ((tail-slots (cdr (iota (1+ (length args))))))
(for-each maybe-load-constant tail-slots args))
(emit-tail-call asm (1+ (length args))))
(($ $callk k proc args)
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation))
(let ((tail-slots (cdr (iota (1+ (length args))))))
(for-each maybe-load-constant tail-slots args))
(emit-tail-call-label asm (1+ (length args)) k))
(($ $values ())
(emit-reset-frame asm 1)
(emit-return-values asm))
@ -442,37 +449,45 @@
(($ $primcall '> (a b)) (binary emit-br-if-< b a))))
(define (compile-trunc label k exp nreq rest-var nlocals)
(define (do-call proc args emit-call)
(let* ((proc-slot (lookup-call-proc-slot label allocation))
(nargs (1+ (length args)))
(arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation))
(for-each maybe-load-constant arg-slots (cons proc args))
(emit-call asm proc-slot nargs)
(emit-dead-slot-map asm proc-slot
(lookup-dead-slot-map label allocation))
(cond
((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
(match (lookup-parallel-moves k allocation)
((((? (lambda (src) (= src (1+ proc-slot))) src)
. dst)) dst)
(_ #f)))
;; The usual case: one required live return value, ignoring
;; any additional values.
=> (lambda (dst)
(emit-receive asm dst proc-slot nlocals)))
(else
(unless (and (zero? nreq) rest-var)
(emit-receive-values asm proc-slot (->bool rest-var) nreq))
(when (and rest-var (maybe-slot rest-var))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves k allocation))
(emit-reset-frame asm nlocals)))))
(match exp
(($ $call proc args)
(let* ((proc-slot (lookup-call-proc-slot label allocation))
(nargs (1+ (length args)))
(arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation))
(for-each maybe-load-constant arg-slots (cons proc args))
(emit-call asm proc-slot nargs)
(emit-dead-slot-map asm proc-slot
(lookup-dead-slot-map label allocation))
(cond
((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
(match (lookup-parallel-moves k allocation)
((((? (lambda (src) (= src (1+ proc-slot))) src)
. dst)) dst)
(_ #f)))
;; The usual case: one required live return value, ignoring
;; any additional values.
=> (lambda (dst)
(emit-receive asm dst proc-slot nlocals)))
(else
(unless (and (zero? nreq) rest-var)
(emit-receive-values asm proc-slot (->bool rest-var) nreq))
(when (and rest-var (maybe-slot rest-var))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves k allocation))
(emit-reset-frame asm nlocals)))))))
(do-call proc args
(lambda (asm proc-slot nargs)
(emit-call asm proc-slot nargs))))
(($ $callk k proc args)
(do-call proc args
(lambda (asm proc-slot nargs)
(emit-call-label asm proc-slot nargs k))))))
(match f
(($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))

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

@ -147,6 +147,9 @@
(($ $call proc args)
(mark-live! proc)
(for-each mark-live! args))
(($ $callk k proc args)
(mark-live! proc)
(for-each mark-live! args))
(($ $primcall name args)
(for-each mark-live! args))
(($ $values args)

5
module/language/cps/dfg.scm
View file

@ -839,6 +839,10 @@ BODY for each body continuation in the prompt."
(use! proc)
(for-each use! args))
(($ $callk k proc args)
(use! proc)
(for-each use! args))
(($ $primcall name args)
(for-each use! args))
@ -979,6 +983,7 @@ BODY for each body continuation in the prompt."
(lambda (use)
(match (find-expression (lookup-cont use conts))
(($ $call) #f)
(($ $callk) #f)
(($ $values) #f)
(($ $primcall 'free-ref (closure slot))
(not (eq? sym slot)))

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

@ -451,7 +451,7 @@
(cause &allocation))
(($ $prompt)
(cause &prompt))
(($ $call)
((or ($ $call) ($ $callk))
(logior &all-effects-but-bailout (cause &all-effects-but-bailout)))
(($ $primcall name args)
(primitive-effects dfg name args))))

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

@ -255,6 +255,9 @@
(($ $call proc args)
(let ((args (map subst args)))
(build-cps-exp ($call (subst proc) args))))
(($ $callk k proc args)
(let ((args (map subst args)))
(build-cps-exp ($callk k (subst proc) args))))
(($ $primcall name args)
(let ((args (map subst args)))
(build-cps-exp ($primcall name args))))

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

@ -352,6 +352,8 @@ are comparable with eqv?. A tmp slot may be used."
(match (find-expression body)
(($ $call proc args)
(cons proc args))
(($ $callk k proc args)
(cons proc args))
(($ $primcall name args)
args)
(($ $values args)
@ -423,7 +425,7 @@ are comparable with eqv?. A tmp slot may be used."
(match (vector-ref contv n)
(($ $kargs names syms body)
(match (find-expression body)
(($ $call)
((or ($ $call) ($ $callk))
(let ((args (make-bitvector (bitvector-length needs-slotv) #f)))
(bit-set*! args (live-before n) #t)
(bit-set*! args (live-after n) #f)
@ -460,7 +462,7 @@ are comparable with eqv?. A tmp slot may be used."
(if (bit-position #t dead 0)
(finish-hints n (live-before n) args)
(scan-for-hints (1- n) args))))
((or ($ $call) ($ $values))
((or ($ $call) ($ $callk) ($ $values))
(finish-hints n (live-before n) args))))
;; Otherwise we kill uses of the block entry.
(_ (finish-hints n (live-before (1+ n)) args))))
@ -640,7 +642,7 @@ are comparable with eqv?. A tmp slot may be used."
(($ $kargs names syms body)
(let ((uses (vector-ref usev n)))
(match (find-call body)
(($ $continue k src ($ $call))
(($ $continue k src (or ($ $call) ($ $callk)))
(allocate-call label k uses live post-live))
(($ $continue k src ($ $primcall)) #t)
(($ $continue k src ($ $values))

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

@ -124,6 +124,13 @@
(($ $call (? symbol? proc) ((? symbol? arg) ...))
(check-var proc v-env)
(for-each (cut check-var <> v-env) arg))
(($ $callk (? symbol? k*) (? symbol? proc) ((? symbol? arg) ...))
;; We don't check that k* is in scope; it's actually inside some
;; other function, probably. We rely on the transformation that
;; introduces the $callk to be correct, and the linker to resolve
;; the reference.
(check-var proc v-env)
(for-each (cut check-var <> v-env) arg))
(($ $primcall (? symbol? name) ((? symbol? arg) ...))
(for-each (cut check-var <> v-env) arg))
(($ $values ((? symbol? arg) ...))

2
module/system/vm/assembler.scm
View file

@ -1275,7 +1275,7 @@ needed."
;; FIXME: Define these somewhere central, shared with C.
(define *bytecode-major-version* #x0202)
(define *bytecode-minor-version* 3)
(define *bytecode-minor-version* 4)
(define (link-dynamic-section asm text rw rw-init frame-maps)
"Link the dynamic section for an ELF image with bytecode @var{text},