From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 25 Aug 2019 21:20:39 +0000 (+0000)
Subject: New primitive PRIMITIVE-PROCEDURE-OPEN-CODED?.
X-Git-Tag: mit-scheme-pucked-10.1.20~11^2~62
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ed988f07efd71dcb370c9545065bef7f613dd6ad;p=mit-scheme.git
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 ...))
---
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