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 cce2df0a3ba7e7a7c5dbba12069b8629371fe1e5..7406976ca21dc97bc3cb18210dc98d991e6a3d1c 100644 (file)
--- 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 1cd20a223488b62357cc0c4d99332fd3da4ad747..c620c80ddf8e1b7745156ebcf52995d40ef17cf1 100644 (file)
--- 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 5fb982bc4f33a3f985553cbc982c783778c91439..4ec434e79d515e55bc82037477b3d31bf558da24 100644 (file)
--- 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 c5bffcdc2433ff60be4f24fa2ba57df3ff20f9c4..dcba7742d780b8387eaa2a619399aa6938a30fe4 100644 (file)
--- 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 8e7733193d2b19c35fc7b619c90cd6128864dd3a..730615096e9143ee183a601e5a7479303ba45d1b 100644 (file)
--- 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 6c8a69a70b7504b8bdb450f848e1849c341a08b9..2158e9a3644e30f124372ba82182fdb5dc61f73a 100644 (file)
--- 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 742e488524a6278d32477aa75dd584bcacebbf09..13045951e3737ddd6f63a90bae77c420ae558ad1 100644 (file)
--- 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 6c937e0aad30b0acf3e1231e9bbe33e2e5acea21..0de464e9ea47875f74a3f59cb7ce751ba46dbd79 100644 (file)
--- 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 ba95ef29d9894028631f5d3d6ddbb57abada5bce..c9fabd621684a66450e48f21bea99fe3b4685ccb 100644 (file)
--- 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 0e594288ce71dfeeddb824e224d0b5489764c2cf..44ed686a993e507fdc2b3d5b8151819c8194cdf6 100644 (file)
--- 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 (file)
index 0000000..8155c5c
--- /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))
+\f
+(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