Commit | Line | Data |
---|---|---|
934e6b95 AW |
1 | ;;; Continuation-passing style (CPS) intermediate language (IL) |
2 | ||
a104380d | 3 | ;; Copyright (C) 2013, 2014 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) | |
828ed944 | 36 | (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box) |
934e6b95 AW |
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 | |
a104380d AW |
49 | ((bytevector-length |
50 | ||
51 | bytevector-u8-ref bytevector-u8-set! | |
11eff826 AW |
52 | bytevector-s8-ref bytevector-s8-set! |
53 | ||
54 | bytevector-u16-ref bytevector-u16-set! | |
55 | bytevector-u16-native-ref bytevector-u16-native-set! | |
56 | bytevector-s16-ref bytevector-s16-set! | |
57 | bytevector-s16-native-ref bytevector-s16-native-set! | |
58 | ||
59 | bytevector-u32-ref bytevector-u32-set! | |
60 | bytevector-u32-native-ref bytevector-u32-native-set! | |
61 | bytevector-s32-ref bytevector-s32-set! | |
62 | bytevector-s32-native-ref bytevector-s32-native-set! | |
63 | ||
64 | bytevector-u64-ref bytevector-u64-set! | |
65 | bytevector-u64-native-ref bytevector-u64-native-set! | |
66 | bytevector-s64-ref bytevector-s64-set! | |
67 | bytevector-s64-native-ref bytevector-s64-native-set! | |
68 | ||
69 | bytevector-ieee-single-ref bytevector-ieee-single-set! | |
70 | bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! | |
71 | bytevector-ieee-double-ref bytevector-ieee-double-set! | |
72 | bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!) | |
73 | '(rnrs bytevectors)) | |
4d6a7ac6 | 74 | ((class-of) '(oop goops)) |
11eff826 AW |
75 | (else '(guile)))) |
76 | ||
6e422a35 | 77 | (define (primitive-ref name k src) |
11eff826 | 78 | (module-box #f (primitive-module name) name #f #t |
934e6b95 AW |
79 | (lambda (box) |
80 | (build-cps-term | |
6e422a35 | 81 | ($continue k src ($primcall 'box-ref (box))))))) |
934e6b95 | 82 | |
6e422a35 | 83 | (define (builtin-ref idx k src) |
828ed944 | 84 | (let-fresh () (idx-sym) |
486013d6 AW |
85 | (build-cps-term |
86 | ($letconst (('idx idx-sym idx)) | |
6e422a35 | 87 | ($continue k src |
486013d6 AW |
88 | ($primcall 'builtin-ref (idx-sym))))))) |
89 | ||
934e6b95 | 90 | (define (reify-clause ktail) |
828ed944 | 91 | (let-fresh (kclause kbody kthrow) (wna false str eol throw) |
934e6b95 | 92 | (build-cps-cont |
6e422a35 AW |
93 | (kclause ($kclause ('() '() #f '() #f) |
94 | (kbody | |
95 | ($kargs () () | |
96 | ($letconst (('wna wna 'wrong-number-of-args) | |
97 | ('false false #f) | |
98 | ('str str "Wrong number of arguments") | |
99 | ('eol eol '())) | |
100 | ($letk ((kthrow | |
101 | ($kargs ('throw) (throw) | |
102 | ($continue ktail #f | |
103 | ($call throw | |
104 | (wna false str eol false)))))) | |
105 | ,(primitive-ref 'throw kthrow #f)))))))))) | |
934e6b95 AW |
106 | |
107 | ;; FIXME: Operate on one function at a time, for efficiency. | |
108 | (define (reify-primitives fun) | |
828ed944 AW |
109 | (with-fresh-name-state fun |
110 | (let ((conts (build-cont-table fun))) | |
111 | (define (visit-fun term) | |
112 | (rewrite-cps-exp term | |
113 | (($ $fun src meta free body) | |
114 | ($fun src meta free ,(visit-cont body))))) | |
115 | (define (visit-cont cont) | |
116 | (rewrite-cps-cont cont | |
117 | (($ $cont sym ($ $kargs names syms body)) | |
118 | (sym ($kargs names syms ,(visit-term body)))) | |
119 | (($ $cont sym ($ $kentry self (and tail ($ $cont ktail)) ())) | |
120 | ;; A case-lambda with no clauses. Reify a clause. | |
121 | (sym ($kentry self ,tail (,(reify-clause ktail))))) | |
122 | (($ $cont sym ($ $kentry self tail clauses)) | |
123 | (sym ($kentry self ,tail ,(map visit-cont clauses)))) | |
124 | (($ $cont sym ($ $kclause arity body)) | |
125 | (sym ($kclause ,arity ,(visit-cont body)))) | |
126 | (($ $cont) | |
127 | ,cont))) | |
128 | (define (visit-term term) | |
129 | (rewrite-cps-term term | |
130 | (($ $letk conts body) | |
131 | ($letk ,(map visit-cont conts) ,(visit-term body))) | |
132 | (($ $continue k src exp) | |
133 | ,(match exp | |
134 | (($ $prim name) | |
135 | (match (lookup-cont k conts) | |
136 | (($ $kargs (_)) | |
137 | (cond | |
138 | ((builtin-name->index name) | |
139 | => (lambda (idx) | |
140 | (builtin-ref idx k src))) | |
141 | (else (primitive-ref name k src)))) | |
142 | (_ (build-cps-term ($continue k src ($void)))))) | |
143 | (($ $fun) | |
144 | (build-cps-term ($continue k src ,(visit-fun exp)))) | |
145 | (($ $primcall 'call-thunk/no-inline (proc)) | |
146 | (build-cps-term | |
147 | ($continue k src ($call proc ())))) | |
148 | (($ $primcall name args) | |
149 | (cond | |
150 | ((or (prim-instruction name) (branching-primitive? name)) | |
151 | ;; Assume arities are correct. | |
152 | term) | |
153 | (else | |
154 | (let-fresh (k*) (v) | |
155 | (build-cps-term | |
156 | ($letk ((k* ($kargs (v) (v) | |
157 | ($continue k src ($call v args))))) | |
158 | ,(cond | |
159 | ((builtin-name->index name) | |
160 | => (lambda (idx) | |
161 | (builtin-ref idx k* src))) | |
162 | (else (primitive-ref name k* src))))))))) | |
163 | (_ term))))) | |
164 | ||
165 | (visit-fun fun)))) |