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

$branch is now a distinct CPS term type

Browse source 
* module/language/cps.scm ($branch): Refactor to be its own CPS term
  type, not relying on $continue to specify a continuation (which before
  was only for the false case) or a source location.  Update allllllll
  callers.
This commit is contained in:
Andy Wingo 2018-01-03 14:15:35 +01:00
parent 108ade6b0e
commit afb0a92d50
26 changed files with 907 additions and 804 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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
@ -435,7 +435,7 @@
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation)))))
(define (compile-test label exp kt kf next-label)
(define (compile-test label next-label kf kt op param args)
(define (prefer-true?)
(if (< (max kt kf) label)
;; Two backwards branches. Prefer
@ -474,71 +474,71 @@
(define (binary-</imm op a b)
(op asm (from-sp (slot a)) b)
(emit-branch emit-jl emit-jnl))
(match exp
(match (vector op param args)
;; Immediate type tag predicates.
(($ $primcall 'fixnum? #f (a)) (unary emit-fixnum? a))
(($ $primcall 'heap-object? #f (a)) (unary emit-heap-object? a))
(($ $primcall 'char? #f (a)) (unary emit-char? a))
(($ $primcall 'eq-false? #f (a)) (unary emit-eq-false? a))
(($ $primcall 'eq-nil? #f (a)) (unary emit-eq-nil? a))
(($ $primcall 'eq-null? #f (a)) (unary emit-eq-null? a))
(($ $primcall 'eq-true? #f (a)) (unary emit-eq-true? a))
(($ $primcall 'unspecified? #f (a)) (unary emit-unspecified? a))
(($ $primcall 'undefined? #f (a)) (unary emit-undefined? a))
(($ $primcall 'eof-object? #f (a)) (unary emit-eof-object? a))
(($ $primcall 'null? #f (a)) (unary emit-null? a))
(($ $primcall 'false? #f (a)) (unary emit-false? a))
(($ $primcall 'nil? #f (a)) (unary emit-nil? a))
(#('fixnum? #f (a)) (unary emit-fixnum? a))
(#('heap-object? #f (a)) (unary emit-heap-object? a))
(#('char? #f (a)) (unary emit-char? a))
(#('eq-false? #f (a)) (unary emit-eq-false? a))
(#('eq-nil? #f (a)) (unary emit-eq-nil? a))
(#('eq-null? #f (a)) (unary emit-eq-null? a))
(#('eq-true? #f (a)) (unary emit-eq-true? a))
(#('unspecified? #f (a)) (unary emit-unspecified? a))
(#('undefined? #f (a)) (unary emit-undefined? a))
(#('eof-object? #f (a)) (unary emit-eof-object? a))
(#('null? #f (a)) (unary emit-null? a))
(#('false? #f (a)) (unary emit-false? a))
(#('nil? #f (a)) (unary emit-nil? a))
;; Heap type tag predicates.
(($ $primcall 'pair? #f (a)) (unary emit-pair? a))
(($ $primcall 'struct? #f (a)) (unary emit-struct? a))
(($ $primcall 'symbol? #f (a)) (unary emit-symbol? a))
(($ $primcall 'variable? #f (a)) (unary emit-variable? a))
(($ $primcall 'vector? #f (a)) (unary emit-vector? a))
(($ $primcall 'string? #f (a)) (unary emit-string? a))
(($ $primcall 'heap-number? #f (a)) (unary emit-heap-number? a))
(($ $primcall 'hash-table? #f (a)) (unary emit-hash-table? a))
(($ $primcall 'pointer? #f (a)) (unary emit-pointer? a))
(($ $primcall 'fluid? #f (a)) (unary emit-fluid? a))
(($ $primcall 'stringbuf? #f (a)) (unary emit-stringbuf? a))
(($ $primcall 'dynamic-state? #f (a)) (unary emit-dynamic-state? a))
(($ $primcall 'frame? #f (a)) (unary emit-frame? a))
(($ $primcall 'keyword? #f (a)) (unary emit-keyword? a))
(($ $primcall 'atomic-box? #f (a)) (unary emit-atomic-box? a))
(($ $primcall 'syntax? #f (a)) (unary emit-syntax? a))
(($ $primcall 'program? #f (a)) (unary emit-program? a))
(($ $primcall 'vm-continuation? #f (a)) (unary emit-vm-continuation? a))
(($ $primcall 'bytevector? #f (a)) (unary emit-bytevector? a))
(($ $primcall 'weak-set? #f (a)) (unary emit-weak-set? a))
(($ $primcall 'weak-table? #f (a)) (unary emit-weak-table? a))
(($ $primcall 'array? #f (a)) (unary emit-array? a))
(($ $primcall 'bitvector? #f (a)) (unary emit-bitvector? a))
(($ $primcall 'smob? #f (a)) (unary emit-smob? a))
(($ $primcall 'port? #f (a)) (unary emit-port? a))
(($ $primcall 'bignum? #f (a)) (unary emit-bignum? a))
(($ $primcall 'flonum? #f (a)) (unary emit-flonum? a))
(($ $primcall 'compnum? #f (a)) (unary emit-compnum? a))
(($ $primcall 'fracnum? #f (a)) (unary emit-fracnum? a))
(#('pair? #f (a)) (unary emit-pair? a))
(#('struct? #f (a)) (unary emit-struct? a))
(#('symbol? #f (a)) (unary emit-symbol? a))
(#('variable? #f (a)) (unary emit-variable? a))
(#('vector? #f (a)) (unary emit-vector? a))
(#('string? #f (a)) (unary emit-string? a))
(#('heap-number? #f (a)) (unary emit-heap-number? a))
(#('hash-table? #f (a)) (unary emit-hash-table? a))
(#('pointer? #f (a)) (unary emit-pointer? a))
(#('fluid? #f (a)) (unary emit-fluid? a))
(#('stringbuf? #f (a)) (unary emit-stringbuf? a))
(#('dynamic-state? #f (a)) (unary emit-dynamic-state? a))
(#('frame? #f (a)) (unary emit-frame? a))
(#('keyword? #f (a)) (unary emit-keyword? a))
(#('atomic-box? #f (a)) (unary emit-atomic-box? a))
(#('syntax? #f (a)) (unary emit-syntax? a))
(#('program? #f (a)) (unary emit-program? a))
(#('vm-continuation? #f (a)) (unary emit-vm-continuation? a))
(#('bytevector? #f (a)) (unary emit-bytevector? a))
(#('weak-set? #f (a)) (unary emit-weak-set? a))
(#('weak-table? #f (a)) (unary emit-weak-table? a))
(#('array? #f (a)) (unary emit-array? a))
(#('bitvector? #f (a)) (unary emit-bitvector? a))
(#('smob? #f (a)) (unary emit-smob? a))
(#('port? #f (a)) (unary emit-port? a))
(#('bignum? #f (a)) (unary emit-bignum? a))
(#('flonum? #f (a)) (unary emit-flonum? a))
(#('compnum? #f (a)) (unary emit-compnum? a))
(#('fracnum? #f (a)) (unary emit-fracnum? a))
;; Binary predicates.
(($ $primcall 'eq? #f (a b)) (binary-test emit-eq? a b))
(($ $primcall 'heap-numbers-equal? #f (a b))
(#('eq? #f (a b)) (binary-test emit-eq? a b))
(#('heap-numbers-equal? #f (a b))
(binary-test emit-heap-numbers-equal? a b))
(($ $primcall '< #f (a b)) (binary-< emit-<? a b))
(($ $primcall '<= #f (a b)) (binary-<= emit-<? a b))
(($ $primcall '= #f (a b)) (binary-test emit-=? a b))
(($ $primcall 'u64-< #f (a b)) (binary-< emit-u64<? a b))
(($ $primcall 'u64-imm-< b (a)) (binary-</imm emit-u64-imm<? a b))
(($ $primcall 'imm-u64-< b (a)) (binary-</imm emit-imm-u64<? a b))
(($ $primcall 'u64-= #f (a b)) (binary-test emit-u64=? a b))
(($ $primcall 'u64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
(($ $primcall 's64-= #f (a b)) (binary-test emit-u64=? a b))
(($ $primcall 's64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
(($ $primcall 's64-< #f (a b)) (binary-< emit-s64<? a b))
(($ $primcall 's64-imm-< b (a)) (binary-</imm emit-s64-imm<? a b))
(($ $primcall 'imm-s64-< b (a)) (binary-</imm emit-imm-s64<? a b))
(($ $primcall 'f64-< #f (a b)) (binary-< emit-f64<? a b))
(($ $primcall 'f64-<= #f (a b)) (binary-<= emit-f64<? a b))
(($ $primcall 'f64-= #f (a b)) (binary-test emit-f64=? a b))))
(#('< #f (a b)) (binary-< emit-<? a b))
(#('<= #f (a b)) (binary-<= emit-<? a b))
(#('= #f (a b)) (binary-test emit-=? a b))
(#('u64-< #f (a b)) (binary-< emit-u64<? a b))
(#('u64-imm-< b (a)) (binary-</imm emit-u64-imm<? a b))
(#('imm-u64-< b (a)) (binary-</imm emit-imm-u64<? a b))
(#('u64-= #f (a b)) (binary-test emit-u64=? a b))
(#('u64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
(#('s64-= #f (a b)) (binary-test emit-u64=? a b))
(#('s64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
(#('s64-< #f (a b)) (binary-< emit-s64<? a b))
(#('s64-imm-< b (a)) (binary-</imm emit-s64-imm<? a b))
(#('imm-s64-< b (a)) (binary-</imm emit-imm-s64<? a b))
(#('f64-< #f (a b)) (binary-< emit-f64<? a b))
(#('f64-<= #f (a b)) (binary-<= emit-f64<? a b))
(#('f64-= #f (a b)) (binary-test emit-f64=? a b))))
(define (compile-trunc label k exp nreq rest-var)
(define (do-call proc args emit-call)
@ -599,13 +599,8 @@
(compile-value label exp dst)))
(maybe-emit-jump))
(($ $kargs () ())
(match exp
(($ $branch kt exp)
(compile-test label exp (forward-label kt) forwarded-k
(skip-elided-conts (1+ label))))
(_
(compile-effect label exp k)
(maybe-emit-jump))))
(compile-effect label exp k)
(maybe-emit-jump))
(($ $kargs names syms)
(compile-values label exp syms)
(maybe-emit-jump))
@ -620,6 +615,20 @@
(unless fallthrough?
(emit-j asm kargs)))))))
(define (compile-term label term)
(match term
(($ $continue k src exp)
(when src
(emit-source asm src))
(unless (elide-cont? label)
(compile-expression label k exp)))
(($ $branch kf kt src op param args)
(when src
(emit-source asm src))
(compile-test label (skip-elided-conts (1+ label))
(forward-label kf) (forward-label kt)
op param args))))
(define (compile-cont label cont)
(match cont
(($ $kfun src meta self tail clause)
@ -646,7 +655,7 @@
(let ((body (forward-label body)))
(unless (= body (skip-elided-conts (1+ label)))
(emit-j asm body)))))
(($ $kargs names vars ($ $continue k src exp))
(($ $kargs names vars term)
(emit-label asm label)
(for-each (lambda (name var)
(let ((slot (maybe-slot var)))
@ -654,10 +663,7 @@
(let ((repr (lookup-representation var allocation)))
(emit-definition asm name slot repr)))))
names vars)
(when src
(emit-source asm src))
(unless (elide-cont? label)
(compile-expression label k exp)))
(compile-term label term))
(($ $kreceive arity kargs)
(emit-label asm label))
(($ $ktail)