Commit | Line | Data |
---|---|---|
934e6b95 AW |
1 | ;;; Continuation-passing style (CPS) intermediate language (IL) |
2 | ||
3 | ;; Copyright (C) 2013 Free Software Foundation, Inc. | |
4 | ||
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | ;;; Commentary: | |
20 | ;;; | |
21 | ;;; A pass to reify lone $prim's that were never folded into a | |
22 | ;;; $primcall, and $primcall's to primitives that don't have a | |
23 | ;;; corresponding VM op. | |
24 | ;;; | |
25 | ;;; Code: | |
26 | ||
27 | (define-module (language cps reify-primitives) | |
28 | #:use-module (ice-9 match) | |
29 | #:use-module (language cps) | |
30 | #:use-module (language cps dfg) | |
31 | #:use-module (language cps primitives) | |
691697de | 32 | #:use-module (language bytecode) |
934e6b95 AW |
33 | #:export (reify-primitives)) |
34 | ||
35 | (define (module-box src module name public? bound? val-proc) | |
36 | (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box) | |
37 | (build-cps-term | |
38 | ($letconst (('module module-sym module) | |
39 | ('name name-sym name) | |
40 | ('public? public?-sym public?) | |
41 | ('bound? bound?-sym bound?)) | |
6e422a35 AW |
42 | ($letk ((kbox ($kargs ('box) (box) ,(val-proc box)))) |
43 | ($continue kbox src | |
934e6b95 AW |
44 | ($primcall 'cached-module-box |
45 | (module-sym name-sym public?-sym bound?-sym)))))))) | |
46 | ||
11eff826 AW |
47 | (define (primitive-module name) |
48 | (case name | |
49 | ((bytevector-u8-ref bytevector-u8-set! | |
50 | bytevector-s8-ref bytevector-s8-set! | |
51 | ||
52 | bytevector-u16-ref bytevector-u16-set! | |
53 | bytevector-u16-native-ref bytevector-u16-native-set! | |
54 | bytevector-s16-ref bytevector-s16-set! | |
55 | bytevector-s16-native-ref bytevector-s16-native-set! | |
56 | ||
57 | bytevector-u32-ref bytevector-u32-set! | |
58 | bytevector-u32-native-ref bytevector-u32-native-set! | |
59 | bytevector-s32-ref bytevector-s32-set! | |
60 | bytevector-s32-native-ref bytevector-s32-native-set! | |
61 | ||
62 | bytevector-u64-ref bytevector-u64-set! | |
63 | bytevector-u64-native-ref bytevector-u64-native-set! | |
64 | bytevector-s64-ref bytevector-s64-set! | |
65 | bytevector-s64-native-ref bytevector-s64-native-set! | |
66 | ||
67 | bytevector-ieee-single-ref bytevector-ieee-single-set! | |
68 | bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! | |
69 | bytevector-ieee-double-ref bytevector-ieee-double-set! | |
70 | bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!) | |
71 | '(rnrs bytevectors)) | |
4d6a7ac6 | 72 | ((class-of) '(oop goops)) |
11eff826 AW |
73 | (else '(guile)))) |
74 | ||
6e422a35 | 75 | (define (primitive-ref name k src) |
11eff826 | 76 | (module-box #f (primitive-module name) name #f #t |
934e6b95 AW |
77 | (lambda (box) |
78 | (build-cps-term | |
6e422a35 | 79 | ($continue k src ($primcall 'box-ref (box))))))) |
934e6b95 | 80 | |
6e422a35 | 81 | (define (builtin-ref idx k src) |
486013d6 AW |
82 | (let-gensyms (idx-sym) |
83 | (build-cps-term | |
84 | ($letconst (('idx idx-sym idx)) | |
6e422a35 | 85 | ($continue k src |
486013d6 AW |
86 | ($primcall 'builtin-ref (idx-sym))))))) |
87 | ||
934e6b95 AW |
88 | (define (reify-clause ktail) |
89 | (let-gensyms (kclause kbody wna false str eol kthrow throw) | |
90 | (build-cps-cont | |
6e422a35 AW |
91 | (kclause ($kclause ('() '() #f '() #f) |
92 | (kbody | |
93 | ($kargs () () | |
94 | ($letconst (('wna wna 'wrong-number-of-args) | |
95 | ('false false #f) | |
96 | ('str str "Wrong number of arguments") | |
97 | ('eol eol '())) | |
98 | ($letk ((kthrow | |
99 | ($kargs ('throw) (throw) | |
100 | ($continue ktail #f | |
101 | ($call throw | |
102 | (wna false str eol false)))))) | |
103 | ,(primitive-ref 'throw kthrow #f)))))))))) | |
934e6b95 AW |
104 | |
105 | ;; FIXME: Operate on one function at a time, for efficiency. | |
106 | (define (reify-primitives fun) | |
107 | (let ((conts (build-cont-table fun))) | |
108 | (define (visit-fun term) | |
109 | (rewrite-cps-exp term | |
6e422a35 AW |
110 | (($ $fun src meta free body) |
111 | ($fun src meta free ,(visit-cont body))))) | |
934e6b95 AW |
112 | (define (visit-cont cont) |
113 | (rewrite-cps-cont cont | |
6e422a35 AW |
114 | (($ $cont sym ($ $kargs names syms body)) |
115 | (sym ($kargs names syms ,(visit-term body)))) | |
116 | (($ $cont sym ($ $kentry self (and tail ($ $cont ktail)) ())) | |
934e6b95 | 117 | ;; A case-lambda with no clauses. Reify a clause. |
6e422a35 AW |
118 | (sym ($kentry self ,tail (,(reify-clause ktail))))) |
119 | (($ $cont sym ($ $kentry self tail clauses)) | |
120 | (sym ($kentry self ,tail ,(map visit-cont clauses)))) | |
121 | (($ $cont sym ($ $kclause arity body)) | |
122 | (sym ($kclause ,arity ,(visit-cont body)))) | |
934e6b95 AW |
123 | (($ $cont) |
124 | ,cont))) | |
125 | (define (visit-term term) | |
126 | (rewrite-cps-term term | |
127 | (($ $letk conts body) | |
128 | ($letk ,(map visit-cont conts) ,(visit-term body))) | |
6e422a35 | 129 | (($ $continue k src exp) |
934e6b95 AW |
130 | ,(match exp |
131 | (($ $prim name) | |
132 | (match (lookup-cont k conts) | |
486013d6 AW |
133 | (($ $kargs (_)) |
134 | (cond | |
135 | ((builtin-name->index name) | |
136 | => (lambda (idx) | |
6e422a35 AW |
137 | (builtin-ref idx k src))) |
138 | (else (primitive-ref name k src)))) | |
139 | (_ (build-cps-term ($continue k src ($void)))))) | |
934e6b95 | 140 | (($ $fun) |
6e422a35 | 141 | (build-cps-term ($continue k src ,(visit-fun exp)))) |
5bd4b658 AW |
142 | (($ $primcall 'call-thunk/no-inline (proc)) |
143 | (build-cps-term | |
6e422a35 | 144 | ($continue k src ($call proc ())))) |
934e6b95 AW |
145 | (($ $primcall name args) |
146 | (cond | |
691697de | 147 | ((or (prim-instruction name) (branching-primitive? name)) |
934e6b95 AW |
148 | ;; Assume arities are correct. |
149 | term) | |
150 | (else | |
151 | (let-gensyms (k* v) | |
152 | (build-cps-term | |
6e422a35 AW |
153 | ($letk ((k* ($kargs (v) (v) |
154 | ($continue k src ($call v args))))) | |
486013d6 AW |
155 | ,(cond |
156 | ((builtin-name->index name) | |
157 | => (lambda (idx) | |
6e422a35 AW |
158 | (builtin-ref idx k* src))) |
159 | (else (primitive-ref name k* src))))))))) | |
934e6b95 AW |
160 | (_ term))))) |
161 | ||
162 | (visit-fun fun))) |