From ed988f07efd71dcb370c9545065bef7f613dd6ad Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Sun, 25 Aug 2019 21:20:39 +0000 Subject: [PATCH] New primitive PRIMITIVE-PROCEDURE-OPEN-CODED?. Usage: (define (foo x y) (if ((ucode-primitive primitive-procedure-open-coded? 1) (ucode-primitive xyz 2)) ((ucode-primitive xyz 2) x y) ... Scheme alternative implementation ...)) --- src/compiler/base/utils.scm | 1 + src/compiler/fgopt/folcon.scm | 6 +++- src/compiler/machines/C/compiler.pkg | 1 + src/compiler/machines/aarch64/compiler.pkg | 1 + src/compiler/machines/i386/compiler.pkg | 1 + src/compiler/machines/svm/compiler.pkg | 1 + src/compiler/machines/x86-64/compiler.pkg | 1 + src/compiler/rtlgen/opncod.scm | 6 ++++ src/microcode/extern.c | 10 ++++++ tests/check.scm | 1 + tests/compiler/test-open-code.scm | 42 ++++++++++++++++++++++ 11 files changed, 70 insertions(+), 1 deletion(-) create mode 100644 tests/compiler/test-open-code.scm diff --git a/src/compiler/base/utils.scm b/src/compiler/base/utils.scm index cce2df0a3..7406976ca 100644 --- a/src/compiler/base/utils.scm +++ b/src/compiler/base/utils.scm @@ -332,6 +332,7 @@ USA. (ucode-primitive pair?) (ucode-primitive positive-fixnum?) (ucode-primitive positive?) + (ucode-primitive primitive-procedure-open-coded? 1) (ucode-primitive string?) (ucode-primitive vector?) (ucode-primitive weak-pair? 1) diff --git a/src/compiler/fgopt/folcon.scm b/src/compiler/fgopt/folcon.scm index 1cd20a223..c620c80dd 100644 --- a/src/compiler/fgopt/folcon.scm +++ b/src/compiler/fgopt/folcon.scm @@ -236,7 +236,11 @@ USA. (define (constant-foldable-operator-value rv) (if (rvalue/reference? rv) (variable-usual-definition (variable-name (reference-lvalue rv))) - (rvalue-constant-value rv))) + (let ((primitive (rvalue-constant-value rv))) + (assert (primitive-procedure? primitive)) + (if (eq? primitive (ucode-primitive primitive-procedure-open-coded? 1)) + primitive-procedure-open-coded? + primitive)))) (define (arity-correct? proc n) (let ((arity (procedure-arity proc))) diff --git a/src/compiler/machines/C/compiler.pkg b/src/compiler/machines/C/compiler.pkg index 5fb982bc4..4ec434e79 100644 --- a/src/compiler/machines/C/compiler.pkg +++ b/src/compiler/machines/C/compiler.pkg @@ -600,6 +600,7 @@ USA. (files "rtlgen/opncod") (parent (compiler rtl-generator)) (export (compiler rtl-generator) combination/inline) + (export (compiler fg-optimizer) primitive-procedure-open-coded?) (export (compiler top-level) open-coding-analysis)) (define-package (compiler rtl-generator find-block) diff --git a/src/compiler/machines/aarch64/compiler.pkg b/src/compiler/machines/aarch64/compiler.pkg index c5bffcdc2..dcba7742d 100644 --- a/src/compiler/machines/aarch64/compiler.pkg +++ b/src/compiler/machines/aarch64/compiler.pkg @@ -586,6 +586,7 @@ USA. (files "rtlgen/opncod") (parent (compiler rtl-generator)) (export (compiler rtl-generator) combination/inline) + (export (compiler fg-optimizer) primitive-procedure-open-coded?) (export (compiler top-level) open-coding-analysis)) (define-package (compiler rtl-generator find-block) diff --git a/src/compiler/machines/i386/compiler.pkg b/src/compiler/machines/i386/compiler.pkg index 8e7733193..730615096 100644 --- a/src/compiler/machines/i386/compiler.pkg +++ b/src/compiler/machines/i386/compiler.pkg @@ -586,6 +586,7 @@ USA. (files "rtlgen/opncod") (parent (compiler rtl-generator)) (export (compiler rtl-generator) combination/inline) + (export (compiler fg-optimizer) primitive-procedure-open-coded?) (export (compiler top-level) open-coding-analysis)) (define-package (compiler rtl-generator find-block) diff --git a/src/compiler/machines/svm/compiler.pkg b/src/compiler/machines/svm/compiler.pkg index 6c8a69a70..2158e9a36 100644 --- a/src/compiler/machines/svm/compiler.pkg +++ b/src/compiler/machines/svm/compiler.pkg @@ -588,6 +588,7 @@ USA. (files "rtlgen/opncod") (parent (compiler rtl-generator)) (export (compiler rtl-generator) combination/inline) + (export (compiler fg-optimizer) primitive-procedure-open-coded?) (export (compiler top-level) open-coding-analysis)) (define-package (compiler rtl-generator find-block) diff --git a/src/compiler/machines/x86-64/compiler.pkg b/src/compiler/machines/x86-64/compiler.pkg index 742e48852..13045951e 100644 --- a/src/compiler/machines/x86-64/compiler.pkg +++ b/src/compiler/machines/x86-64/compiler.pkg @@ -586,6 +586,7 @@ USA. (files "rtlgen/opncod") (parent (compiler rtl-generator)) (export (compiler rtl-generator) combination/inline) + (export (compiler fg-optimizer) primitive-procedure-open-coded?) (export (compiler top-level) open-coding-analysis)) (define-package (compiler rtl-generator find-block) diff --git a/src/compiler/rtlgen/opncod.scm b/src/compiler/rtlgen/opncod.scm index 6c937e0aa..0de464e9e 100644 --- a/src/compiler/rtlgen/opncod.scm +++ b/src/compiler/rtlgen/opncod.scm @@ -73,6 +73,12 @@ USA. (and entry (try-handler combination value entry)))))))) +(define (primitive-procedure-open-coded? primitive) + (guarantee primitive-procedure? primitive 'PRIMITIVE-PROCEDURE-OPEN-CODED?) + (let ((name (primitive-procedure-name primitive))) + (and (hash-table-ref name->open-coders name (lambda () #f)) + #t))) + (define (try-handler combination primitive entry) (let ((operands (combination/operands combination))) (and (primitive-arity-correct? primitive (length operands)) diff --git a/src/microcode/extern.c b/src/microcode/extern.c index ba95ef29d..c9fabd621 100644 --- a/src/microcode/extern.c +++ b/src/microcode/extern.c @@ -198,3 +198,13 @@ whether the corresponding primitive is implemented or not.") (find_primitive ((MEMORY_REF (name, SYMBOL_NAME)), intern_p, allow_p, arity)); } + +DEFINE_PRIMITIVE ("PRIMITIVE-PROCEDURE-OPEN-CODED?", Prim_primitive_procedure_open_coded, 1, 1, + "(PRIMITIVE)\n\ +Returns #t iff PRIMITIVE is open-coded by the compiler.\n\ +Only returns #t if constant-folded by the same compiler.") +{ + PRIMITIVE_HEADER (1); + CHECK_ARG (1, PRIMITIVE_P); + PRIMITIVE_RETURN (SHARP_F); +} diff --git a/tests/check.scm b/tests/check.scm index 0e594288c..44ed686a9 100644 --- a/tests/check.scm +++ b/tests/check.scm @@ -42,6 +42,7 @@ USA. '( ("compiler/test-fasdump" (compiler portable-fasdump)) "compiler/test-fgopt-conect" + "compiler/test-open-code" "compiler/test-toplev" "compiler/test-varname" "compiler/test-vartrap" diff --git a/tests/compiler/test-open-code.scm b/tests/compiler/test-open-code.scm new file mode 100644 index 000000000..8155c5cf9 --- /dev/null +++ b/tests/compiler/test-open-code.scm @@ -0,0 +1,42 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017, 2018, 2019 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme 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 +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Tests open-coded conditionals + +(declare (usual-integrations)) + +(define-syntax ucode-primitive + (sc-macro-transformer + (lambda (form environment) + environment + (apply make-primitive-procedure (cdr form))))) + +(define-test 'primitive-procedure-open-coded? + (lambda () + (assert-eqv + ((ucode-primitive primitive-procedure-open-coded? 1) + (ucode-primitive null? 1)) + (compiled-procedure? (lambda () 0))))) \ No newline at end of file -- 2.25.1