Commit | Line | Data |
---|---|---|
4c906ad5 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 | ;;; | |
691697de AW |
21 | ;;; Some bytecode operations can encode an immediate as an operand. |
22 | ;;; This pass tranforms generic primcalls to these specialized | |
23 | ;;; primcalls, if possible. | |
4c906ad5 AW |
24 | ;;; |
25 | ;;; Code: | |
26 | ||
27 | (define-module (language cps specialize-primcalls) | |
28 | #:use-module (ice-9 match) | |
29 | #:use-module (language cps) | |
30 | #:use-module (language cps dfg) | |
31 | #:export (specialize-primcalls)) | |
32 | ||
33 | (define (specialize-primcalls fun) | |
34 | (let ((dfg (compute-dfg fun #:global? #t))) | |
35 | (define (immediate-u8? sym) | |
36 | (call-with-values (lambda () (find-constant-value sym dfg)) | |
37 | (lambda (has-const? val) | |
38 | (and has-const? (integer? val) (exact? val) (<= 0 val 255))))) | |
39 | (define (visit-cont cont) | |
40 | (rewrite-cps-cont cont | |
41 | (($ $cont sym ($ $kargs names syms body)) | |
42 | (sym ($kargs names syms ,(visit-term body)))) | |
43 | (($ $cont sym ($ $kentry self tail clauses)) | |
44 | (sym ($kentry self ,tail ,(map visit-cont clauses)))) | |
45 | (($ $cont sym ($ $kclause arity body)) | |
46 | (sym ($kclause ,arity ,(visit-cont body)))) | |
47 | (($ $cont) | |
48 | ,cont))) | |
49 | (define (visit-term term) | |
50 | (rewrite-cps-term term | |
51 | (($ $letk conts body) | |
52 | ($letk ,(map visit-cont conts) | |
53 | ,(visit-term body))) | |
54 | (($ $letrec names syms funs body) | |
55 | ($letrec names syms (map visit-fun funs) | |
56 | ,(visit-term body))) | |
57 | (($ $continue k src (and fun ($ $fun))) | |
58 | ($continue k src ,(visit-fun fun))) | |
59 | (($ $continue k src ($ $primcall name args)) | |
60 | ,(visit-primcall k src name args)) | |
61 | (($ $continue) | |
62 | ,term))) | |
63 | (define (visit-primcall k src name args) | |
691697de | 64 | ;; If we introduce a VM op from a primcall without a VM op, we |
4c906ad5 AW |
65 | ;; will need to ensure that the return arity matches. Rely on the |
66 | ;; elide-values pass to clean up. | |
67 | (define-syntax-rule (adapt-void exp) | |
68 | (let-gensyms (k* val kvoid) | |
69 | (build-cps-term | |
70 | ($letk ((k* ($kargs ('val) (val) | |
71 | ($continue k src ($primcall 'values (val))))) | |
72 | (kvoid ($kargs () () | |
73 | ($continue k* src ($void))))) | |
74 | ($continue kvoid src exp))))) | |
75 | (define-syntax-rule (adapt-val exp) | |
76 | (let-gensyms (k* val) | |
77 | (build-cps-term | |
78 | ($letk ((k* ($kargs ('val) (val) | |
79 | ($continue k src ($primcall 'values (val)))))) | |
80 | ($continue k* src exp))))) | |
81 | (match (cons name args) | |
82 | (('make-vector (? immediate-u8? n) init) | |
83 | (adapt-val ($primcall 'make-vector/immediate (n init)))) | |
84 | (('vector-ref v (? immediate-u8? n)) | |
85 | (build-cps-term | |
86 | ($continue k src ($primcall 'vector-ref/immediate (v n))))) | |
87 | (('vector-set! v (? immediate-u8? n) x) | |
88 | (build-cps-term | |
89 | ($continue k src ($primcall 'vector-set!/immediate (v n x))))) | |
90 | (('allocate-struct v (? immediate-u8? n)) | |
91 | (adapt-val ($primcall 'allocate-struct/immediate (v n)))) | |
92 | (('struct-ref s (? immediate-u8? n)) | |
93 | (adapt-val ($primcall 'struct-ref/immediate (s n)))) | |
94 | (('struct-set! s (? immediate-u8? n) x) | |
95 | ;; Unhappily, and undocumentedly, struct-set! returns the value | |
96 | ;; that was set. There is code that relies on this. Hackety | |
97 | ;; hack... | |
98 | (let-gensyms (k*) | |
99 | (build-cps-term | |
100 | ($letk ((k* ($kargs () () | |
101 | ($continue k src ($primcall 'values (x)))))) | |
102 | ($continue k* src ($primcall 'struct-set!/immediate (s n x))))))) | |
103 | (_ | |
104 | (build-cps-term ($continue k src ($primcall name args)))))) | |
105 | ||
106 | (define (visit-fun fun) | |
107 | (rewrite-cps-exp fun | |
108 | (($ $fun src meta free body) | |
109 | ($fun src meta free ,(visit-cont body))))) | |
110 | ||
111 | (visit-fun fun))) |