[Guile-commits] 01/13: Reify primitives in CPS2

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 1a819eaaa73b6d3099661d6518f035bd36c79899
Author: Andy Wingo <address@hidden>
Date:   Thu Jul 16 11:27:14 2015 +0200

    Reify primitives in CPS2
    
    * module/language/cps/reify-primitives.scm: Remove.
    * module/language/cps2/reify-primitives.scm: New file.
    * module/Makefile.am: Adapt build.
    
    * module/language/cps/compile-bytecode.scm:
    * module/language/cps2/compile-cps.scm: Reify primitives in CPS2 instead
      of CPS.
---
 module/Makefile.am                        |    2 +-
 module/language/cps/compile-bytecode.scm  |    3 +-
 module/language/cps/reify-primitives.scm  |  178 -----------------------------
 module/language/cps2/compile-cps.scm      |    2 +
 module/language/cps2/reify-primitives.scm |  145 +++++++++++++++++++++++
 5 files changed, 149 insertions(+), 181 deletions(-)

diff --git a/module/Makefile.am b/module/Makefile.am
index 188cc76..c1c3e5c 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -126,7 +126,6 @@ CPS_LANG_SOURCES =                                          
\
   language/cps/compile-bytecode.scm                            \
   language/cps/dfg.scm                                         \
   language/cps/primitives.scm                                  \
-  language/cps/reify-primitives.scm                            \
   language/cps/renumber.scm                                    \
   language/cps/slot-allocation.scm                             \
   language/cps/spec.scm                                                \
@@ -144,6 +143,7 @@ CPS2_LANG_SOURCES =                                         
\
   language/cps2/elide-values.scm                               \
   language/cps2/prune-bailouts.scm                             \
   language/cps2/prune-top-level-scopes.scm                     \
+  language/cps2/reify-primitives.scm                           \
   language/cps2/renumber.scm                                   \
   language/cps2/optimize.scm                                   \
   language/cps2/simplify.scm                                   \
diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index c07db26..c92c15d 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -29,7 +29,6 @@
   #:use-module (language cps)
   #:use-module (language cps dfg)
   #:use-module (language cps primitives)
-  #:use-module (language cps reify-primitives)
   #:use-module (language cps renumber)
   #:use-module (language cps slot-allocation)
   #:use-module (system vm assembler)
@@ -443,7 +442,7 @@
        (compile-entry)))))
 
 (define (compile-bytecode exp env opts)
-  (let* ((exp (renumber (reify-primitives exp)))
+  (let* ((exp (renumber exp))
          (asm (make-assembler)))
     (match exp
       (($ $program funs)
diff --git a/module/language/cps/reify-primitives.scm 
b/module/language/cps/reify-primitives.scm
deleted file mode 100644
index 286fd7c..0000000
--- a/module/language/cps/reify-primitives.scm
+++ /dev/null
@@ -1,178 +0,0 @@
-;;; 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:
-;;;
-;;; A pass to reify lone $prim's that were never folded into a
-;;; $primcall, and $primcall's to primitives that don't have a
-;;; corresponding VM op.
-;;;
-;;; Code:
-
-(define-module (language cps reify-primitives)
-  #:use-module (ice-9 match)
-  #:use-module (language cps)
-  #:use-module (language cps dfg)
-  #:use-module (language cps primitives)
-  #:use-module (language bytecode)
-  #:export (reify-primitives))
-
-(define (module-box src module name public? bound? val-proc)
-  (let-fresh (kbox) (module-var name-var public?-var bound?-var box)
-    (build-cps-term
-      ($letconst (('module module-var module)
-                  ('name name-var name)
-                  ('public? public?-var public?)
-                  ('bound? bound?-var bound?))
-        ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
-          ($continue kbox src
-            ($primcall 'cached-module-box
-                       (module-var name-var public?-var bound?-var))))))))
-
-(define (primitive-module name)
-  (case name
-    ((bytevector?
-      bytevector-length
-
-      bytevector-u8-ref bytevector-u8-set!
-      bytevector-s8-ref bytevector-s8-set!
-
-      bytevector-u16-ref bytevector-u16-set!
-      bytevector-u16-native-ref bytevector-u16-native-set!
-      bytevector-s16-ref bytevector-s16-set!
-      bytevector-s16-native-ref bytevector-s16-native-set!
-
-      bytevector-u32-ref bytevector-u32-set!
-      bytevector-u32-native-ref bytevector-u32-native-set!
-      bytevector-s32-ref bytevector-s32-set!
-      bytevector-s32-native-ref bytevector-s32-native-set!
-
-      bytevector-u64-ref bytevector-u64-set!
-      bytevector-u64-native-ref bytevector-u64-native-set!
-      bytevector-s64-ref bytevector-s64-set!
-      bytevector-s64-native-ref bytevector-s64-native-set!
-
-      bytevector-ieee-single-ref bytevector-ieee-single-set!
-      bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
-      bytevector-ieee-double-ref bytevector-ieee-double-set!
-      bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)
-     '(rnrs bytevectors))
-    ((class-of) '(oop goops))
-    (else '(guile))))
-
-(define (primitive-ref name k src)
-  (module-box #f (primitive-module name) name #f #t
-              (lambda (box)
-                (build-cps-term
-                  ($continue k src ($primcall 'box-ref (box)))))))
-
-(define (builtin-ref idx k src)
-  (let-fresh () (idx-var)
-    (build-cps-term
-      ($letconst (('idx idx-var idx))
-        ($continue k src
-          ($primcall 'builtin-ref (idx-var)))))))
-
-(define (reify-clause ktail)
-  (let-fresh (kclause kbody kthrow) (wna false str eol throw)
-    (build-cps-cont
-      (kclause ($kclause ('() '() #f '() #f)
-                 (kbody
-                  ($kargs () ()
-                    ($letconst (('wna wna 'wrong-number-of-args)
-                                ('false false #f)
-                                ('str str "Wrong number of arguments")
-                                ('eol eol '()))
-                      ($letk ((kthrow
-                               ($kargs ('throw) (throw)
-                                 ($continue ktail #f
-                                   ($call throw
-                                          (wna false str eol false))))))
-                        ,(primitive-ref 'throw kthrow #f)))))
-                 ,#f)))))
-
-(define (reify-primitives/1 fun single-value-conts)
-  (define (visit-clause cont)
-    (rewrite-cps-cont cont
-      (($ $cont label ($ $kclause arity body alternate))
-       (label ($kclause ,arity ,(visit-cont body)
-                      ,(and alternate (visit-clause alternate)))))))
-  (define (visit-cont cont)
-    (rewrite-cps-cont cont
-      (($ $cont label ($ $kargs (name) (var) body))
-       ,(begin
-          (bitvector-set! single-value-conts label #t)
-          (build-cps-cont
-            (label ($kargs (name) (var) ,(visit-term body))))))
-      (($ $cont label ($ $kargs names vars body))
-       (label ($kargs names vars ,(visit-term body))))
-      (($ $cont)
-       ,cont)))
-  (define (visit-term term)
-    (match term
-      (($ $letk conts body)
-       ;; Visit continuations before their uses.
-       (let ((conts (map visit-cont conts)))
-         (build-cps-term
-           ($letk ,conts ,(visit-term body)))))
-      (($ $continue k src exp)
-       (match exp
-         (($ $prim name)
-          (if (bitvector-ref single-value-conts k)
-              (cond
-               ((builtin-name->index name)
-                => (lambda (idx)
-                     (builtin-ref idx k src)))
-               (else (primitive-ref name k src)))
-              (build-cps-term ($continue k src
-                                ($const *unspecified*)))))
-         (($ $primcall 'call-thunk/no-inline (proc))
-          (build-cps-term
-            ($continue k src ($call proc ()))))
-         (($ $primcall name args)
-          (cond
-           ((or (prim-instruction name) (branching-primitive? name))
-            ;; Assume arities are correct.
-            term)
-           (else
-            (let-fresh (k*) (v)
-              (build-cps-term
-                ($letk ((k* ($kargs (v) (v)
-                              ($continue k src ($call v args)))))
-                  ,(cond
-                    ((builtin-name->index name)
-                     => (lambda (idx)
-                          (builtin-ref idx k* src)))
-                    (else (primitive-ref name k* src)))))))))
-         (_ term)))))
-
-  (rewrite-cps-cont fun
-    (($ $cont label ($ $kfun src meta self (and tail ($ $cont ktail)) #f))
-     ;; A case-lambda with no clauses.  Reify a clause.
-     (label ($kfun src meta self ,tail ,(reify-clause ktail))))
-    (($ $cont label ($ $kfun src meta self tail clause))
-     (label ($kfun src meta self ,tail ,(visit-clause clause))))))
-
-(define (reify-primitives term)
-  (with-fresh-name-state term
-    (let ((single-value-conts (make-bitvector (label-counter) #f)))
-      (rewrite-cps-term term
-        (($ $program procs)
-         ($program ,(map (lambda (cont)
-                           (reify-primitives/1 cont single-value-conts))
-                         procs)))))))
diff --git a/module/language/cps2/compile-cps.scm 
b/module/language/cps2/compile-cps.scm
index 85b00c9..ee6e3d5 100644
--- a/module/language/cps2/compile-cps.scm
+++ b/module/language/cps2/compile-cps.scm
@@ -29,6 +29,7 @@
   #:use-module (language cps2 utils)
   #:use-module (language cps2 closure-conversion)
   #:use-module (language cps2 optimize)
+  #:use-module (language cps2 reify-primitives)
   #:use-module (language cps2 renumber)
   #:use-module (language cps intmap)
   #:export (compile-cps))
@@ -123,5 +124,6 @@
   (set! exp (optimize-higher-order-cps exp opts))
   (set! exp (convert-closures exp))
   (set! exp (optimize-first-order-cps exp opts))
+  (set! exp (reify-primitives exp))
   (set! exp (renumber exp))
   (values (conts->fun* exp) env env))
diff --git a/module/language/cps2/reify-primitives.scm 
b/module/language/cps2/reify-primitives.scm
new file mode 100644
index 0000000..b5f62d4
--- /dev/null
+++ b/module/language/cps2/reify-primitives.scm
@@ -0,0 +1,145 @@
+;;; 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:
+;;;
+;;; A pass to reify lone $prim's that were never folded into a
+;;; $primcall, and $primcall's to primitives that don't have a
+;;; corresponding VM op.
+;;;
+;;; Code:
+
+(define-module (language cps2 reify-primitives)
+  #:use-module (ice-9 match)
+  #:use-module (language cps2)
+  #:use-module (language cps2 utils)
+  #:use-module (language cps2 with-cps)
+  #:use-module (language cps primitives)
+  #:use-module (language cps intmap)
+  #:use-module (language bytecode)
+  #:export (reify-primitives))
+
+(define (module-box cps src module name public? bound? val-proc)
+  (with-cps cps
+    (letv box)
+    (let$ body (val-proc box))
+    (letk kbox ($kargs ('box) (box) ,body))
+    ($ (with-cps-constants ((module module)
+                            (name name)
+                            (public? public?)
+                            (bound? bound?))
+         (build-term ($continue kbox src
+                       ($primcall 'cached-module-box
+                                  (module name public? bound?))))))))
+
+(define (primitive-module name)
+  (case name
+    ((bytevector?
+      bytevector-length
+
+      bytevector-u8-ref bytevector-u8-set!
+      bytevector-s8-ref bytevector-s8-set!
+
+      bytevector-u16-ref bytevector-u16-set!
+      bytevector-u16-native-ref bytevector-u16-native-set!
+      bytevector-s16-ref bytevector-s16-set!
+      bytevector-s16-native-ref bytevector-s16-native-set!
+
+      bytevector-u32-ref bytevector-u32-set!
+      bytevector-u32-native-ref bytevector-u32-native-set!
+      bytevector-s32-ref bytevector-s32-set!
+      bytevector-s32-native-ref bytevector-s32-native-set!
+
+      bytevector-u64-ref bytevector-u64-set!
+      bytevector-u64-native-ref bytevector-u64-native-set!
+      bytevector-s64-ref bytevector-s64-set!
+      bytevector-s64-native-ref bytevector-s64-native-set!
+
+      bytevector-ieee-single-ref bytevector-ieee-single-set!
+      bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
+      bytevector-ieee-double-ref bytevector-ieee-double-set!
+      bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)
+     '(rnrs bytevectors))
+    ((class-of) '(oop goops))
+    (else '(guile))))
+
+(define (primitive-ref cps name k src)
+  (module-box cps src (primitive-module name) name #f #t
+              (lambda (cps box)
+                (with-cps cps
+                  (build-term
+                    ($continue k src ($primcall 'box-ref (box))))))))
+
+(define (builtin-ref cps idx k src)
+  (with-cps cps
+    ($ (with-cps-constants ((idx idx))
+         (build-term
+           ($continue k src ($primcall 'builtin-ref (idx))))))))
+
+(define (reify-clause cps ktail)
+  (with-cps cps
+    (letv throw)
+    (let$ throw-body
+          (with-cps-constants ((wna 'wrong-number-of-args)
+                               (false #f)
+                               (str "Wrong number of arguments")
+                               (eol '()))
+            (build-term
+              ($continue ktail #f
+                ($call throw (wna false str eol false))))))
+    (letk kthrow ($kargs ('throw) (throw) ,throw-body))
+    (let$ body (primitive-ref 'throw kthrow #f))
+    (letk kbody ($kargs () () ,body))
+    (letk kclause ($kclause ('() '() #f '() #f) kbody #f))
+    kclause))
+
+(define (reify-primitives cps)
+  (define (visit-cont label cont cps)
+    (define (resolve-prim cps name k src)
+      (cond
+       ((builtin-name->index name)
+        => (lambda (idx) (builtin-ref cps idx k src)))
+       (else
+        (primitive-ref cps name k src))))
+    (match cont
+      (($ $kfun src meta self tail #f)
+       (with-cps cps
+         (let$ clause (reify-clause tail))
+         (setk label ($kfun src meta self tail clause))))
+      (($ $kargs names vars ($ $continue k src ($ $prim name)))
+       (with-cps cps
+         (let$ body (resolve-prim name k src))
+         (setk label ($kargs names vars ,body))))
+      (($ $kargs names vars
+          ($ $continue k src ($ $primcall 'call-thunk/no-inline (proc))))
+       (with-cps cps
+         (setk label ($kargs names vars ($continue k src ($call proc ()))))))
+      (($ $kargs names vars ($ $continue k src ($ $primcall name args)))
+       (if (or (prim-instruction name) (branching-primitive? name))
+           ;; Assume arities are correct.
+           cps
+           (with-cps cps
+             (letv proc)
+             (letk kproc ($kargs ('proc) (proc)
+                           ($continue k src ($call proc args))))
+             (let$ body (resolve-prim name kproc src))
+             (setk label ($kargs names vars ,body)))))
+      (_ cps)))
+
+  (with-fresh-name-state cps
+    (persistent-intmap (intmap-fold visit-cont cps cps))))