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