1 ;;; Continuation-passing style (CPS) intermediate language (IL)
3 ;; Copyright (C) 2013 Free Software Foundation, Inc.
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.
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.
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
21 ;;; Some bytecode operations can encode an immediate as an operand.
22 ;;; This pass tranforms generic primcalls to these specialized
23 ;;; primcalls, if possible.
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))
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))))
49 (define (visit-term term)
50 (rewrite-cps-term term
52 ($letk ,(map visit-cont conts)
54 (($ $letrec names syms funs body)
55 ($letrec names syms (map visit-fun funs)
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))
63 (define (visit-primcall k src name args)
64 ;; If we introduce a VM op from a primcall without a VM op, we
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)
70 ($letk ((k* ($kargs ('val) (val)
71 ($continue k src ($primcall 'values (val)))))
73 ($continue k* src ($void)))))
74 ($continue kvoid src exp)))))
75 (define-syntax-rule (adapt-val exp)
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))
86 ($continue k src ($primcall 'vector-ref/immediate (v n)))))
87 (('vector-set! v (? immediate-u8? n) x)
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
100 ($letk ((k* ($kargs () ()
101 ($continue k src ($primcall 'values (x))))))
102 ($continue k* src ($primcall 'struct-set!/immediate (s n x)))))))
104 (build-cps-term ($continue k src ($primcall name args))))))
106 (define (visit-fun fun)
108 (($ $fun src meta free body)
109 ($fun src meta free ,(visit-cont body)))))