From 1a819eaaa73b6d3099661d6518f035bd36c79899 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 16 Jul 2015 11:27:14 +0200 Subject: 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(-) delete mode 100644 module/language/cps/reify-primitives.scm create mode 100644 module/language/cps2/reify-primitives.scm diff --git a/module/Makefile.am b/module/Makefile.am index 188cc7626..c1c3e5cf0 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 c07db2621..c92c15d01 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 286fd7c41..000000000 --- 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 85b00c95c..ee6e3d5bb 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 000000000..b5f62d456 --- /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)))) -- cgit v1.2.3