diff options
author | Andy Wingo <wingo@pobox.com> | 2013-08-11 14:08:08 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-08-31 09:40:56 +0200 |
commit | 6e8ad823359adae643007afb3a4c4f4d91c252e5 (patch) | |
tree | bbeced1070771d55e653030a5f5c079619ae518e | |
parent | 934e6b95159c75fe43dfb1a8e0882d6b88ba4cbf (diff) | |
download | guile-6e8ad823359adae643007afb3a4c4f4d91c252e5.tar.gz |
Add CPS -> RTL compiler
* module/Makefile.am:
* module/language/cps/compile-rtl.scm:
* module/language/cps/dfg.scm:
* module/language/cps/slot-allocation.scm: New modules.
* module/language/cps/spec.scm: Register the compiler.
* test-suite/Makefile.am:
* test-suite/tests/rtl-compilation.test: Add tests.
-rw-r--r-- | module/Makefile.am | 3 | ||||
-rw-r--r-- | module/language/cps/compile-rtl.scm | 371 | ||||
-rw-r--r-- | module/language/cps/dfg.scm | 432 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 419 | ||||
-rw-r--r-- | module/language/cps/spec.scm | 3 | ||||
-rw-r--r-- | test-suite/Makefile.am | 1 | ||||
-rw-r--r-- | test-suite/tests/rtl-compilation.test | 200 |
7 files changed, 1428 insertions, 1 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index d7e524bec..5a0ff6952 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -122,8 +122,11 @@ CPS_LANG_SOURCES = \ language/cps.scm \ language/cps/arities.scm \ language/cps/closure-conversion.scm \ + language/cps/compile-rtl.scm \ + language/cps/dfg.scm \ language/cps/primitives.scm \ language/cps/reify-primitives.scm \ + language/cps/slot-allocation.scm \ language/cps/spec.scm \ language/cps/verify.scm diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm new file mode 100644 index 000000000..9277adf43 --- /dev/null +++ b/module/language/cps/compile-rtl.scm @@ -0,0 +1,371 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013 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 published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Compiling CPS to RTL. The result is in the RTL language, which +;;; happens to be an ELF image as a bytecode. +;;; +;;; Code: + +(define-module (language cps compile-rtl) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (language cps) + #:use-module (language cps arities) + #:use-module (language cps closure-conversion) + #:use-module (language cps dfg) + #:use-module (language cps primitives) + #:use-module (language cps reify-primitives) + #:use-module (language cps slot-allocation) + #:use-module (system vm assembler) + #:export (compile-rtl)) + +;; TODO: Source info, local var names. Needs work in the linker and the +;; debugger. + +(define (kw-arg-ref args kw default) + (match (memq kw args) + ((_ val . _) val) + (_ default))) + +(define (optimize exp opts) + (define (run-pass exp pass kw default) + (if (kw-arg-ref opts kw default) + (pass exp) + exp)) + + ;; Calls to source-to-source optimization passes go here. + (let* () + ;; Passes that are needed: + ;; + ;; * Contification: turning $letrec-bound $funs into $letk-bound $conts. + ;; + ;; * Abort contification: turning abort primcalls into continuation + ;; calls, and eliding prompts if possible. + ;; + ;; * Common subexpression elimination. Desperately needed. Requires + ;; effects analysis. + ;; + ;; * Loop peeling. Unrolls the first round through a loop if the + ;; loop has effects that CSE can work on. Requires effects + ;; analysis. When run before CSE, loop peeling is the equivalent + ;; of loop-invariant code motion (LICM). + ;; + ;; * Generic simplification pass, to be run as needed. Used to + ;; "clean up", both on the original raw input and after specific + ;; optimization passes. + + exp)) + +(define (visit-funs proc exp) + (match exp + (($ $continue _ exp) + (visit-funs proc exp)) + + (($ $fun meta free body) + (proc exp) + (visit-funs proc body)) + + (($ $letk conts body) + (visit-funs proc body) + (for-each (lambda (cont) (visit-funs proc cont)) conts)) + + (($ $cont sym src ($ $kargs names syms body)) + (visit-funs proc body)) + + (($ $cont sym src ($ $kclause arity body)) + (visit-funs proc body)) + + (($ $cont sym src ($ $kentry self tail clauses)) + (for-each (lambda (clause) (visit-funs proc clause)) clauses)) + + (_ (values)))) + +(define (emit-rtl-sequence asm exp allocation nlocals cont-table) + (define (slot sym) + (lookup-slot sym allocation)) + + (define (constant sym) + (lookup-constant-value sym allocation)) + + (define (emit-rtl label k exp next-label) + (define (maybe-mov dst src) + (unless (= dst src) + (emit-mov asm dst src))) + + (define (maybe-jump label) + (unless (eq? label next-label) + (emit-br asm label))) + + (define (maybe-load-constant slot src) + (call-with-values (lambda () + (lookup-maybe-constant-value src allocation)) + (lambda (has-const? val) + (and has-const? + (begin + (emit-load-constant asm slot val) + #t))))) + + (define (emit-tail) + ;; There are only three kinds of expressions in tail position: + ;; tail calls, multiple-value returns, and single-value returns. + (match exp + (($ $call 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 asm (1+ (length args)))) + (($ $values args) + (let ((tail-slots (cdr (iota (1+ (length args)))))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (for-each maybe-load-constant tail-slots args)) + (emit-reset-frame asm (1+ (length args))) + (emit-return-values asm)) + (($ $primcall 'return (arg)) + (emit-return asm (slot arg))))) + + (define (emit-val sym) + (let ((dst (slot sym))) + (match exp + (($ $var sym) + (maybe-mov dst (slot sym))) + (($ $void) + (when dst + (emit-load-constant asm dst *unspecified*))) + (($ $const exp) + (when dst + (emit-load-constant asm dst exp))) + (($ $fun meta () ($ $cont k)) + (emit-load-static-procedure asm dst k)) + (($ $fun meta free ($ $cont k)) + (emit-make-closure asm dst k (length free))) + (($ $call proc args) + (let ((proc-slot (lookup-call-proc-slot label allocation)) + (nargs (length args))) + (or (maybe-load-constant proc-slot proc) + (maybe-mov proc-slot (slot proc))) + (let lp ((n (1+ proc-slot)) (args args)) + (match args + (() + (emit-call asm proc-slot (+ nargs 1)) + (emit-receive asm dst proc-slot nlocals)) + ((arg . args) + (or (maybe-load-constant n arg) + (maybe-mov n (slot arg))) + (lp (1+ n) args)))))) + (($ $primcall 'current-module) + (emit-current-module asm dst)) + (($ $primcall 'cached-toplevel-box (scope name bound?)) + (emit-cached-toplevel-box asm dst (constant scope) (constant name) + (constant bound?))) + (($ $primcall 'cached-module-box (mod name public? bound?)) + (emit-cached-module-box asm dst (constant mod) (constant name) + (constant public?) (constant bound?))) + (($ $primcall 'resolve (name bound?)) + (emit-resolve asm dst (constant bound?) (slot name))) + (($ $primcall 'free-ref (closure idx)) + (emit-free-ref asm dst (slot closure) (constant idx))) + (($ $primcall name args) + ;; FIXME: Inline all the cases. + (let ((inst (prim-rtl-instruction name))) + (emit-text asm `((,inst ,dst ,@(map slot args)))))) + (($ $values (arg)) + (or (maybe-load-constant dst arg) + (maybe-mov dst (slot arg)))) + (($ $prompt escape? tag handler) + (emit-prompt asm escape? tag handler))) + (maybe-jump k))) + + (define (emit-vals syms) + (match exp + (($ $primcall name args) + (error "unimplemented primcall in values context" name)) + (($ $values args) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (for-each maybe-load-constant (map slot syms) args))) + (maybe-jump k)) + + (define (emit-seq) + (match exp + (($ $primcall 'cache-current-module! (sym scope)) + (emit-cache-current-module! asm (slot sym) (constant scope))) + (($ $primcall 'free-set! (closure idx value)) + (emit-free-set! asm (slot closure) (slot value) (constant idx))) + (($ $primcall 'box-set! (box value)) + (emit-box-set! asm (slot box) (slot value))) + (($ $primcall 'struct-set! (struct index value)) + (emit-struct-set! asm (slot struct) (slot index) (slot value))) + (($ $primcall 'vector-set! (vector index value)) + (emit-vector-set asm (slot vector) (slot index) (slot value))) + (($ $primcall 'set-car! (pair value)) + (emit-set-car! asm (slot pair) (slot value))) + (($ $primcall 'set-cdr! (pair value)) + (emit-set-cdr! asm (slot pair) (slot value))) + (($ $primcall 'define! (sym value)) + (emit-define asm (slot sym) (slot value))) + (($ $primcall name args) + (error "unhandled primcall in seq context" name)) + (($ $values ()) #f)) + (maybe-jump k)) + + (define (emit-test kt kf) + (define (unary op sym) + (cond + ((eq? kt next-label) + (op asm (slot sym) #t kf)) + (else + (op asm (slot sym) #f kt) + (maybe-jump kf)))) + (define (binary op a b) + (cond + ((eq? kt next-label) + (op asm (slot a) (slot b) #t kf)) + (else + (op asm (slot a) (slot b) #f kt) + (maybe-jump kf)))) + (match exp + (($ $var sym) (unary emit-br-if-true sym)) + (($ $primcall 'null? (a)) (unary emit-br-if-null a)) + (($ $primcall 'nil? (a)) (unary emit-br-if-nil a)) + (($ $primcall 'pair? (a)) (unary emit-br-if-pair a)) + (($ $primcall 'struct? (a)) (unary emit-br-if-struct a)) + (($ $primcall 'char? (a)) (unary emit-br-if-char a)) + ;; Add TC7 tests here + (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b)) + (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b)) + (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b)) + (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b)) + (($ $primcall '< (a b)) (binary emit-br-if-< a b)) + (($ $primcall '<= (a b)) (binary emit-br-if-<= a b)) + (($ $primcall '= (a b)) (binary emit-br-if-= a b)) + (($ $primcall '>= (a b)) (binary emit-br-if-<= b a)) + (($ $primcall '> (a b)) (binary emit-br-if-< b a)))) + + (define (emit-trunc nreq rest? k) + (match exp + (($ $call proc args) + (let ((proc-slot (lookup-call-proc-slot label allocation)) + (nargs (length args))) + (or (maybe-load-constant proc-slot proc) + (maybe-mov proc-slot (slot proc))) + (let lp ((n (1+ proc-slot)) (args args)) + (match args + (() + (emit-call asm proc-slot (+ nargs 1)) + (emit-receive-values asm proc-slot nreq) + (when rest? + (emit-bind-rest asm (+ proc-slot 1 nreq))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (emit-reset-frame asm nlocals)) + ((arg . args) + (or (maybe-load-constant n arg) + (maybe-mov n (slot arg))) + (lp (1+ n) args))))))) + (maybe-jump k)) + + (match (lookup-cont k cont-table) + (($ $ktail) (emit-tail)) + (($ $kargs (name) (sym)) (emit-val sym)) + (($ $kargs () ()) (emit-seq)) + (($ $kargs names syms) (emit-vals syms)) + (($ $kargs (name) (sym)) (emit-val sym)) + (($ $kif kt kf) (emit-test kt kf)) + (($ $ktrunc ($ $arity req () rest () #f) k) + (emit-trunc (length req) (and rest #t) k)))) + + (define (collect-exps k src cont tail) + (define (find-exp k src term) + (match term + (($ $continue exp-k exp) + (cons (list k src exp-k exp) tail)) + (($ $letk conts body) + (find-exp k src body)))) + (match cont + (($ $kargs names syms body) + (find-exp k src body)) + (_ tail))) + + (let lp ((exps (reverse (fold-local-conts collect-exps '() exp)))) + (match exps + (() #t) + (((k src exp-k exp) . exps) + (let ((next-label (match exps + (((k . _) . _) k) + (() #f)))) + (emit-label asm k) + (emit-rtl k exp-k exp next-label) + (lp exps)))))) + +(define (compile-fun f asm) + (let ((allocation (allocate-slots f)) + (cont-table (match f + (($ $fun meta free body) + (build-local-cont-table body))))) + (define (emit-fun-clause clause alternate) + (match clause + (($ $cont k src + ($ $kclause ($ $arity req opt rest kw allow-other-keys?) + body)) + (let ((kw-indices (map (match-lambda + ((key name sym) + (cons key (lookup-slot sym allocation)))) + kw)) + (nlocals (lookup-nlocals k allocation))) + (emit-label asm k) + (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys? + nlocals alternate) + (emit-rtl-sequence asm body allocation nlocals cont-table) + (emit-end-arity asm))))) + + (define (emit-fun-clauses clauses) + (match clauses + ((clause . clauses) + (let ((kalternate (match clauses + (() #f) + ((($ $cont k) . _) k)))) + (emit-fun-clause clause kalternate) + (when kalternate + (emit-fun-clauses clauses)))))) + + (match f + (($ $fun meta free ($ $cont k src ($ $kentry self tail clauses))) + (emit-begin-program asm k (or meta '())) + (emit-fun-clauses clauses) + (emit-end-program asm))))) + +(define (compile-rtl exp env opts) + (let* ((exp (fix-arities exp)) + (exp (optimize exp opts)) + (exp (convert-closures exp)) + (exp (reify-primitives exp)) + (asm (make-assembler))) + (visit-funs (lambda (fun) + (compile-fun fun asm)) + exp) + (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f)) + env + env))) diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm new file mode 100644 index 000000000..08264518d --- /dev/null +++ b/module/language/cps/dfg.scm @@ -0,0 +1,432 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013 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 published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Many passes rely on a local or global static analysis of a function. +;;; This module implements a simple data-flow graph (DFG) analysis, +;;; tracking the definitions and uses of variables and continuations. +;;; It also builds a table of continuations and parent links, to be able +;;; to easily determine if one continuation is in the scope of another, +;;; and to get to the expression inside a continuation. +;;; +;;; Note that the data-flow graph of continuation labels is a +;;; control-flow graph. +;;; +;;; We currently don't expose details of the DFG type outside this +;;; module, preferring to only expose accessors. That may change in the +;;; future but it seems to work for now. +;;; +;;; Code: + +(define-module (language cps dfg) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (language cps) + #:export (build-cont-table + build-local-cont-table + lookup-cont + + compute-dfg + dfg-cont-table + lookup-def + lookup-uses + find-call + call-expression + find-expression + find-defining-expression + find-constant-value + lift-definition! + variable-used-in? + constant-needs-allocation? + dead-after-def? + dead-after-use? + branch? + find-other-branches + dead-after-branch? + lookup-bound-syms)) + +(define (build-cont-table fun) + (fold-conts (lambda (k src cont table) + (hashq-set! table k cont) + table) + (make-hash-table) + fun)) + +(define (build-local-cont-table cont) + (fold-local-conts (lambda (k src cont table) + (hashq-set! table k cont) + table) + (make-hash-table) + cont)) + +(define (lookup-cont sym conts) + (let ((res (hashq-ref conts sym))) + (unless res + (error "Unknown continuation!" sym (hash-fold acons '() conts))) + res)) + +;; Data-flow graph for CPS: both for values and continuations. +(define-record-type $dfg + (make-dfg conts use-maps uplinks) + dfg? + ;; hash table of sym -> $kargs, $kif, etc + (conts dfg-cont-table) + ;; hash table of sym -> $use-map + (use-maps dfg-use-maps) + ;; hash table of sym -> $parent-link + (uplinks dfg-uplinks)) + +(define-record-type $use-map + (make-use-map sym def uses) + use-map? + (sym use-map-sym) + (def use-map-def) + (uses use-map-uses set-use-map-uses!)) + +(define-record-type $uplink + (make-uplink parent level) + uplink? + (parent uplink-parent) + (level uplink-level)) + +(define (visit-fun fun conts use-maps uplinks global?) + (define (add-def! sym def-k) + (unless def-k + (error "Term outside labelled continuation?")) + (hashq-set! use-maps sym (make-use-map sym def-k '()))) + + (define (add-use! sym use-k) + (match (hashq-ref use-maps sym) + (#f (error "Symbol out of scope?" sym)) + ((and use-map ($ $use-map sym def uses)) + (set-use-map-uses! use-map (cons use-k uses))))) + + (define (link-parent! k parent) + (match (hashq-ref uplinks parent) + (($ $uplink _ level) + (hashq-set! uplinks k (make-uplink parent (1+ level)))))) + + (define (visit exp exp-k) + (define (def! sym) + (add-def! sym exp-k)) + (define (use! sym) + (add-use! sym exp-k)) + (define (recur exp) + (visit exp exp-k)) + (match exp + (($ $letk (($ $cont k src cont) ...) body) + ;; Set up recursive environment before visiting cont bodies. + (for-each (lambda (cont k) + (def! k) + (hashq-set! conts k cont) + (link-parent! k exp-k)) + cont k) + (for-each visit cont k) + (recur body)) + + (($ $kargs names syms body) + (for-each def! syms) + (recur body)) + + (($ $kif kt kf) + (use! kt) + (use! kf)) + + (($ $ktrunc arity k) + (use! k)) + + (($ $letrec names syms funs body) + (unless global? + (error "$letrec should not be present when building a local DFG")) + (for-each def! syms) + (for-each (cut visit-fun <> conts use-maps uplinks global?) funs) + (visit body exp-k)) + + (($ $continue k exp) + (use! k) + (match exp + (($ $var sym) + (use! sym)) + + (($ $call proc args) + (use! proc) + (for-each use! args)) + + (($ $primcall name args) + (for-each use! args)) + + (($ $values args) + (for-each use! args)) + + (($ $prompt escape? tag handler) + (use! tag) + (use! handler)) + + (($ $fun) + (when global? + (visit-fun exp conts use-maps uplinks global?))) + + (_ #f))))) + + (match fun + (($ $fun meta free + ($ $cont kentry src + (and entry + ($ $kentry self ($ $cont ktail _ tail) clauses)))) + ;; Treat the fun continuation as its own parent. + (add-def! kentry kentry) + (add-def! self kentry) + (hashq-set! uplinks kentry (make-uplink #f 0)) + (hashq-set! conts kentry entry) + + (add-def! ktail kentry) + (hashq-set! conts ktail tail) + (link-parent! ktail kentry) + + (for-each + (match-lambda + (($ $cont kclause _ + (and clause ($ $kclause arity ($ $cont kbody _ body)))) + (add-def! kclause kentry) + (hashq-set! conts kclause clause) + (link-parent! kclause kentry) + + (add-def! kbody kclause) + (hashq-set! conts kbody body) + (link-parent! kbody kclause) + + (visit body kbody))) + clauses)))) + +(define* (compute-dfg fun #:key (global? #t)) + (let* ((conts (make-hash-table)) + (use-maps (make-hash-table)) + (uplinks (make-hash-table))) + (visit-fun fun conts use-maps uplinks global?) + (make-dfg conts use-maps uplinks))) + +(define (lookup-uplink k uplinks) + (let ((res (hashq-ref uplinks k))) + (unless res + (error "Unknown continuation!" k (hash-fold acons '() uplinks))) + res)) + +(define (lookup-use-map sym use-maps) + (let ((res (hashq-ref use-maps sym))) + (unless res + (error "Unknown lexical!" sym (hash-fold acons '() use-maps))) + res)) + +(define (lookup-def sym dfg) + (match dfg + (($ $dfg conts use-maps uplinks) + (match (lookup-use-map sym use-maps) + (($ $use-map sym def uses) + def))))) + +(define (lookup-uses sym dfg) + (match dfg + (($ $dfg conts use-maps uplinks) + (match (lookup-use-map sym use-maps) + (($ $use-map sym def uses) + uses))))) + +(define (find-defining-term sym dfg) + (match (lookup-uses (lookup-def sym dfg) dfg) + ((def-exp-k) + (lookup-cont def-exp-k (dfg-cont-table dfg))) + (else #f))) + +(define (find-call term) + (match term + (($ $kargs names syms body) (find-call body)) + (($ $letk conts body) (find-call body)) + (($ $letrec names syms funs body) (find-call body)) + (($ $continue) term))) + +(define (call-expression call) + (match call + (($ $continue k exp) exp))) + +(define (find-expression term) + (call-expression (find-call term))) + +(define (find-defining-expression sym dfg) + (match (find-defining-term sym dfg) + (#f #f) + (($ $ktrunc) #f) + (term (find-expression term)))) + +(define (find-constant-value sym dfg) + (match (find-defining-expression sym dfg) + (($ $const val) + (values #t val)) + (($ $continue k ($ $void)) + (values #t *unspecified*)) + (else + (values #f #f)))) + +(define (constant-needs-allocation? sym val dfg) + (define (find-exp term) + (match term + (($ $kargs names syms body) (find-exp body)) + (($ $letk conts body) (find-exp body)) + (else term))) + (match dfg + (($ $dfg conts use-maps uplinks) + (match (lookup-use-map sym use-maps) + (($ $use-map _ def uses) + (or-map + (lambda (use) + (match (find-expression (lookup-cont use conts)) + (($ $call) #f) + (($ $values) #f) + (($ $primcall 'free-ref (closure slot)) + (not (eq? sym slot))) + (($ $primcall 'free-set! (closure slot value)) + (not (eq? sym slot))) + (($ $primcall 'cache-current-module! (mod . _)) + (eq? sym mod)) + (($ $primcall 'cached-toplevel-box _) + #f) + (($ $primcall 'cached-module-box _) + #f) + (($ $primcall 'resolve (name bound?)) + (eq? sym name)) + (_ #t))) + uses)))))) + +(define (continuation-scope-contains? parent-k k uplinks) + (match (lookup-uplink parent-k uplinks) + (($ $uplink _ parent-level) + (let lp ((k k)) + (or (eq? parent-k k) + (match (lookup-uplink k uplinks) + (($ $uplink parent level) + (and (< parent-level level) + (lp parent))))))))) + +(define (lift-definition! k parent-k dfg) + (match dfg + (($ $dfg conts use-maps uplinks) + (match (lookup-uplink parent-k uplinks) + (($ $uplink parent level) + (hashq-set! uplinks k + (make-uplink parent-k (1+ level))) + ;; Lift definitions of all conts in K. + (let lp ((cont (lookup-cont k conts))) + (match cont + (($ $letk (($ $cont kid) ...) body) + (for-each (cut lift-definition! <> k dfg) kid) + (lp body)) + (($ $letrec names syms funs body) + (lp body)) + (_ #t)))))))) + +(define (variable-used-in? var parent-k dfg) + (match dfg + (($ $dfg conts use-maps uplinks) + (or-map (lambda (use) + (continuation-scope-contains? parent-k use uplinks)) + (match (lookup-use-map var use-maps) + (($ $use-map sym def uses) + uses)))))) + +;; Does k1 dominate k2? +;; +;; Note that this is a conservative predicate: a false return value does +;; not indicate that k1 _doesn't_ dominate k2. The reason for this is +;; that we are using the scope tree as an approximation of the dominator +;; relationship. See +;; http://mlton.org/pipermail/mlton/2003-January/023054.html for a +;; deeper discussion. +(define (conservatively-dominates? k1 k2 uplinks) + (continuation-scope-contains? k1 k2 uplinks)) + +(define (dead-after-def? sym dfg) + (match dfg + (($ $dfg conts use-maps uplinks) + (match (lookup-use-map sym use-maps) + (($ $use-map sym def uses) + (null? uses)))))) + +(define (dead-after-use? sym use-k dfg) + (match dfg + (($ $dfg conts use-maps uplinks) + (match (lookup-use-map sym use-maps) + (($ $use-map sym def uses) + ;; If all other uses dominate this use, it is now dead. There + ;; are other ways for it to be dead, but this is an + ;; approximation. A better check would be if the successor + ;; post-dominates all uses. + (and-map (cut conservatively-dominates? <> use-k uplinks) + uses)))))) + +;; A continuation is a "branch" if all of its predecessors are $kif +;; continuations. +(define (branch? k dfg) + (match dfg + (($ $dfg conts use-maps uplinks) + (match (lookup-use-map k use-maps) + (($ $use-map sym def uses) + (and (not (null? uses)) + (and-map (lambda (k) + (match (lookup-cont k conts) + (($ $kif) #t) + (_ #f))) + uses))))))) + +(define (find-other-branches k dfg) + (match dfg + (($ $dfg conts use-maps uplinks) + (match (lookup-use-map k use-maps) + (($ $use-map sym def (uses ..1)) + (map (lambda (kif) + (match (lookup-cont kif conts) + (($ $kif (? (cut eq? <> k)) kf) + kf) + (($ $kif kt (? (cut eq? <> k))) + kt) + (_ (error "Not all predecessors are branches")))) + uses)))))) + +(define (dead-after-branch? sym branch other-branches dfg) + (match dfg + (($ $dfg conts use-maps uplinks) + (match (lookup-use-map sym use-maps) + (($ $use-map sym def uses) + (and-map + (lambda (use-k) + ;; A symbol is dead after a branch if at least one of the + ;; other branches dominates a use of the symbol, and all + ;; other uses of the symbol dominate the test. + (if (or-map (cut conservatively-dominates? <> use-k uplinks) + other-branches) + (not (conservatively-dominates? branch use-k uplinks)) + (conservatively-dominates? use-k branch uplinks))) + uses)))))) + +(define (lookup-bound-syms k dfg) + (match dfg + (($ $dfg conts use-maps uplinks) + (match (lookup-cont k conts) + (($ $kargs names syms body) + syms))))) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm new file mode 100644 index 000000000..a7b9f746c --- /dev/null +++ b/module/language/cps/slot-allocation.scm @@ -0,0 +1,419 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013 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 published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A module to assign stack slots to variables in a CPS term. +;;; +;;; Code: + +(define-module (language cps slot-allocation) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (language cps) + #:use-module (language cps dfg) + #:export (allocate-slots + lookup-slot + lookup-constant-value + lookup-maybe-constant-value + lookup-nlocals + lookup-call-proc-slot + lookup-parallel-moves)) + +;; Continuations can bind variables. The $allocation structure +;; represents the slot in which a variable is stored. +;; +;; Not all variables have slots allocated. Variables that are constant +;; and that are only used by primcalls that can accept constants +;; directly are not allocated to slots, and their SLOT value is false. +;; Likewise constants that are only used by calls are not allocated into +;; slots, to avoid needless copying. If a variable is constant, its +;; constant value is set to the CONST slot and HAS-CONST? is set to a +;; true value. +;; +;; DEF holds the label of the continuation that defines the variable, +;; and DEAD is a list of continuations at which the variable becomes +;; dead. +(define-record-type $allocation + (make-allocation def slot dead has-const? const) + allocation? + (def allocation-def) + (slot allocation-slot) + (dead allocation-dead set-allocation-dead!) + (has-const? allocation-has-const?) + (const allocation-const)) + +;; Continuations can also have associated allocation data. For example, +;; when a call happens in a labelled continuation, we need to know what +;; slot the procedure goes in. Likewise before branching to the target +;; continuation, we might need to shuffle values into the right place: a +;; parallel move. $cont-allocation stores allocation data keyed on the +;; continuation label. +(define-record-type $cont-allocation + (make-cont-allocation call-proc-slot parallel-moves) + cont-allocation? + + ;; Currently calls are allocated in the caller frame, above all locals + ;; that are live at the time of the call. Therefore there is no + ;; parallel move problem. We could be more clever here. + (call-proc-slot cont-call-proc-slot) + + ;; Tail calls, multiple-value returns, and jumps to continuations with + ;; multiple arguments are forms of parallel assignment. A + ;; $parallel-move represents a specific solution to the parallel + ;; assignment problem, with an ordered list of (SRC . DST) moves. This + ;; may involve a temporary variable. + ;; + ;; ((src . dst) ...) + (parallel-moves cont-parallel-moves)) + +(define (find-first-zero n) + ;; Naive implementation. + (let lp ((slot 0)) + (if (logbit? slot n) + (lp (1+ slot)) + slot))) + +(define (find-first-trailing-zero n count) + (let lp ((slot count)) + (if (or (zero? slot) (logbit? (1- slot) n)) + slot + (lp (1- slot))))) + +(define (lookup-allocation sym allocation) + (let ((res (hashq-ref allocation sym))) + (unless res + (error "Variable or continuation not defined" sym)) + res)) + +(define (lookup-slot sym allocation) + (match (lookup-allocation sym allocation) + (($ $allocation def slot dead has-const? const) slot))) + +(define (lookup-constant-value sym allocation) + (match (lookup-allocation sym allocation) + (($ $allocation def slot dead #t const) const) + (_ + (error "Variable does not have constant value" sym)))) + +(define (lookup-maybe-constant-value sym allocation) + (match (lookup-allocation sym allocation) + (($ $allocation def slot dead has-const? const) + (values has-const? const)))) + +(define (lookup-call-proc-slot k allocation) + (match (lookup-allocation k allocation) + (($ $cont-allocation proc-slot parallel-moves) + (unless proc-slot + (error "Continuation not a call" k)) + proc-slot) + (_ + (error "Continuation not a call" k)))) + +(define (lookup-nlocals k allocation) + (match (lookup-allocation k allocation) + ((? number? nlocals) nlocals) + (_ + (error "Not a clause continuation" k)))) + +(define (lookup-parallel-moves k allocation) + (match (lookup-allocation k allocation) + (($ $cont-allocation proc-slot parallel-moves) + (unless parallel-moves + (error "Continuation does not have parallel moves" k)) + parallel-moves) + (_ + (error "Continuation not a call" k)))) + +(define (solve-parallel-move src dst tmp) + "Solve the parallel move problem between src and dst slot lists, which +are comparable with eqv?. A tmp slot may be used." + + ;; This algorithm is taken from: "Tilting at windmills with Coq: + ;; formal verification of a compilation algorithm for parallel moves" + ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy + ;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf> + + (define (split-move moves reg) + (let loop ((revhead '()) (tail moves)) + (match tail + (((and s+d (s . d)) . rest) + (if (eqv? s reg) + (cons d (append-reverse revhead rest)) + (loop (cons s+d revhead) rest))) + (_ #f)))) + + (define (replace-last-source reg moves) + (match moves + ((moves ... (s . d)) + (append moves (list (cons reg d)))))) + + (let loop ((to-move (map cons src dst)) + (being-moved '()) + (moved '()) + (last-source #f)) + ;; 'last-source' should always be equivalent to: + ;; (and (pair? being-moved) (car (last being-moved))) + (match being-moved + (() (match to-move + (() (reverse moved)) + (((and s+d (s . d)) . t1) + (if (or (eqv? s d) ; idempotent + (not s)) ; src is a constant and can be loaded directly + (loop t1 '() moved #f) + (loop t1 (list s+d) moved s))))) + (((and s+d (s . d)) . b) + (match (split-move to-move d) + ((r . t1) (loop t1 (acons d r being-moved) moved last-source)) + (#f (match b + (() (loop to-move '() (cons s+d moved) #f)) + (_ (if (eqv? d last-source) + (loop to-move + (replace-last-source tmp b) + (cons s+d (acons d tmp moved)) + tmp) + (loop to-move b (cons s+d moved) last-source)))))))))) + +(define (allocate-slots fun) + (define (empty-live-set) + (cons #b0 '())) + + (define (add-live-variable sym slot live-set) + (cons (logior (car live-set) (ash 1 slot)) + (acons sym slot (cdr live-set)))) + + (define (remove-live-variable sym slot live-set) + (cons (logand (car live-set) (lognot (ash 1 slot))) + (acons sym #f (cdr live-set)))) + + (define (fold-live-set proc seed live-set) + (let lp ((bits (car live-set)) (clauses (cdr live-set)) (seed seed)) + (if (zero? bits) + seed + (match clauses + (((sym . slot) . clauses) + (if (and slot (logbit? slot bits)) + (lp (logand bits (lognot (ash 1 slot))) + clauses + (proc sym slot seed)) + (lp bits clauses seed))))))) + + (define (compute-slot live-set hint) + (if (and hint (not (logbit? hint (car live-set)))) + hint + (find-first-zero (car live-set)))) + + (define (compute-call-proc-slot live-set nlocals) + (+ 3 (find-first-trailing-zero (car live-set) nlocals))) + + (define dfg (compute-dfg fun #:global? #f)) + (define allocation (make-hash-table)) + + (define (visit-clause clause live-set) + (define nlocals (compute-slot live-set #f)) + (define nargs + (match clause + (($ $cont _ _ ($ $kclause _ ($ $cont _ _ ($ $kargs names syms)))) + (length syms)))) + + (define (allocate! sym k hint live-set) + (match (hashq-ref allocation sym) + (($ $allocation def slot dead has-const) + ;; Parallel move already allocated this one. + (if slot + (add-live-variable sym slot live-set) + live-set)) + (_ + (call-with-values (lambda () (find-constant-value sym dfg)) + (lambda (has-const? const) + (cond + ((and has-const? (not (constant-needs-allocation? sym const dfg))) + (hashq-set! allocation sym + (make-allocation k #f '() has-const? const)) + live-set) + (else + (let ((slot (compute-slot live-set hint))) + (when (>= slot nlocals) + (set! nlocals (+ slot 1))) + (hashq-set! allocation sym + (make-allocation k slot '() has-const? const)) + (add-live-variable sym slot live-set))))))))) + + (define (dead sym k live-set) + (match (lookup-allocation sym allocation) + ((and allocation ($ $allocation def slot dead has-const? const)) + (set-allocation-dead! allocation (cons k dead)) + (remove-live-variable sym slot live-set)))) + + (define (allocate-frame! k nargs live-set) + (let ((proc-slot (compute-call-proc-slot live-set nlocals))) + (set! nlocals (max nlocals (+ proc-slot 1 nargs))) + (hashq-set! allocation k + (make-cont-allocation + proc-slot + (match (hashq-ref allocation k) + (($ $cont-allocation #f moves) moves) + (#f #f)))) + live-set)) + + (define (parallel-move! src-k src-slots pre-live-set post-live-set dst-slots) + (let* ((tmp-slot (find-first-zero (logior (car pre-live-set) + (car post-live-set)))) + (moves (solve-parallel-move src-slots dst-slots tmp-slot))) + (when (and (>= tmp-slot nlocals) (assv tmp-slot moves)) + (set! nlocals (+ tmp-slot 1))) + (hashq-set! allocation src-k + (make-cont-allocation + (match (hashq-ref allocation src-k) + (($ $cont-allocation proc-slot #f) proc-slot) + (#f #f)) + moves)) + post-live-set)) + + (define (visit-cont cont label live-set) + (define (maybe-kill-definition sym live-set) + (if (and (lookup-slot sym allocation) (dead-after-def? sym dfg)) + (dead sym label live-set) + live-set)) + + (define (kill-conditionally-dead live-set) + (if (branch? label dfg) + (let ((branches (find-other-branches label dfg))) + (fold-live-set + (lambda (sym slot live-set) + (if (and (> slot nargs) + (dead-after-branch? sym label branches dfg)) + (dead sym label live-set) + live-set)) + live-set + live-set)) + live-set)) + + (match cont + (($ $kentry self tail clauses) + (let ((live-set (allocate! self label 0 live-set))) + (for-each (cut visit-cont <> label live-set) clauses)) + live-set) + + (($ $kclause arity ($ $cont k src body)) + (visit-cont body k live-set)) + + (($ $kargs names syms body) + (visit-term body label + (kill-conditionally-dead + (fold maybe-kill-definition + (fold (cut allocate! <> label #f <>) live-set syms) + syms)))) + + (($ $ktrunc) live-set) + (($ $kif) live-set))) + + (define (visit-term term label live-set) + (match term + (($ $letk conts body) + (let ((live-set (visit-term body label live-set))) + (for-each (match-lambda + (($ $cont k src cont) + (visit-cont cont k live-set))) + conts)) + live-set) + + (($ $continue k exp) + (visit-exp exp label k live-set)))) + + (define (visit-exp exp label k live-set) + (define (use sym live-set) + (if (and (lookup-slot sym allocation) (dead-after-use? sym k dfg)) + (dead sym k live-set) + live-set)) + + (match exp + (($ $var sym) + (use sym live-set)) + + (($ $call proc args) + (match (lookup-cont k (dfg-cont-table dfg)) + (($ $ktail) + (let ((tail-nlocals (1+ (length args)))) + (set! nlocals (max nlocals tail-nlocals)) + (parallel-move! label + (map (cut lookup-slot <> allocation) + (cons proc args)) + live-set (fold use live-set (cons proc args)) + (iota tail-nlocals)))) + (($ $ktrunc arity kargs) + (let* ((live-set + (fold use + (use proc + (allocate-frame! label (length args) live-set)) + args)) + (proc-slot (lookup-call-proc-slot label allocation)) + (dst-syms (lookup-bound-syms kargs dfg)) + (nvals (length dst-syms)) + (src-slots (map (cut + proc-slot 1 <>) (iota nvals))) + (live-set* (fold (cut allocate! <> kargs <> <>) + live-set dst-syms src-slots)) + (dst-slots (map (cut lookup-slot <> allocation) + dst-syms))) + (parallel-move! label src-slots live-set live-set* dst-slots))) + (else + (fold use + (use proc (allocate-frame! label (length args) live-set)) + args)))) + + (($ $primcall name args) + (fold use live-set args)) + + (($ $values args) + (let ((live-set* (fold use live-set args))) + (define (compute-dst-slots) + (match (lookup-cont k (dfg-cont-table dfg)) + (($ $ktail) + (let ((tail-nlocals (1+ (length args)))) + (set! nlocals (max nlocals tail-nlocals)) + (cdr (iota tail-nlocals)))) + (_ + (let* ((src-slots (map (cut lookup-slot <> allocation) args)) + (dst-syms (lookup-bound-syms k dfg)) + (dst-live-set (fold (cut allocate! <> k <> <>) + live-set* dst-syms src-slots))) + (map (cut lookup-slot <> allocation) dst-syms))))) + + (parallel-move! label + (map (cut lookup-slot <> allocation) args) + live-set live-set* + (compute-dst-slots)))) + + (($ $prompt escape? tag handler) + (use tag live-set)) + + (_ live-set))) + + (match clause + (($ $cont k _ body) + (visit-cont body k live-set) + (hashq-set! allocation k nlocals)))) + + (match fun + (($ $fun meta free ($ $cont k _ ($ $kentry self tail clauses))) + (let ((live-set (add-live-variable self 0 (empty-live-set)))) + (hashq-set! allocation self (make-allocation k 0 '() #f #f)) + (for-each (cut visit-clause <> live-set) clauses) + allocation)))) diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm index 38dc54d1c..493b54740 100644 --- a/module/language/cps/spec.scm +++ b/module/language/cps/spec.scm @@ -21,6 +21,7 @@ (define-module (language cps spec) #:use-module (system base language) #:use-module (language cps) + #:use-module (language cps compile-rtl) #:export (cps)) (define* (write-cps exp #:optional (port (current-output-port))) @@ -31,6 +32,6 @@ #:reader (lambda (port env) (read port)) #:printer write-cps #:parser parse-cps - #:compilers '() + #:compilers `((rtl . ,compile-rtl)) #:for-humans? #f ) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index fad64b796..c4e4d1f55 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -115,6 +115,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/receive.test \ tests/regexp.test \ tests/rtl.test \ + tests/rtl-compilation.test \ tests/session.test \ tests/signals.test \ tests/srcprop.test \ diff --git a/test-suite/tests/rtl-compilation.test b/test-suite/tests/rtl-compilation.test new file mode 100644 index 000000000..cf00a4f78 --- /dev/null +++ b/test-suite/tests/rtl-compilation.test @@ -0,0 +1,200 @@ +;;;; rtl-compilation.test --- test suite for compiling via rtl -*- scheme -*- +;;;; +;;;; Copyright (C) 2013 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 published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-suite rtl-compilation) + #:use-module (test-suite lib) + #:use-module (system base compile) + #:use-module (system vm objcode)) + +(define* (compile-via-rtl exp #:key peval? cse? (env (make-fresh-user-module))) + (load-thunk-from-memory + (compile exp #:env env #:to 'rtl + #:opts `(#:partial-eval? ,peval? #:cse? ,cse?)))) + +(define* (run-rtl exp #:key (env (make-fresh-user-module))) + (let ((thunk (compile-via-rtl exp #:env env))) + (save-module-excursion + (lambda () + (set-current-module env) + (thunk))))) + +(with-test-prefix "tail context" + (pass-if-equal 1 + (run-rtl '(let ((x 1)) x))) + + (pass-if-equal 1 + (run-rtl 1)) + + (pass-if-equal (if #f #f) + (run-rtl '(if #f #f))) + + (pass-if-equal "top-level define" + (list (if #f #f) 1) + (let ((mod (make-fresh-user-module))) + (let ((result (run-rtl '(define v 1) #:env mod))) + (list result (module-ref mod 'v))))) + + (pass-if-equal "top-level set!" + (list (if #f #f) 1) + (let ((mod (make-fresh-user-module))) + (module-define! mod 'v #f) + (let ((result (run-rtl '(set! v 1) #:env mod))) + (list result (module-ref mod 'v))))) + + (pass-if-equal "top-level apply [single value]" + 8 + (let ((mod (make-fresh-user-module))) + (module-define! mod 'args '(2 3)) + (run-rtl '(apply expt args) #:env mod))) + + (pass-if-equal "top-level apply [zero values]" + '() + (let ((mod (make-fresh-user-module))) + (module-define! mod 'proc (lambda () (values))) + (module-define! mod 'args '()) + (call-with-values + (lambda () (run-rtl '(apply proc args) #:env mod)) + list))) + + (pass-if-equal "top-level apply [two values]" + '(1 2) + (let ((mod (make-fresh-user-module))) + (module-define! mod 'proc (lambda (n d) (floor/ n d))) + (module-define! mod 'args '(5 3)) + (call-with-values + (lambda () (run-rtl '(apply proc args) #:env mod)) + list))) + + (pass-if-equal "call-with-values" + '(1 2 3) + ((run-rtl '(lambda (n d) + (call-with-values (lambda () (floor/ n d)) + (lambda (q r) (list q r (+ q r)))))) + 5 3)) + + (pass-if-equal cons + (run-rtl 'cons)) + + (pass-if-equal 1 + ((run-rtl '(lambda () 1)))) + + (pass-if-equal 1 + ((run-rtl '(lambda (x) 1)) 2)) + + (pass-if-equal 1 + ((run-rtl '(lambda (x) x)) 1)) + + (pass-if-equal 6 + ((((run-rtl '(lambda (x) + (lambda (y) + (lambda (z) + (+ x y z))))) 1) 2) 3)) + + (pass-if-equal 1 + (run-rtl '(identity 1))) + + (pass-if-equal '(1 . 2) + (run-rtl '(cons 1 2))) + + (pass-if-equal '(1 2) + (call-with-values (lambda () (run-rtl '(values 1 2))) list)) + + (pass-if-equal 28 + ((run-rtl '(lambda (x y z rest) (apply + x y z rest))) + 2 3 5 '(7 11))) + + ;; prompts + ) + +(with-test-prefix "value context" + 1 + ) + +(with-test-prefix "drop context" + 1 + ) + +(with-test-prefix "test context" + 1 + ) + +(with-test-prefix "values context" + (pass-if-equal '(3 . 1) + (run-rtl + '(let ((rat (lambda (n d) + (call-with-values + (lambda () (floor/ n d)) + (lambda (q r) + (cons q r)))))) + (rat 10 3))))) + +(with-test-prefix "contification" + (pass-if ((run-rtl '(lambda (x) + (define (even? x) + (if (null? x) #t (odd? (cdr x)))) + (define (odd? x) + (if (null? x) #f (even? (cdr x)))) + (even? x))) + '(1 2 3 4))) + + (pass-if (not ((run-rtl '(lambda (x) + (define (even? x) + (if (null? x) #t (odd? (cdr x)))) + (define (odd? x) + (if (null? x) #f (even? (cdr x)))) + (even? x))) + '(1 2 3))))) + +(with-test-prefix "case-lambda" + (pass-if-equal "simple" + '(0 3 9 28) + (let ((proc (run-rtl '(case-lambda + (() 0) + ((x) x) + ((x y) (+ x y)) + ((x y z . rest) (apply + x y z rest)))))) + (map (lambda (args) (apply proc args)) + '(() (3) (2 7) (2 3 5 7 11))))) + + (pass-if-exception "no match" + exception:wrong-num-args + ((run-rtl '(case-lambda ((x) x) ((x y) (+ x y)))) + 1 2 3)) + + (pass-if-exception "zero clauses called with no args" + exception:wrong-num-args + ((run-rtl '(case-lambda)))) + + (pass-if-exception "zero clauses called with args" + exception:wrong-num-args + ((run-rtl '(case-lambda)) 1))) + +(with-test-prefix "mixed contexts" + (pass-if-equal "sequences" '(3 4 5) + (let* ((pair (cons 1 2)) + (result ((run-rtl '(lambda (pair) + (set-car! pair 3) + (set-cdr! pair 4) + 5)) + pair))) + (list (car pair) + (cdr pair) + result))) + + (pass-if-equal "mutable lexicals" 2 + (run-rtl '(let ((n 1)) (set! n 2) n)))) |