[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/13: Reify primitives in CPS2
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/13: Reify primitives in CPS2 |
Date: |
Wed, 22 Jul 2015 15:32:25 +0000 |
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))))
- [Guile-commits] branch master updated (90aabcc -> aa7f0e2), Andy Wingo, 2015/07/22
- [Guile-commits] 04/13: CPS1 slot-allocation simplification, Andy Wingo, 2015/07/22
- [Guile-commits] 05/13: More slot-allocation simplification, Andy Wingo, 2015/07/22
- [Guile-commits] 03/13: Utils refactors, Andy Wingo, 2015/07/22
- [Guile-commits] 07/13: Fix bad return shuffles for multiply-used $kreceive conts, Andy Wingo, 2015/07/22
- [Guile-commits] 01/13: Reify primitives in CPS2,
Andy Wingo <=
- [Guile-commits] 09/13: Fix CPS2 compute-successors, Andy Wingo, 2015/07/22
- [Guile-commits] 06/13: Fix error printing some wrong-num-args backtraces, Andy Wingo, 2015/07/22
- [Guile-commits] 02/13: Add intset-prev and intset-fold-right, Andy Wingo, 2015/07/22
- [Guile-commits] 11/13: Compile CPS2 directly to bytecode, Andy Wingo, 2015/07/22
- [Guile-commits] 08/13: intset-intersect bugfix, Andy Wingo, 2015/07/22
- [Guile-commits] 10/13: Slot allocation and bytecode compilation from CPS2., Andy Wingo, 2015/07/22
- [Guile-commits] 12/13: Remove CPS1 language, Andy Wingo, 2015/07/22
- [Guile-commits] 13/13: Rename CPS2 to CPS, Andy Wingo, 2015/07/22