Commit | Line | Data |
---|---|---|
4c906ad5 AW |
1 | ;;; Continuation-passing style (CPS) intermediate language (IL) |
2 | ||
a9ec16f9 | 3 | ;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. |
4c906ad5 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 | ;;; | |
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) | |
a0329d01 | 34 | (let ((dfg (compute-dfg fun #:global? #t))) |
3e1b97c1 | 35 | (with-fresh-name-state-from-dfg dfg |
828ed944 AW |
36 | (define (immediate-u8? sym) |
37 | (call-with-values (lambda () (find-constant-value sym dfg)) | |
38 | (lambda (has-const? val) | |
39 | (and has-const? (integer? val) (exact? val) (<= 0 val 255))))) | |
40 | (define (visit-cont cont) | |
41 | (rewrite-cps-cont cont | |
42 | (($ $cont sym ($ $kargs names syms body)) | |
43 | (sym ($kargs names syms ,(visit-term body)))) | |
8320f504 AW |
44 | (($ $cont sym ($ $kfun src meta self tail clause)) |
45 | (sym ($kfun src meta self ,tail | |
24b611e8 | 46 | ,(and clause (visit-cont clause))))) |
90dce16d AW |
47 | (($ $cont sym ($ $kclause arity body alternate)) |
48 | (sym ($kclause ,arity ,(visit-cont body) | |
49 | ,(and alternate (visit-cont alternate))))) | |
828ed944 AW |
50 | (($ $cont) |
51 | ,cont))) | |
52 | (define (visit-term term) | |
53 | (rewrite-cps-term term | |
54 | (($ $letk conts body) | |
55 | ($letk ,(map visit-cont conts) | |
56 | ,(visit-term body))) | |
57 | (($ $letrec names syms funs body) | |
58 | ($letrec names syms (map visit-fun funs) | |
59 | ,(visit-term body))) | |
60 | (($ $continue k src (and fun ($ $fun))) | |
61 | ($continue k src ,(visit-fun fun))) | |
62 | (($ $continue k src ($ $primcall name args)) | |
63 | ,(visit-primcall k src name args)) | |
64 | (($ $continue) | |
65 | ,term))) | |
66 | (define (visit-primcall k src name args) | |
67 | ;; If we introduce a VM op from a primcall without a VM op, we | |
68 | ;; will need to ensure that the return arity matches. Rely on the | |
69 | ;; elide-values pass to clean up. | |
70 | (define-syntax-rule (adapt-void exp) | |
71 | (let-fresh (k* kvoid) (val) | |
72 | (build-cps-term | |
73 | ($letk ((k* ($kargs ('val) (val) | |
74 | ($continue k src ($primcall 'values (val))))) | |
75 | (kvoid ($kargs () () | |
a9ec16f9 | 76 | ($continue k* src ($const *unspecified*))))) |
828ed944 AW |
77 | ($continue kvoid src exp))))) |
78 | (define-syntax-rule (adapt-val exp) | |
79 | (let-fresh (k*) (val) | |
80 | (build-cps-term | |
81 | ($letk ((k* ($kargs ('val) (val) | |
82 | ($continue k src ($primcall 'values (val)))))) | |
83 | ($continue k* src exp))))) | |
84 | (match (cons name args) | |
85 | (('make-vector (? immediate-u8? n) init) | |
86 | (adapt-val ($primcall 'make-vector/immediate (n init)))) | |
87 | (('vector-ref v (? immediate-u8? n)) | |
4c906ad5 | 88 | (build-cps-term |
828ed944 AW |
89 | ($continue k src ($primcall 'vector-ref/immediate (v n))))) |
90 | (('vector-set! v (? immediate-u8? n) x) | |
91 | (build-cps-term | |
92 | ($continue k src ($primcall 'vector-set!/immediate (v n x))))) | |
93 | (('allocate-struct v (? immediate-u8? n)) | |
94 | (adapt-val ($primcall 'allocate-struct/immediate (v n)))) | |
95 | (('struct-ref s (? immediate-u8? n)) | |
96 | (adapt-val ($primcall 'struct-ref/immediate (s n)))) | |
97 | (('struct-set! s (? immediate-u8? n) x) | |
e2fafeb9 AW |
98 | (build-cps-term |
99 | ($continue k src ($primcall 'struct-set!/immediate (s n x))))) | |
828ed944 AW |
100 | (_ |
101 | (build-cps-term ($continue k src ($primcall name args)))))) | |
4c906ad5 | 102 | |
828ed944 AW |
103 | (define (visit-fun fun) |
104 | (rewrite-cps-exp fun | |
24b611e8 AW |
105 | (($ $fun free body) |
106 | ($fun free ,(visit-cont body))))) | |
4c906ad5 | 107 | |
a0329d01 | 108 | (visit-cont fun)))) |