X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/ae9c16e89565f997936778a710d5addf1ec256c2..a9ec16f9c5574d80f66c173b495285579f5894b4:/module/language/cps/specialize-primcalls.scm

diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm
dissimilarity index 75%
index 8e2f38fd0..cb5a70d89 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -1,111 +1,108 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-;;; Commentary:
-;;;
-;;; Some RTL operations can encode an immediate as an operand.  This
-;;; pass tranforms generic primcalls to these specialized primcalls, if
-;;; possible.
-;;;
-;;; Code:
-
-(define-module (language cps specialize-primcalls)
-  #:use-module (ice-9 match)
-  #:use-module (language cps)
-  #:use-module (language cps dfg)
-  #:export (specialize-primcalls))
-
-(define (specialize-primcalls fun)
-  (let ((dfg (compute-dfg fun #:global? #t)))
-    (define (immediate-u8? sym)
-      (call-with-values (lambda () (find-constant-value sym dfg))
-        (lambda (has-const? val)
-          (and has-const? (integer? val) (exact? val) (<= 0 val 255)))))
-    (define (visit-cont cont)
-      (rewrite-cps-cont cont
-        (($ $cont sym ($ $kargs names syms body))
-         (sym ($kargs names syms ,(visit-term body))))
-        (($ $cont sym ($ $kentry self tail clauses))
-         (sym ($kentry self ,tail ,(map visit-cont clauses))))
-        (($ $cont sym ($ $kclause arity body))
-         (sym ($kclause ,arity ,(visit-cont body))))
-        (($ $cont)
-         ,cont)))
-    (define (visit-term term)
-      (rewrite-cps-term term
-        (($ $letk conts body)
-         ($letk ,(map visit-cont conts)
-           ,(visit-term body)))
-        (($ $letrec names syms funs body)
-         ($letrec names syms (map visit-fun funs)
-                  ,(visit-term body)))
-        (($ $continue k src (and fun ($ $fun)))
-         ($continue k src ,(visit-fun fun)))
-        (($ $continue k src ($ $primcall name args))
-         ,(visit-primcall k src name args))
-        (($ $continue)
-         ,term)))
-    (define (visit-primcall k src name args)
-      ;; If we introduce an RTL op from a primcall without an RTL op, we
-      ;; will need to ensure that the return arity matches.  Rely on the
-      ;; elide-values pass to clean up.
-      (define-syntax-rule (adapt-void exp)
-        (let-gensyms (k* val kvoid)
-          (build-cps-term
-            ($letk ((k* ($kargs ('val) (val)
-                          ($continue k src ($primcall 'values (val)))))
-                    (kvoid ($kargs () ()
-                             ($continue k* src ($void)))))
-              ($continue kvoid src exp)))))
-      (define-syntax-rule (adapt-val exp)
-        (let-gensyms (k* val)
-          (build-cps-term
-            ($letk ((k* ($kargs ('val) (val)
-                          ($continue k src ($primcall 'values (val))))))
-              ($continue k* src exp)))))
-      (match (cons name args)
-        (('make-vector (? immediate-u8? n) init)
-         (adapt-val ($primcall 'make-vector/immediate (n init))))
-        (('vector-ref v (? immediate-u8? n))
-         (build-cps-term
-           ($continue k src ($primcall 'vector-ref/immediate (v n)))))
-        (('vector-set! v (? immediate-u8? n) x)
-         (build-cps-term
-           ($continue k src ($primcall 'vector-set!/immediate (v n x)))))
-        (('allocate-struct v (? immediate-u8? n))
-         (adapt-val ($primcall 'allocate-struct/immediate (v n))))
-        (('struct-ref s (? immediate-u8? n))
-         (adapt-val ($primcall 'struct-ref/immediate (s n))))
-        (('struct-set! s (? immediate-u8? n) x)
-         ;; Unhappily, and undocumentedly, struct-set! returns the value
-         ;; that was set.  There is code that relies on this.  Hackety
-         ;; hack...
-         (let-gensyms (k*)
-           (build-cps-term
-             ($letk ((k* ($kargs () ()
-                           ($continue k src ($primcall 'values (x))))))
-               ($continue k* src ($primcall 'struct-set!/immediate (s n x)))))))
-        (_ 
-         (build-cps-term ($continue k src ($primcall name args))))))
-
-    (define (visit-fun fun)
-      (rewrite-cps-exp fun
-        (($ $fun src meta free body)
-         ($fun src meta free ,(visit-cont body)))))
-
-    (visit-fun fun)))
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+;;;
+;;; Some bytecode operations can encode an immediate as an operand.
+;;; This pass tranforms generic primcalls to these specialized
+;;; primcalls, if possible.
+;;;
+;;; Code:
+
+(define-module (language cps specialize-primcalls)
+  #:use-module (ice-9 match)
+  #:use-module (language cps)
+  #:use-module (language cps dfg)
+  #:export (specialize-primcalls))
+
+(define (specialize-primcalls fun)
+  (let ((dfg (compute-dfg fun #:global? #t)))
+    (with-fresh-name-state-from-dfg dfg
+      (define (immediate-u8? sym)
+        (call-with-values (lambda () (find-constant-value sym dfg))
+          (lambda (has-const? val)
+            (and has-const? (integer? val) (exact? val) (<= 0 val 255)))))
+      (define (visit-cont cont)
+        (rewrite-cps-cont cont
+          (($ $cont sym ($ $kargs names syms body))
+           (sym ($kargs names syms ,(visit-term body))))
+          (($ $cont sym ($ $kfun src meta self tail clause))
+           (sym ($kfun src meta self ,tail
+                  ,(and clause (visit-cont clause)))))
+          (($ $cont sym ($ $kclause arity body alternate))
+           (sym ($kclause ,arity ,(visit-cont body)
+                          ,(and alternate (visit-cont alternate)))))
+          (($ $cont)
+           ,cont)))
+      (define (visit-term term)
+        (rewrite-cps-term term
+          (($ $letk conts body)
+           ($letk ,(map visit-cont conts)
+             ,(visit-term body)))
+          (($ $letrec names syms funs body)
+           ($letrec names syms (map visit-fun funs)
+                    ,(visit-term body)))
+          (($ $continue k src (and fun ($ $fun)))
+           ($continue k src ,(visit-fun fun)))
+          (($ $continue k src ($ $primcall name args))
+           ,(visit-primcall k src name args))
+          (($ $continue)
+           ,term)))
+      (define (visit-primcall k src name args)
+        ;; If we introduce a VM op from a primcall without a VM op, we
+        ;; will need to ensure that the return arity matches.  Rely on the
+        ;; elide-values pass to clean up.
+        (define-syntax-rule (adapt-void exp)
+          (let-fresh (k* kvoid) (val)
+            (build-cps-term
+              ($letk ((k* ($kargs ('val) (val)
+                            ($continue k src ($primcall 'values (val)))))
+                      (kvoid ($kargs () ()
+                               ($continue k* src ($const *unspecified*)))))
+                ($continue kvoid src exp)))))
+        (define-syntax-rule (adapt-val exp)
+          (let-fresh (k*) (val)
+            (build-cps-term
+              ($letk ((k* ($kargs ('val) (val)
+                            ($continue k src ($primcall 'values (val))))))
+                ($continue k* src exp)))))
+        (match (cons name args)
+          (('make-vector (? immediate-u8? n) init)
+           (adapt-val ($primcall 'make-vector/immediate (n init))))
+          (('vector-ref v (? immediate-u8? n))
+           (build-cps-term
+             ($continue k src ($primcall 'vector-ref/immediate (v n)))))
+          (('vector-set! v (? immediate-u8? n) x)
+           (build-cps-term
+             ($continue k src ($primcall 'vector-set!/immediate (v n x)))))
+          (('allocate-struct v (? immediate-u8? n))
+           (adapt-val ($primcall 'allocate-struct/immediate (v n))))
+          (('struct-ref s (? immediate-u8? n))
+           (adapt-val ($primcall 'struct-ref/immediate (s n))))
+          (('struct-set! s (? immediate-u8? n) x)
+           (build-cps-term
+             ($continue k src ($primcall 'struct-set!/immediate (s n x)))))
+          (_ 
+           (build-cps-term ($continue k src ($primcall name args))))))
+
+      (define (visit-fun fun)
+        (rewrite-cps-exp fun
+          (($ $fun free body)
+           ($fun free ,(visit-cont body)))))
+
+      (visit-cont fun))))