Commit | Line | Data |
---|---|---|
934e6b95 AW |
1 | ;;; Continuation-passing style (CPS) intermediate language (IL) |
2 | ||
e87f0593 | 3 | ;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. |
934e6b95 AW |
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) | |
cf8bb037 | 36 | (let-fresh (kbox) (module-var name-var public?-var bound?-var box) |
934e6b95 | 37 | (build-cps-term |
cf8bb037 AW |
38 | ($letconst (('module module-var module) |
39 | ('name name-var name) | |
40 | ('public? public?-var public?) | |
41 | ('bound? bound?-var bound?)) | |
6e422a35 AW |
42 | ($letk ((kbox ($kargs ('box) (box) ,(val-proc box)))) |
43 | ($continue kbox src | |
934e6b95 | 44 | ($primcall 'cached-module-box |
cf8bb037 | 45 | (module-var name-var public?-var bound?-var)))))))) |
934e6b95 | 46 | |
11eff826 AW |
47 | (define (primitive-module name) |
48 | (case name | |
e87f0593 AW |
49 | ((bytevector? |
50 | bytevector-length | |
a104380d AW |
51 | |
52 | bytevector-u8-ref bytevector-u8-set! | |
11eff826 AW |
53 | bytevector-s8-ref bytevector-s8-set! |
54 | ||
55 | bytevector-u16-ref bytevector-u16-set! | |
56 | bytevector-u16-native-ref bytevector-u16-native-set! | |
57 | bytevector-s16-ref bytevector-s16-set! | |
58 | bytevector-s16-native-ref bytevector-s16-native-set! | |
59 | ||
60 | bytevector-u32-ref bytevector-u32-set! | |
61 | bytevector-u32-native-ref bytevector-u32-native-set! | |
62 | bytevector-s32-ref bytevector-s32-set! | |
63 | bytevector-s32-native-ref bytevector-s32-native-set! | |
64 | ||
65 | bytevector-u64-ref bytevector-u64-set! | |
66 | bytevector-u64-native-ref bytevector-u64-native-set! | |
67 | bytevector-s64-ref bytevector-s64-set! | |
68 | bytevector-s64-native-ref bytevector-s64-native-set! | |
69 | ||
70 | bytevector-ieee-single-ref bytevector-ieee-single-set! | |
71 | bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! | |
72 | bytevector-ieee-double-ref bytevector-ieee-double-set! | |
73 | bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!) | |
74 | '(rnrs bytevectors)) | |
4d6a7ac6 | 75 | ((class-of) '(oop goops)) |
11eff826 AW |
76 | (else '(guile)))) |
77 | ||
6e422a35 | 78 | (define (primitive-ref name k src) |
11eff826 | 79 | (module-box #f (primitive-module name) name #f #t |
934e6b95 AW |
80 | (lambda (box) |
81 | (build-cps-term | |
6e422a35 | 82 | ($continue k src ($primcall 'box-ref (box))))))) |
934e6b95 | 83 | |
6e422a35 | 84 | (define (builtin-ref idx k src) |
cf8bb037 | 85 | (let-fresh () (idx-var) |
486013d6 | 86 | (build-cps-term |
cf8bb037 | 87 | ($letconst (('idx idx-var idx)) |
6e422a35 | 88 | ($continue k src |
cf8bb037 | 89 | ($primcall 'builtin-ref (idx-var))))))) |
486013d6 | 90 | |
934e6b95 | 91 | (define (reify-clause ktail) |
828ed944 | 92 | (let-fresh (kclause kbody kthrow) (wna false str eol throw) |
934e6b95 | 93 | (build-cps-cont |
6e422a35 AW |
94 | (kclause ($kclause ('() '() #f '() #f) |
95 | (kbody | |
96 | ($kargs () () | |
97 | ($letconst (('wna wna 'wrong-number-of-args) | |
98 | ('false false #f) | |
99 | ('str str "Wrong number of arguments") | |
100 | ('eol eol '())) | |
101 | ($letk ((kthrow | |
102 | ($kargs ('throw) (throw) | |
103 | ($continue ktail #f | |
104 | ($call throw | |
105 | (wna false str eol false)))))) | |
90dce16d AW |
106 | ,(primitive-ref 'throw kthrow #f))))) |
107 | ,#f))))) | |
934e6b95 | 108 | |
cf8bb037 AW |
109 | (define (reify-primitives/1 fun single-value-conts) |
110 | (define (visit-clause cont) | |
111 | (rewrite-cps-cont cont | |
112 | (($ $cont label ($ $kclause arity body alternate)) | |
113 | (label ($kclause ,arity ,(visit-cont body) | |
114 | ,(and alternate (visit-clause alternate))))))) | |
115 | (define (visit-cont cont) | |
116 | (rewrite-cps-cont cont | |
117 | (($ $cont label ($ $kargs (name) (var) body)) | |
118 | ,(begin | |
119 | (bitvector-set! single-value-conts label #t) | |
120 | (build-cps-cont | |
121 | (label ($kargs (name) (var) ,(visit-term body)))))) | |
122 | (($ $cont label ($ $kargs names vars body)) | |
123 | (label ($kargs names vars ,(visit-term body)))) | |
124 | (($ $cont) | |
125 | ,cont))) | |
126 | (define (visit-term term) | |
127 | (match term | |
128 | (($ $letk conts body) | |
129 | ;; Visit continuations before their uses. | |
130 | (let ((conts (map visit-cont conts))) | |
131 | (build-cps-term | |
132 | ($letk ,conts ,(visit-term body))))) | |
133 | (($ $continue k src exp) | |
134 | (match exp | |
135 | (($ $prim name) | |
136 | (if (bitvector-ref single-value-conts k) | |
137 | (cond | |
138 | ((builtin-name->index name) | |
139 | => (lambda (idx) | |
140 | (builtin-ref idx k src))) | |
141 | (else (primitive-ref name k src))) | |
a9ec16f9 AW |
142 | (build-cps-term ($continue k src |
143 | ($const *unspecified*))))) | |
cf8bb037 AW |
144 | (($ $primcall 'call-thunk/no-inline (proc)) |
145 | (build-cps-term | |
146 | ($continue k src ($call proc ())))) | |
147 | (($ $primcall name args) | |
148 | (cond | |
149 | ((or (prim-instruction name) (branching-primitive? name)) | |
150 | ;; Assume arities are correct. | |
151 | term) | |
152 | (else | |
153 | (let-fresh (k*) (v) | |
154 | (build-cps-term | |
155 | ($letk ((k* ($kargs (v) (v) | |
156 | ($continue k src ($call v args))))) | |
157 | ,(cond | |
158 | ((builtin-name->index name) | |
159 | => (lambda (idx) | |
160 | (builtin-ref idx k* src))) | |
161 | (else (primitive-ref name k* src))))))))) | |
162 | (_ term))))) | |
163 | ||
164 | (rewrite-cps-cont fun | |
165 | (($ $cont label ($ $kfun src meta self (and tail ($ $cont ktail)) #f)) | |
166 | ;; A case-lambda with no clauses. Reify a clause. | |
167 | (label ($kfun src meta self ,tail ,(reify-clause ktail)))) | |
168 | (($ $cont label ($ $kfun src meta self tail clause)) | |
169 | (label ($kfun src meta self ,tail ,(visit-clause clause)))))) | |
170 | ||
171 | (define (reify-primitives term) | |
172 | (with-fresh-name-state term | |
173 | (let ((single-value-conts (make-bitvector (label-counter) #f))) | |
174 | (rewrite-cps-term term | |
175 | (($ $program procs) | |
176 | ($program ,(map (lambda (cont) | |
177 | (reify-primitives/1 cont single-value-conts)) | |
178 | procs))))))) |