From 1a5d1c6ca47d7a640c788b99d20fc68ac98b2975 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 22 May 2023 10:16:17 +0200 Subject: [PATCH 01/23] .gitignore: add the directory /local as ignored --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 573cff5ee..dd899078d 100644 --- a/.gitignore +++ b/.gitignore @@ -4,6 +4,7 @@ \#* /build +/local cov-int *.data From 3f3c89ddb252e8e936a2a2748d7ce3e76dd9edc1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 13 Mar 2023 14:18:25 +0100 Subject: [PATCH 02/23] cmp: separate cmpbackend from cmpmain (1) Introduce compiler-pass/generate-cxx. --- src/cmp/cmpbackend-cxx.lsp | 735 ++++++++++++++++++++++++++++++++++ src/cmp/cmpmain.lsp | 788 ++----------------------------------- src/cmp/load.lsp.in | 1 + 3 files changed, 776 insertions(+), 748 deletions(-) create mode 100644 src/cmp/cmpbackend-cxx.lsp diff --git a/src/cmp/cmpbackend-cxx.lsp b/src/cmp/cmpbackend-cxx.lsp new file mode 100644 index 000000000..74f5f38f7 --- /dev/null +++ b/src/cmp/cmpbackend-cxx.lsp @@ -0,0 +1,735 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya +;;;; Copyright (c) 1990, Giuseppe Attardi +;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll +;;;; Copyright (c) 2023, Daniel Kochmański +;;;; +;;;; See the file 'LICENSE' for the copyright details. +;;;; + +;;;; CMPBACKEND-CXX -- backend for compiling to C99/C++ and then invoking the +;;;; external compiler. + +(in-package "COMPILER") + + +;;; External tool wrappers +(defun safe-mkstemp (template) + ;; We do several things here. One is to check for success in MKSTEMP, + ;; the other one is to ensure that the output of this function _always_ + ;; carries a file type -- this solves a problem with filesystems where + ;; mkstemp may introduce one or more dots in the name causing several + ;; functions below to ignore parts of the name. Note that this forces + ;; us to have two files per temp: one with and one without extension. + (let ((base (ext:mkstemp template))) + (unless base + (error "Unable to create temporary file~%~ + ~AXXXXXX +Make sure you have enough free space in disk, check permissions or set~%~ +the environment variable TMPDIR to a different value." template)) + (let ((output (make-pathname :name + (concatenate 'string (pathname-name base) + (or (pathname-type base) "")) + :type "tmp" + :defaults base))) + (if (and (not (probe-file output)) + (si:copy-file base output)) + (setf base (list (truename output) (truename base))) + (progn (delete-file base) + (setf base nil)))) + base)) + +#+msvc +(defun delete-msvc-generated-files (output-pathname) + (loop for i in '("implib" "exp" "ilk" ) + for full = (make-pathname :type i :defaults output-pathname) + for truename = (probe-file full) + when truename + do (cmp-delete-file truename))) + +#+msvc +(defun embed-manifest-file (o-file &optional (type :dll)) + (let* ((real-file (probe-file o-file))) + (when real-file + (let* ((manifest-namestring (concatenate 'string (namestring o-file) + ".manifest")) + (resource-code (ecase type + ((:dll :shared-library :fasl :fas) 2) + ((:program) 1))) + (resource-option (format nil "-outputresource:~A;~D" + (namestring real-file) + resource-code)) + (manifest (probe-file manifest-namestring))) + (when manifest + (safe-run-program "mt" + (list "-nologo" + "-manifest" + manifest-namestring + resource-option)) + (delete-file manifest)))))) + +(defun cmp-delete-file (file) + (cond ((null *delete-files*)) + ((ext:getenv "ECL_PRESERVE_FILES")) + ((null (probe-file file))) + (*debug-compiler* + (cmpprogress "~%Postponing deletion of ~A" file) + (push file *files-to-be-deleted*)) + (t + (delete-file file)))) + +(push #'(lambda () (mapc #'delete-file *files-to-be-deleted*)) + si::*exit-hooks*) + +#-mingw32 +(defmacro fix-for-mingw (directory-namestring) + directory-namestring) + +#+mingw32 +(defun fix-for-mingw (directory-namestring) + (let ((x (string-right-trim '(#\\ #\/) directory-namestring))) + (if (zerop (length x)) "/" x))) + +(defun get-deprecated-user-ld-flags () + (let ((flags (split-program-options *user-ld-flags*))) + (when flags + (cmpwarn "The variable ~s is deprecated, please use ~s and ~s instead." + '*user-ld-flags* '*user-linker-flags* '*user-linker-libs*)) + flags)) + +#+msvc +(defun linker-cc (o-pathname object-files &key + (type :program) + (ld-flags (split-program-options *ld-flags*)) + (ld-libs (split-program-options *ld-libs*))) + (safe-run-program + *ld* + `(,(concatenate 'string "-Fe" (brief-namestring o-pathname)) + ,@(split-program-options *ld-rpath*) + ,@(split-program-options *user-linker-flags*) + ,@object-files + ,@ld-flags + ,@(split-program-options *user-linker-libs*) + ,@(get-deprecated-user-ld-flags) + ,@ld-libs + ,(if (eq type :program) + (concatenate 'string "/IMPLIB:prog" (file-namestring o-pathname) ".lib") + "") + ,(concatenate 'string "/LIBPATH:" + (ecl-library-directory)))) + (embed-manifest-file o-pathname type) + (delete-msvc-generated-files o-pathname)) + +#-msvc +(defun linker-cc (o-pathname object-files &key + (type :program) + (ld-flags (split-program-options *ld-flags*)) + (ld-libs (split-program-options *ld-libs*))) + (declare (ignore type)) + (safe-run-program + *ld* + `("-o" ,(brief-namestring o-pathname) + ,(concatenate 'string "-L" (fix-for-mingw (ecl-library-directory))) + ,@(split-program-options *user-linker-flags*) + ,@ld-flags + ,@object-files + ,@(and *ld-rpath* (list *ld-rpath*)) + ,@(split-program-options *user-linker-libs*) + ,@(get-deprecated-user-ld-flags) + ,@ld-libs))) + +(defun linker-ar (output-name o-name ld-libs) + #-msvc + (static-lib-ar (namestring output-name) + (list* (brief-namestring o-name) ld-libs)) + #+msvc + (unwind-protect + (progn + (with-open-file (f "static_lib.tmp" :direction :output + :if-does-not-exist :create :if-exists :supersede) + (format f "/OUT:~A ~A ~{~&\"~A\"~}" + output-name o-name ld-libs)) + (safe-run-program "link" '("-lib" "-nologo" "@static_lib.tmp"))) + (when (probe-file "static_lib.tmp") + (cmp-delete-file "static_lib.tmp")))) + +(defun static-lib-ar (lib object-files) + (let ((lib (brief-namestring lib))) + (when (probe-file lib) + (delete-file lib)) + (safe-run-program *ar* (list* "cr" lib (mapcar #'brief-namestring object-files))) + (safe-run-program *ranlib* (list lib)))) + +(defun compiler-cc (c-pathname o-pathname) + (safe-run-program + *cc* + `("-I." + ,@(precompiled-header-flags) + ,(concatenate 'string "-I" (fix-for-mingw (ecl-include-directory))) + ,@(split-program-options *cc-flags*) + ,@(and (>= (cmp-env-optimization 'speed) 2) + (split-program-options *cc-optimize*)) + "-c" + ,(brief-namestring c-pathname) + #-msvc + ,@(list "-o" (brief-namestring o-pathname)) + #+msvc + ,(concatenate 'string "-Fo" (brief-namestring o-pathname)) + ,@(split-program-options *user-cc-flags*)))) +;;; Since the SUN4 assembler loops with big files, you might want to use this: +;;; (format nil "~A ~@[~*-O1~] -S -I. -I~A -w ~A ; as -o ~A ~A" +;;; *cc* (>= *speed* 2) +;;; *include-directory* +;;; (namestring c-pathname) +;;; (namestring o-pathname) +;;; (namestring s-pathname)) + + +(defun need-to-dump-precompiled-header () + (let* ((config *precompiled-header-cc-config*) + (need-to-dump (or (null config) + (not (eq (svref config 0) *cc*)) + (not (eq (svref config 1) (ecl-include-directory))) + (not (eq (svref config 2) *cc-flags*)) + (not (eq (svref config 3) *cc-optimize*)) + (not (eq (svref config 4) *user-cc-flags*))))) + (when need-to-dump + (setf *precompiled-header-cc-config* + (vector *cc* (ecl-include-directory) *cc-flags* + *cc-optimize* *user-cc-flags*))) + need-to-dump)) + +(defun precompiled-header-flags () + (when *use-precompiled-headers* + (when (need-to-dump-precompiled-header) + (handler-case + (dump-precompiled-header) + (error (err) + (setf *use-precompiled-headers* nil + *precompiled-header-flags* nil + *precompiled-header-cc-config* nil) + (cmpnote "Disabling precompiled header files due to error:~% ~A" err)))) + *precompiled-header-flags*)) + +#+msvc +(defun dump-precompiled-header () + ;; The way precompiled headers work on msvc is not compatible with + ;; what we want to use them for. The msvc compiler creates a + ;; precompiled header file out of ordinary source files by + ;; processing them up to a certain point at which all needed headers + ;; are included. This creates both a precompiled header and a object + ;; file. The object file created by this compilation must be + ;; included in all binaries which are linked together from other + ;; source files compiled using the precompiled header. Thus, we + ;; would need to include the first object file created in a session + ;; in all further object files if we wanted to support that. + (error "Precompiled headers are not supported for msvc.")) + +#-msvc +(defun dump-precompiled-header () + (let* ((input-file (make-pathname + :directory (append (pathname-directory (ecl-include-directory)) + '("ecl")) + :defaults (ecl-include-directory) + :name "ecl-cmp" + :type "h")) + (output-dir (merge-pathnames + (format nil "ecl-include~4,'0x/" (random #xffff)) + (translate-logical-pathname "TMP:"))) + (output-file (compile-file-pathname + (make-pathname :name "ecl-cmp" :defaults output-dir) + :type :precompiled-header))) + (ensure-directories-exist output-dir) + (push output-dir *files-to-be-deleted*) + (safe-run-program + *cc* + `("-x" "c-header" + ,(fix-for-mingw (namestring input-file)) + ,(concatenate 'string "-I" (fix-for-mingw (ecl-include-directory))) + ,@(split-program-options *cc-flags*) + ,@(split-program-options *cc-optimize*) + "-o" + ,(fix-for-mingw (namestring output-file)) + ,@(split-program-options *user-cc-flags*))) + (push output-file *files-to-be-deleted*) + (setf *precompiled-header-flags* + (list (concatenate 'string "-I" (namestring output-dir)) + "-include" + (concatenate 'string (namestring output-dir) "ecl-cmp.h"))))) + + +;;; Collecting necessary information + +(defun ecl-include-directory () + "Finds the directory in which the header files were installed." + (cond ((and *ecl-include-directory* + (probe-file (merge-pathnames "ecl/config.h" *ecl-include-directory*))) + *ecl-include-directory*) + ((probe-file "SYS:ecl;config.h") + (setf *ecl-include-directory* (namestring (translate-logical-pathname "SYS:")))) + ((error "Unable to find include directory")))) + +(defun ecl-library-directory () + "Finds the directory in which the ECL core library was installed." + (cond ((and *ecl-library-directory* + (probe-file (merge-pathnames (compile-file-pathname "ecl" :type + #+dlopen :shared-library + #-dlopen :static-library) + *ecl-library-directory*))) + *ecl-library-directory*) + ((probe-file "SYS:BUILD-STAMP") + (setf *ecl-library-directory* (namestring (translate-logical-pathname "SYS:")))) + ((error "Unable to find library directory")))) + +(defun guess-kind (pathname) + "Given a file name, guess whether it is an object file, a library, a program +or a loadable module." + (let ((record (assoc (pathname-type pathname) + '((#.+object-file-extension+ :object) + ("o" :object) + ("obj" :object) + ("c" :c) + (#.+static-library-extension+ :static-library) + ("lib" :static-library) + ("a" :static-library) + (#.+shared-library-extension+ :shared-library) + ("dylib" :shared-library) + ("dll" :shared-library) + ("so" :shared-library) + ("fas" :fasl)) + :test #'string-equal))) + (if record + (second record) + (progn + (warn "File ~s is of no known file type. Assuming it is an object file." + pathname) + :object)))) + +(defun guess-ld-libs (pathname &key (kind (guess-kind pathname))) + "Given a file name, return the compiler command line argument to link this file in." + (case kind + ((:object :c) + (brief-namestring pathname)) + ((:fasl :fas) + nil) + ((:static-library :lib) + (brief-namestring pathname)) + ((:shared-library :dll) + (brief-namestring pathname)) + ((:program) + nil) + (otherwise + (error "C::BUILDER cannot accept files of kind ~s" kind)))) + +(defun system-ld-flag (library) + "Given a symbol, try to find a library that matches it, either by looking in the +filesystem or in the database of ASDF modules." + (let ((asdf #+asdf (find-package "ASDF")) + system) + (labels ((asdfsym (x) (find-symbol (string x) asdf)) + (asdfcall (fun &rest rest) (apply (asdfsym fun) rest)) + (system-output (system type) + (let ((build (make-instance (asdfsym :build-op) :type type))) + (first (asdfcall :output-files build system)))) + (existing-system-output (system type) + (let ((o (system-output system type))) + (and o (setf o (probe-file o)) (namestring o)))) + (find-archive (system) + (or (existing-system-output system :library) + (existing-system-output system :shared-library))) + (fallback () + (translate-logical-pathname + (merge-pathnames + "SYS:" + (compile-file-pathname (string-downcase library) + :type :library))))) + (or + #-ecl-min + (and asdf + (setf system (asdfcall :find-system library nil)) + (find-archive system)) + (fallback))))) + + +;;; Target-specific invocations. + +#+dlopen +(defun shared-cc (o-pathname object-files) + (let ((ld-flags (split-program-options *ld-shared-flags*)) + (ld-libs (split-program-options *ld-libs*))) + #+msvc + (setf ld-flags + (let ((implib (brief-namestring + (compile-file-pathname o-pathname :type :lib)))) + ;; MSVC linker options are added at the end, after the + ;; /link flag, because they are not processed by the + ;; compiler, but by the linker + (append ld-flags + (list (concatenate 'string "/LIBPATH:" + (ecl-library-directory)) + (concatenate 'string "/IMPLIB:" implib))))) + #+mingw32 + (setf ld-flags (list* "-shared" ld-flags)) + (linker-cc o-pathname object-files :type :dll + :ld-flags ld-flags :ld-libs ld-libs))) + +#+dlopen +(defun bundle-cc (o-pathname init-name object-files) + (declare (ignore init-name)) + (let ((ld-flags (split-program-options *ld-bundle-flags*)) + (ld-libs (split-program-options *ld-libs*))) + #+msvc + (setf ld-flags + (let ((implib (brief-namestring + (compile-file-pathname o-pathname :type :import-library)))) + ;; MSVC linker options are added at the end, after the + ;; /link flag, because they are not processed by the + ;; compiler, but by the linker + (append ld-flags + (list + ;; Not needed because we use ECL_DLLEXPORT + ;; (concatenate 'string "/EXPORT:" init-name) + (concatenate 'string "/LIBPATH:" + (ecl-library-directory)) + (concatenate 'string "/IMPLIB:" implib))))) + #+mingw32 + (setf ld-flags (list* "-shared" "-Wl,--export-all-symbols" ld-flags)) + (linker-cc o-pathname object-files :type :fasl + :ld-flags ld-flags :ld-libs ld-libs))) + +(defconstant +lisp-program-header+ " +#include + +#ifdef __cplusplus +#define ECL_CPP_TAG \"C\" +#else +#define ECL_CPP_TAG +#endif + +~:{ extern ECL_CPP_TAG void ~A(cl_object);~%~} + +") + +;; +;; This format string contains the structure of the code that initializes +;; a program, a library, a module, etc. Basically, it processes a codeblock +;; just like in a normal compiled file, but then adds all the codeblocks of +;; its corresponding modules. +;; +(defconstant +lisp-program-init+ " +#ifdef __cplusplus +extern \"C\" +#endif + +ECL_DLLEXPORT +void ~A(cl_object cblock) +{ + /* + * This function is first invoked with a pointer to a Cblock + * structure, so that the function initializes it, and then + * it is invoked with OBJNULL, to force initialization. + */ + static cl_object Cblock = OBJNULL; + if (cblock != OBJNULL) { + Cblock = cblock; +#ifndef ECL_DYNAMIC_VV + cblock->cblock.data = NULL; +#endif + cblock->cblock.data_size = 0; + return; + } + Cblock->cblock.data_text = (const cl_object *)\"~A\"; + ~A +{ + /* + * At this point Cblock contains the cblock of the parent. + * Notice how the modules are linked to the parent forming a + * circular chain. This disables the garbage collection of + * the library until _ALL_ functions in all modules are unlinked. + */ + cl_object current = OBJNULL, next = Cblock; +~:{ + current = ecl_make_codeblock(); + current->cblock.next = next; + next = current; + ecl_init_module(current, ~A); +~} + Cblock->cblock.next = current; +} + ~A +} +") + +(defconstant +lisp-init-wrapper+ " +#ifdef __cplusplus +extern \"C\" +#endif + +ECL_DLLEXPORT +void ~A(cl_object cblock) +{ + /* This is a wrapper around the randomized init function name. */ + ~A(cblock); +} +") + +(defconstant +lisp-program-main+ " +extern int +main(int argc, char **argv) +{ + cl_boot(argc, argv); + ECL_CATCH_ALL_BEGIN(ecl_process_env()) { + ~A + ecl_init_module(OBJNULL, ~A); + ~A + } ECL_CATCH_ALL_END; + si_exit(0); +} +") + +(defconstant +lisp-library-main+ " +extern int +~A(int argc, char **argv) +{ + cl_boot(argc, argv); + ECL_CATCH_ALL_BEGIN(ecl_process_env()) { + ~A + ecl_init_module(OBJNULL, ~A); + ~A + } ECL_CATCH_ALL_END; + return 0; +} +") + +#+:win32 +(defconstant +lisp-program-winmain+ " +#include +int +WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdShow) +{ + char **argv; + int argc; + ecl_get_commandline_args(&argc, &argv); + cl_boot(argc, argv); + ECL_CATCH_ALL_BEGIN(ecl_process_env()) { + ~A + ecl_init_module(OBJNULL, ~A); + ~A + } ECL_CATCH_ALL_END; + si_exit(0); + for (int i = 0; i < argc; i++) { + LocalFree(argv[i]); + } + LocalFree(argv); +} +") + + +;;; Code generation + +(defun compiler-pass/generate-cxx (c-pathname h-pathname data-pathname init-name + &key input-designator) + + (setq *compiler-phase* 't2) + (with-open-file (*compiler-output1* c-pathname :direction :output + :if-does-not-exist :create + :if-exists :supersede) + (wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version)) + #-ecl-min + (multiple-value-bind (second minute hour day month year) + (get-decoded-time) + (declare (ignore second)) + (wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute) + (wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type))) + (wt-comment-nl "Source: ~A" input-designator) + (with-open-file (*compiler-output2* h-pathname :direction :output + :if-does-not-exist :create + :if-exists :supersede) + (wt-nl1 "#include " *cmpinclude*) + (ctop-write init-name h-pathname data-pathname) + (terpri *compiler-output1*) + (terpri *compiler-output2*))) + (data-c-dump data-pathname)) + + +;;; The builder. + +(defun builder (target output-name + &key + lisp-files ld-flags ld-libs + (init-name nil) + (main-name nil) + (prologue-code "") + (epilogue-code (when (eq target :program) '(SI::TOP-LEVEL T))) + #+:win32 (system :console) + &aux + (*suppress-compiler-messages* (or *suppress-compiler-messages* + (not *compile-verbose*))) + (target (normalize-build-target-name target)) + (output-name (if (or (symbolp output-name) (stringp output-name)) + (compile-file-pathname output-name :type target) + output-name)) + ;; wrap-name is the init function name defined by a programmer + (wrap-name init-name)) + ;; init-name should always be unique + (setf init-name (compute-init-name output-name :kind target)) + (cond ((null wrap-name) nil) + ((equal init-name wrap-name) ; fixup for ASDF + (cmpwarn "Parameter `init-name' is the same as the result of an internal function `compute-init-name'. Ignoring.") + (setf wrap-name nil)) + ((null (member target '(:static-library :shared-library))) + (cmpwarn "Supplying `init-name' is valid only for libraries. Ignoring."))) + (unless main-name + (setf main-name (compute-init-name output-name :kind target :prefix "main_"))) + + + ;; + ;; The epilogue-code can be either a string made of C code, or a + ;; lisp form. In the latter case we add some additional C code to + ;; clean up, and the lisp form is stored in a text representation, + ;; to avoid using the compiler. + ;; + (cond ((null epilogue-code) + (setf epilogue-code "")) + ((stringp epilogue-code) + nil) + (t + (with-standard-io-syntax + (setq epilogue-code + (with-output-to-string (stream) + (princ "{ const char *lisp_code = " stream) + (wt-filtered-data (write-to-string epilogue-code) stream) + (princ "; +cl_object output; +si_select_package(ecl_make_constant_base_string(\"CL-USER\", 7)); +output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL); +}" stream) + ))))) + (cond ((null prologue-code) + (setf prologue-code "")) + ((stringp prologue-code) + ) + (t + (with-standard-io-syntax + (setq prologue-code + (with-output-to-string (stream) + (princ "{ const char *lisp_code = " stream) + (wt-filtered-data (write-to-string prologue-code) stream) + (princ "; +cl_object output; +si_select_package(ecl_make_constant_base_string(\"CL-USER\", 7)); +output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL); +}" stream) + ))))) + ;; + ;; When a module is built out of several object files, we have to + ;; create an additional object file that initializes those ones. + ;; This routine is responsible for creating this file. + ;; + ;; To avoid name clashes, this object file will have a temporary + ;; file name (tmp-name). + ;; + (let* ((tmp-names (safe-mkstemp #P"TMP:ECLINIT")) + (tmp-name (first tmp-names)) + (c-name (brief-namestring + (compile-file-pathname tmp-name :type :c))) + (o-name (brief-namestring + (compile-file-pathname tmp-name :type :object))) + submodules + c-file) + (dolist (item (reverse lisp-files)) + (let* ((path (etypecase item + (symbol (system-ld-flag item)) + (pathname item) + (string (parse-namestring item)))) + (kind (guess-kind path))) + + ;; Shared and static libraries may be linked in a program or + ;; fasl, but if we try to create a `static-library' from two + ;; static libraries we will end with broken binary because + ;; `ar' works fine only with object files. See #274. + (unless (member kind `(,@(unless (eql target :static-library) + '(:shared-library :static-library)) + :object :c)) + (error "C::BUILDER does not accept a file ~s of kind ~s for target ~s" item kind target)) + (let ((init-fn (guess-init-name path kind)) + (guessed-libs (guess-ld-libs path))) + ;; We should give a warning that we cannot link this module in + (when guessed-libs + (push guessed-libs ld-libs)) + (when init-fn + (push (list init-fn path) submodules))))) + (setq c-file (open c-name :direction :output :external-format :default)) + (format c-file +lisp-program-header+ submodules) + + (let ((init-tag (init-name-tag init-name :kind target))) + (ecase target + (:program + (format c-file +lisp-program-init+ init-name init-tag "" submodules "") + ;; we don't need wrapper in the program, we have main for that + ;(format c-file +lisp-init-wrapper+ wrap-name init-name) + (format c-file + #+:win32 (ecase system + (:console +lisp-program-main+) + (:windows +lisp-program-winmain+)) + #-:win32 +lisp-program-main+ + prologue-code init-name epilogue-code) + (close c-file) + (compiler-cc c-name o-name) + (linker-cc output-name (append ld-flags (list (namestring o-name)) + ld-libs))) + (:static-library + (format c-file +lisp-program-init+ + init-name init-tag prologue-code submodules epilogue-code) + (when wrap-name + (format c-file +lisp-init-wrapper+ wrap-name init-name)) + (format c-file +lisp-library-main+ + main-name prologue-code init-name epilogue-code) + (close c-file) + (compiler-cc c-name o-name) + (when (probe-file output-name) (delete-file output-name)) + (linker-ar output-name o-name ld-libs)) + #+dlopen + (:shared-library + (format c-file +lisp-program-init+ + init-name init-tag prologue-code submodules epilogue-code) + (when wrap-name + (format c-file +lisp-init-wrapper+ wrap-name init-name)) + (format c-file +lisp-library-main+ + main-name prologue-code init-name epilogue-code) + (close c-file) + (compiler-cc c-name o-name) + (shared-cc output-name (append ld-flags (list o-name) + ld-libs))) + #+dlopen + (:fasl + (format c-file +lisp-program-init+ init-name init-tag prologue-code + submodules epilogue-code) + ;; we don't need wrapper in the fasl, we scan for init function name + ;(format c-file +lisp-init-wrapper+ wrap-name init-name) + (close c-file) + (compiler-cc c-name o-name) + (bundle-cc output-name init-name (append ld-flags (list o-name) + ld-libs)))) + (mapc 'cmp-delete-file tmp-names) + (cmp-delete-file c-name) + (cmp-delete-file o-name) + output-name))) + +(defun build-fasl (&rest args) + (apply #'builder :fasl args)) + +(defun build-program (&rest args) + (apply #'builder :program args)) + +(defun build-static-library (&rest args) + (apply #'builder :static-library args)) + +(defun build-shared-library (&rest args) + #-dlopen + (error "Dynamically loadable libraries not supported in this system.") + #+dlopen + (apply #'builder :shared-library args)) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index 34e010de7..a3641632e 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -20,30 +20,6 @@ (in-package "COMPILER") -(defun safe-mkstemp (template) - ;; We do several things here. One is to check for success in MKSTEMP, - ;; the other one is to ensure that the output of this function _always_ - ;; carries a file type -- this solves a problem with filesystems where - ;; mkstemp may introduce one or more dots in the name causing several - ;; functions below to ignore parts of the name. Note that this forces - ;; us to have two files per temp: one with and one without extension. - (let* ((base (si::mkstemp template))) - (when base - (let ((output (make-pathname :name - (concatenate 'string (pathname-name base) - (or (pathname-type base) "")) - :type "tmp" - :defaults base))) - (if (and (not (probe-file output)) (si:copy-file base output)) - (setf base (list (truename output) (truename base))) - (progn (delete-file base) (setf base nil))))) - (unless base - (error "Unable to create temporary file~%~ - ~AXXXXXX -Make sure you have enough free space in disk, check permissions or set~%~ -the environment variable TMPDIR to a different value." template)) - base)) - (defun compile-file-pathname (name &key (output-file T) (type nil type-supplied-p) verbose print c-file h-file data-file system-p load external-format source-truename @@ -74,544 +50,6 @@ the environment variable TMPDIR to a different value." template)) (t (make-pathname :type extension :defaults name))))) -#+msvc -(defun delete-msvc-generated-files (output-pathname) - (loop for i in '("implib" "exp" "ilk" ) - for full = (make-pathname :type i :defaults output-pathname) - for truename = (probe-file full) - when truename - do (cmp-delete-file truename))) - -#+msvc -(defun embed-manifest-file (o-file &optional (type :dll)) - (let* ((real-file (probe-file o-file))) - (when real-file - (let* ((manifest-namestring (concatenate 'string (namestring o-file) - ".manifest")) - (resource-code (ecase type - ((:dll :shared-library :fasl :fas) 2) - ((:program) 1))) - (resource-option (format nil "-outputresource:~A;~D" - (namestring real-file) - resource-code)) - (manifest (probe-file manifest-namestring))) - (when manifest - (safe-run-program "mt" - (list "-nologo" - "-manifest" - manifest-namestring - resource-option)) - (delete-file manifest)))))) - -(defun cmp-delete-file (file) - (cond ((null *delete-files*)) - ((ext:getenv "ECL_PRESERVE_FILES")) - ((null (probe-file file))) - (*debug-compiler* - (cmpprogress "~%Postponing deletion of ~A" file) - (push file *files-to-be-deleted*)) - (t - (delete-file file)))) - -(push #'(lambda () (mapc #'delete-file *files-to-be-deleted*)) - si::*exit-hooks*) - -#-mingw32 -(defmacro fix-for-mingw (directory-namestring) - directory-namestring) - -#+mingw32 -(defun fix-for-mingw (directory-namestring) - (let ((x (string-right-trim '(#\\ #\/) directory-namestring))) - (if (zerop (length x)) "/" x))) - -(defun get-deprecated-user-ld-flags () - (let ((flags (split-program-options *user-ld-flags*))) - (when flags - (cmpwarn "The variable ~s is deprecated, please use ~s and ~s instead." - '*user-ld-flags* '*user-linker-flags* '*user-linker-libs*)) - flags)) - -#+msvc -(defun linker-cc (o-pathname object-files &key - (type :program) - (ld-flags (split-program-options *ld-flags*)) - (ld-libs (split-program-options *ld-libs*))) - (safe-run-program - *ld* - `(,(concatenate 'string "-Fe" (brief-namestring o-pathname)) - ,@(split-program-options *ld-rpath*) - ,@(split-program-options *user-linker-flags*) - ,@object-files - ,@ld-flags - ,@(split-program-options *user-linker-libs*) - ,@(get-deprecated-user-ld-flags) - ,@ld-libs - ,(if (eq type :program) - (concatenate 'string "/IMPLIB:prog" (file-namestring o-pathname) ".lib") - "") - ,(concatenate 'string "/LIBPATH:" - (ecl-library-directory)))) - (embed-manifest-file o-pathname type) - (delete-msvc-generated-files o-pathname)) - -#-msvc -(defun linker-cc (o-pathname object-files &key - (type :program) - (ld-flags (split-program-options *ld-flags*)) - (ld-libs (split-program-options *ld-libs*))) - (declare (ignore type)) - (safe-run-program - *ld* - `("-o" ,(brief-namestring o-pathname) - ,(concatenate 'string "-L" (fix-for-mingw (ecl-library-directory))) - ,@(split-program-options *user-linker-flags*) - ,@ld-flags - ,@object-files - ,@(and *ld-rpath* (list *ld-rpath*)) - ,@(split-program-options *user-linker-libs*) - ,@(get-deprecated-user-ld-flags) - ,@ld-libs))) - -(defun linker-ar (output-name o-name ld-libs) - #-msvc - (static-lib-ar (namestring output-name) - (list* (brief-namestring o-name) ld-libs)) - #+msvc - (unwind-protect - (progn - (with-open-file (f "static_lib.tmp" :direction :output - :if-does-not-exist :create :if-exists :supersede) - (format f "/OUT:~A ~A ~{~&\"~A\"~}" - output-name o-name ld-libs)) - (safe-run-program "link" '("-lib" "-nologo" "@static_lib.tmp"))) - (when (probe-file "static_lib.tmp") - (cmp-delete-file "static_lib.tmp")))) - -(defun static-lib-ar (lib object-files) - (let ((lib (brief-namestring lib))) - (when (probe-file lib) - (delete-file lib)) - (safe-run-program *ar* (list* "cr" lib (mapcar #'brief-namestring object-files))) - (safe-run-program *ranlib* (list lib)))) - -#+dlopen -(defun shared-cc (o-pathname object-files) - (let ((ld-flags (split-program-options *ld-shared-flags*)) - (ld-libs (split-program-options *ld-libs*))) - #+msvc - (setf ld-flags - (let ((implib (brief-namestring - (compile-file-pathname o-pathname :type :lib)))) - ;; MSVC linker options are added at the end, after the - ;; /link flag, because they are not processed by the - ;; compiler, but by the linker - (append ld-flags - (list (concatenate 'string "/LIBPATH:" - (ecl-library-directory)) - (concatenate 'string "/IMPLIB:" implib))))) - #+mingw32 - (setf ld-flags (list* "-shared" ld-flags)) - (linker-cc o-pathname object-files :type :dll - :ld-flags ld-flags :ld-libs ld-libs))) - -#+dlopen -(defun bundle-cc (o-pathname init-name object-files) - (declare (ignore init-name)) - (let ((ld-flags (split-program-options *ld-bundle-flags*)) - (ld-libs (split-program-options *ld-libs*))) - #+msvc - (setf ld-flags - (let ((implib (brief-namestring - (compile-file-pathname o-pathname :type :import-library)))) - ;; MSVC linker options are added at the end, after the - ;; /link flag, because they are not processed by the - ;; compiler, but by the linker - (append ld-flags - (list - ;; Not needed because we use ECL_DLLEXPORT - ;; (concatenate 'string "/EXPORT:" init-name) - (concatenate 'string "/LIBPATH:" - (ecl-library-directory)) - (concatenate 'string "/IMPLIB:" implib))))) - #+mingw32 - (setf ld-flags (list* "-shared" "-Wl,--export-all-symbols" ld-flags)) - (linker-cc o-pathname object-files :type :fasl - :ld-flags ld-flags :ld-libs ld-libs))) - -(defconstant +lisp-program-header+ " -#include - -#ifdef __cplusplus -#define ECL_CPP_TAG \"C\" -#else -#define ECL_CPP_TAG -#endif - -~:{ extern ECL_CPP_TAG void ~A(cl_object);~%~} - -") - -;; -;; This format string contains the structure of the code that initializes -;; a program, a library, a module, etc. Basically, it processes a codeblock -;; just like in a normal compiled file, but then adds all the codeblocks of -;; its corresponding modules. -;; -(defconstant +lisp-program-init+ " -#ifdef __cplusplus -extern \"C\" -#endif - -ECL_DLLEXPORT -void ~A(cl_object cblock) -{ - /* - * This function is first invoked with a pointer to a Cblock - * structure, so that the function initializes it, and then - * it is invoked with OBJNULL, to force initialization. - */ - static cl_object Cblock = OBJNULL; - if (cblock != OBJNULL) { - Cblock = cblock; -#ifndef ECL_DYNAMIC_VV - cblock->cblock.data = NULL; -#endif - cblock->cblock.data_size = 0; - return; - } - Cblock->cblock.data_text = (const cl_object *)\"~A\"; - ~A -{ - /* - * At this point Cblock contains the cblock of the parent. - * Notice how the modules are linked to the parent forming a - * circular chain. This disables the garbage collection of - * the library until _ALL_ functions in all modules are unlinked. - */ - cl_object current = OBJNULL, next = Cblock; -~:{ - current = ecl_make_codeblock(); - current->cblock.next = next; - next = current; - ecl_init_module(current, ~A); -~} - Cblock->cblock.next = current; -} - ~A -} -") - -(defconstant +lisp-init-wrapper+ " -#ifdef __cplusplus -extern \"C\" -#endif - -ECL_DLLEXPORT -void ~A(cl_object cblock) -{ - /* This is a wrapper around the randomized init function name. */ - ~A(cblock); -} -") - -(defconstant +lisp-program-main+ " -extern int -main(int argc, char **argv) -{ - cl_boot(argc, argv); - ECL_CATCH_ALL_BEGIN(ecl_process_env()) { - ~A - ecl_init_module(OBJNULL, ~A); - ~A - } ECL_CATCH_ALL_END; - si_exit(0); -} -") - -(defconstant +lisp-library-main+ " -extern int -~A(int argc, char **argv) -{ - cl_boot(argc, argv); - ECL_CATCH_ALL_BEGIN(ecl_process_env()) { - ~A - ecl_init_module(OBJNULL, ~A); - ~A - } ECL_CATCH_ALL_END; - return 0; -} -") - -#+:win32 -(defconstant +lisp-program-winmain+ " -#include -int -WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdShow) -{ - char **argv; - int argc; - ecl_get_commandline_args(&argc, &argv); - cl_boot(argc, argv); - ECL_CATCH_ALL_BEGIN(ecl_process_env()) { - ~A - ecl_init_module(OBJNULL, ~A); - ~A - } ECL_CATCH_ALL_END; - si_exit(0); - for (int i = 0; i < argc; i++) { - LocalFree(argv[i]); - } - LocalFree(argv); -} -") - -(defun guess-kind (pathname) - "Given a file name, guess whether it is an object file, a library, a program -or a loadable module." - (let ((record (assoc (pathname-type pathname) - '((#.+object-file-extension+ :object) - ("o" :object) - ("obj" :object) - ("c" :c) - (#.+static-library-extension+ :static-library) - ("lib" :static-library) - ("a" :static-library) - (#.+shared-library-extension+ :shared-library) - ("dylib" :shared-library) - ("dll" :shared-library) - ("so" :shared-library) - ("fas" :fasl)) - :test #'string-equal))) - (if record - (second record) - (progn - (warn "File ~s is of no known file type. Assuming it is an object file." - pathname) - :object)))) - -(defun guess-ld-libs (pathname &key (kind (guess-kind pathname))) - "Given a file name, return the compiler command line argument to link this file in." - (case kind - ((:object :c) - (brief-namestring pathname)) - ((:fasl :fas) - nil) - ((:static-library :lib) - (brief-namestring pathname)) - ((:shared-library :dll) - (brief-namestring pathname)) - ((:program) - nil) - (otherwise - (error "C::BUILDER cannot accept files of kind ~s" kind)))) - -(defun system-ld-flag (library) - "Given a symbol, try to find a library that matches it, either by looking in the -filesystem or in the database of ASDF modules." - (let ((asdf #+asdf (find-package "ASDF")) - system) - (labels ((asdfsym (x) (find-symbol (string x) asdf)) - (asdfcall (fun &rest rest) (apply (asdfsym fun) rest)) - (system-output (system type) - (let ((build (make-instance (asdfsym :build-op) :type type))) - (first (asdfcall :output-files build system)))) - (existing-system-output (system type) - (let ((o (system-output system type))) - (and o (setf o (probe-file o)) (namestring o)))) - (find-archive (system) - (or (existing-system-output system :library) - (existing-system-output system :shared-library))) - (fallback () - (translate-logical-pathname - (merge-pathnames - "SYS:" - (compile-file-pathname (string-downcase library) - :type :library))))) - (or - #-ecl-min - (and asdf - (setf system (asdfcall :find-system library nil)) - (find-archive system)) - (fallback))))) - -(defun builder (target output-name - &key - lisp-files ld-flags ld-libs - (init-name nil) - (main-name nil) - (prologue-code "") - (epilogue-code (when (eq target :program) '(SI::TOP-LEVEL T))) - #+:win32 (system :console) - &aux - (*suppress-compiler-messages* (or *suppress-compiler-messages* - (not *compile-verbose*))) - (target (normalize-build-target-name target)) - (output-name (if (or (symbolp output-name) (stringp output-name)) - (compile-file-pathname output-name :type target) - output-name)) - ;; wrap-name is the init function name defined by a programmer - (wrap-name init-name)) - ;; init-name should always be unique - (setf init-name (compute-init-name output-name :kind target)) - (cond ((null wrap-name) nil) - ((equal init-name wrap-name) ; fixup for ASDF - (cmpwarn "Parameter `init-name' is the same as the result of an internal function `compute-init-name'. Ignoring.") - (setf wrap-name nil)) - ((null (member target '(:static-library :shared-library))) - (cmpwarn "Supplying `init-name' is valid only for libraries. Ignoring."))) - (unless main-name - (setf main-name (compute-init-name output-name :kind target :prefix "main_"))) - - - ;; - ;; The epilogue-code can be either a string made of C code, or a - ;; lisp form. In the latter case we add some additional C code to - ;; clean up, and the lisp form is stored in a text representation, - ;; to avoid using the compiler. - ;; - (cond ((null epilogue-code) - (setf epilogue-code "")) - ((stringp epilogue-code) - nil) - (t - (with-standard-io-syntax - (setq epilogue-code - (with-output-to-string (stream) - (princ "{ const char *lisp_code = " stream) - (wt-filtered-data (write-to-string epilogue-code) stream) - (princ "; -cl_object output; -si_select_package(ecl_make_constant_base_string(\"CL-USER\", 7)); -output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL); -}" stream) - ))))) - (cond ((null prologue-code) - (setf prologue-code "")) - ((stringp prologue-code) - ) - (t - (with-standard-io-syntax - (setq prologue-code - (with-output-to-string (stream) - (princ "{ const char *lisp_code = " stream) - (wt-filtered-data (write-to-string prologue-code) stream) - (princ "; -cl_object output; -si_select_package(ecl_make_constant_base_string(\"CL-USER\", 7)); -output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL); -}" stream) - ))))) - ;; - ;; When a module is built out of several object files, we have to - ;; create an additional object file that initializes those ones. - ;; This routine is responsible for creating this file. - ;; - ;; To avoid name clashes, this object file will have a temporary - ;; file name (tmp-name). - ;; - (let* ((tmp-names (safe-mkstemp #P"TMP:ECLINIT")) - (tmp-name (first tmp-names)) - (c-name (brief-namestring - (compile-file-pathname tmp-name :type :c))) - (o-name (brief-namestring - (compile-file-pathname tmp-name :type :object))) - submodules - c-file) - (dolist (item (reverse lisp-files)) - (let* ((path (etypecase item - (symbol (system-ld-flag item)) - (pathname item) - (string (parse-namestring item)))) - (kind (guess-kind path))) - - ;; Shared and static libraries may be linked in a program or - ;; fasl, but if we try to create a `static-library' from two - ;; static libraries we will end with broken binary because - ;; `ar' works fine only with object files. See #274. - (unless (member kind `(,@(unless (eql target :static-library) - '(:shared-library :static-library)) - :object :c)) - (error "C::BUILDER does not accept a file ~s of kind ~s for target ~s" item kind target)) - (let ((init-fn (guess-init-name path kind)) - (guessed-libs (guess-ld-libs path))) - ;; We should give a warning that we cannot link this module in - (when guessed-libs - (push guessed-libs ld-libs)) - (when init-fn - (push (list init-fn path) submodules))))) - (setq c-file (open c-name :direction :output :external-format :default)) - (format c-file +lisp-program-header+ submodules) - - (let ((init-tag (init-name-tag init-name :kind target))) - (ecase target - (:program - (format c-file +lisp-program-init+ init-name init-tag "" submodules "") - ;; we don't need wrapper in the program, we have main for that - ;(format c-file +lisp-init-wrapper+ wrap-name init-name) - (format c-file - #+:win32 (ecase system - (:console +lisp-program-main+) - (:windows +lisp-program-winmain+)) - #-:win32 +lisp-program-main+ - prologue-code init-name epilogue-code) - (close c-file) - (compiler-cc c-name o-name) - (linker-cc output-name (append ld-flags (list (namestring o-name)) - ld-libs))) - (:static-library - (format c-file +lisp-program-init+ - init-name init-tag prologue-code submodules epilogue-code) - (when wrap-name - (format c-file +lisp-init-wrapper+ wrap-name init-name)) - (format c-file +lisp-library-main+ - main-name prologue-code init-name epilogue-code) - (close c-file) - (compiler-cc c-name o-name) - (when (probe-file output-name) (delete-file output-name)) - (linker-ar output-name o-name ld-libs)) - #+dlopen - (:shared-library - (format c-file +lisp-program-init+ - init-name init-tag prologue-code submodules epilogue-code) - (when wrap-name - (format c-file +lisp-init-wrapper+ wrap-name init-name)) - (format c-file +lisp-library-main+ - main-name prologue-code init-name epilogue-code) - (close c-file) - (compiler-cc c-name o-name) - (shared-cc output-name (append ld-flags (list o-name) - ld-libs))) - #+dlopen - (:fasl - (format c-file +lisp-program-init+ init-name init-tag prologue-code - submodules epilogue-code) - ;; we don't need wrapper in the fasl, we scan for init function name - ;(format c-file +lisp-init-wrapper+ wrap-name init-name) - (close c-file) - (compiler-cc c-name o-name) - (bundle-cc output-name init-name (append ld-flags (list o-name) - ld-libs)))) - (mapc 'cmp-delete-file tmp-names) - (cmp-delete-file c-name) - (cmp-delete-file o-name) - output-name))) - -(defun build-fasl (&rest args) - (apply #'builder :fasl args)) - -(defun build-program (&rest args) - (apply #'builder :program args)) - -(defun build-static-library (&rest args) - (apply #'builder :static-library args)) - -(defun build-shared-library (&rest args) - #-dlopen - (error "Dynamically loadable libraries not supported in this system.") - #+dlopen - (apply #'builder :shared-library args)) - (defun compile-file (input-pathname &rest args &key @@ -638,8 +76,7 @@ output = si_safe_eval(2, ecl_read_from_cstring(lisp_code), ECL_NIL); (ext:*source-location* (cons source-truename 0)) (*suppress-compiler-messages* (or *suppress-compiler-messages* (not *compile-verbose*)))) - (declare (ignore output-file) - (notinline compiler-cc)) + (declare (notinline compiler-cc)) "Compiles the file specified by INPUT-PATHNAME and generates a fasl file specified by OUTPUT-FILE. If the filetype is not specified in INPUT-PATHNAME, then \".lsp\" is used as the default file type for the source file. LOAD @@ -658,7 +95,7 @@ compiled successfully, returns the pathname of the compiled file" (if (pathname-type input-pathname) (error 'file-error :pathname input-pathname) (dolist (ext '("lsp" "LSP" "lisp" "LISP") - (error 'file-error :pathname input-pathname)) + (error 'file-error :pathname input-pathname)) (setq *compile-file-pathname* (make-pathname :type ext :defaults input-pathname)) (when (probe-file *compile-file-pathname*) (return))))) @@ -669,7 +106,8 @@ compiled successfully, returns the pathname of the compiled file" (*compile-file-truename* input-file) (*compiler-in-use* *compiler-in-use*) (*load-time-values* nil) ;; Load time values are compiled - (output-file (apply #'compile-file-pathname input-file args)) + (output-file (apply #'compile-file-pathname input-file + :output-file output-file args)) (true-output-file nil) ;; Will be set at the end (c-pathname (apply #'compile-file-pathname output-file :output-file c-file :type :c args)) @@ -693,25 +131,22 @@ compiled successfully, returns the pathname of the compiled file" (setf (car ext:*source-location*) *compile-file-pathname*)) (compiler-pass1 stream source-offset)) (compiler-pass/propagate-types) - (compiler-pass2 c-pathname h-pathname data-pathname init-name - :input-designator (namestring input-pathname)) - (data-c-dump data-pathname) - (let ((o-pathname (if system-p - output-file - (compile-file-pathname output-file :type :object)))) - (compiler-cc c-pathname o-pathname) - #+dlopen - (unless system-p - (push o-pathname to-delete) - (bundle-cc (brief-namestring output-file) - init-name - (list (brief-namestring o-pathname))))) + (compiler-pass/generate-cxx c-pathname h-pathname data-pathname init-name + :input-designator (namestring input-pathname)) + (if system-p + (compiler-cc c-pathname output-file) + (let ((o-pathname (compile-file-pathname output-file :type :object))) + (compiler-cc c-pathname o-pathname) + (push o-pathname to-delete) + (bundle-cc (brief-namestring output-file) + init-name + (list (brief-namestring o-pathname))))) (if (setf true-output-file (probe-file output-file)) (cmpprogress "~&;;; Finished compiling ~a.~%;;;~%" (namestring input-pathname)) (cmperr "The C compiler failed to compile the intermediate file.")) (mapc #'cmp-delete-file to-delete) - (when (and load true-output-file (not system-p)) + (when load (load true-output-file :verbose *compile-verbose*))) ; with-compiler-env (compiler-output-values true-output-file compiler-conditions))) @@ -737,17 +172,17 @@ compiled successfully, returns the pathname of the compiled file" #+dlopen (defun compile (name &optional (def nil supplied-p) - &aux form data-pathname - (lexenv nil) - (*suppress-compiler-messages* (or *suppress-compiler-messages* - (not *compile-verbose*))) - (*compiler-in-use* *compiler-in-use*) - (*standard-output* *standard-output*) - (*error-output* *error-output*) - (*package* *package*) - (*compile-print* nil) - (*print-pretty* nil) - (si:*compiler-constants* t)) + &aux form data-pathname + (lexenv nil) + (*suppress-compiler-messages* (or *suppress-compiler-messages* + (not *compile-verbose*))) + (*compiler-in-use* *compiler-in-use*) + (*standard-output* *standard-output*) + (*error-output* *error-output*) + (*package* *package*) + (*compile-print* nil) + (*print-pretty* nil) + (si:*compiler-constants* t)) "Args: (name &optional definition) If DEFINITION is NIL, NAME must be the name of a not-yet-compiled function. @@ -760,7 +195,8 @@ If NAME is NIL, then the compiled function is not installed but is simply returned as the value of COMPILE. In any case, COMPILE creates temporary files, whose filenames begin with \"gazonk\", which are automatically deleted after compilation." - (unless (si:valid-function-name-p name) (error "~s is not a valid function name." name)) + (unless (si:valid-function-name-p name) + (error "~s is not a valid function name." name)) (cond ((and supplied-p def) (when (functionp def) @@ -803,13 +239,11 @@ after compilation." (compiler-pass1 form) (compiler-pass/propagate-types) (let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t)) - (compiler-pass2 c-pathname h-pathname data-pathname init-name - :input-designator (let* ((*print-circle* t) - (*print-length* 8) - (*print-depth* 4)) - (format nil "~W" def)))) - (data-c-dump data-pathname) - + (compiler-pass/generate-cxx c-pathname h-pathname data-pathname init-name + :input-designator (let* ((*print-circle* t) + (*print-length* 8) + (*print-depth* 4)) + (format nil "~W" def)))) (compiler-cc c-pathname o-pathname) (bundle-cc (brief-namestring so-pathname) init-name @@ -818,7 +252,6 @@ after compilation." (cmp-delete-file h-pathname) (cmp-delete-file o-pathname) (mapc 'cmp-delete-file tmp-names) - (cond ((probe-file so-pathname) (load so-pathname :verbose nil) (cmp-delete-file so-pathname)) @@ -838,10 +271,10 @@ after compilation." ;; function which does nothing but resignal ;; the compiler errors we got (loop for c in compiler-conditions - if (typep c 'compiler-error) - do (apply #'si::simple-program-error - (simple-condition-format-control c) - (simple-condition-format-arguments c))))))) + if (typep c 'compiler-error) + do (apply #'si::simple-program-error + (simple-condition-format-control c) + (simple-condition-format-arguments c))))))) ;; By unsetting GAZONK we avoid spurious references to the ;; loaded code. (set 'GAZONK nil) @@ -850,9 +283,9 @@ after compilation." (defun disassemble (thing &key (h-file nil) (data-file nil) &aux lexenv disassembled-form - (*compiler-in-use* *compiler-in-use*) - (*print-pretty* nil)) -"Compiles the form specified by THING and prints the intermediate C language + (*compiler-in-use* *compiler-in-use*) + (*print-pretty* nil)) + "Compiles the form specified by THING and prints the intermediate C language code for that form. But does not install the result of compilation. If THING is NIL, then the previously DISASSEMBLEd form is re-DISASSEMBLEd. If THING is a symbol that names a function not yet compiled, the function definition is @@ -945,75 +378,6 @@ from the C language code. NIL means \"do not create the file\"." (dolist (fun *local-funs*) (p1propagate (fun-lambda fun) nil)))) -(defun compiler-pass2 (c-pathname h-pathname data-pathname init-name - &key input-designator) - - (setq *compiler-phase* 't2) - (with-open-file (*compiler-output1* c-pathname :direction :output - :if-does-not-exist :create - :if-exists :supersede) - (wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version)) - #-ecl-min - (multiple-value-bind (second minute hour day month year) - (get-decoded-time) - (declare (ignore second)) - (wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute) - (wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type))) - (wt-comment-nl "Source: ~A" input-designator) - (with-open-file (*compiler-output2* h-pathname :direction :output - :if-does-not-exist :create - :if-exists :supersede) - (wt-nl1 "#include " *cmpinclude*) - (ctop-write init-name h-pathname data-pathname) - (terpri *compiler-output1*) - (terpri *compiler-output2*)))) - -(defun ecl-include-directory () - "Finds the directory in which the header files were installed." - (cond ((and *ecl-include-directory* - (probe-file (merge-pathnames "ecl/config.h" *ecl-include-directory*))) - *ecl-include-directory*) - ((probe-file "SYS:ecl;config.h") - (setf *ecl-include-directory* (namestring (translate-logical-pathname "SYS:")))) - ((error "Unable to find include directory")))) - -(defun ecl-library-directory () - "Finds the directory in which the ECL core library was installed." - (cond ((and *ecl-library-directory* - (probe-file (merge-pathnames (compile-file-pathname "ecl" :type - #+dlopen :shared-library - #-dlopen :static-library) - *ecl-library-directory*))) - *ecl-library-directory*) - ((probe-file "SYS:BUILD-STAMP") - (setf *ecl-library-directory* (namestring (translate-logical-pathname "SYS:")))) - ((error "Unable to find library directory")))) - -(defun compiler-cc (c-pathname o-pathname) - (safe-run-program - *cc* - `("-I." - ,@(precompiled-header-flags) - ,(concatenate 'string "-I" (fix-for-mingw (ecl-include-directory))) - ,@(split-program-options *cc-flags*) - ,@(and (>= (cmp-env-optimization 'speed) 2) - (split-program-options *cc-optimize*)) - "-c" - ,(brief-namestring c-pathname) - #-msvc - ,@(list "-o" (brief-namestring o-pathname)) - #+msvc - ,(concatenate 'string "-Fo" (brief-namestring o-pathname)) - ,@(split-program-options *user-cc-flags*)))) -; Since the SUN4 assembler loops with big files, you might want to use this: -; (format nil -; "~A ~@[~*-O1~] -S -I. -I~A -w ~A ; as -o ~A ~A" -; *cc* (>= *speed* 2) -; *include-directory* -; (namestring c-pathname) -; (namestring o-pathname) -; (namestring s-pathname)) - (defun print-compiler-info () (cmpprogress "~&;;; OPTIMIZE levels: Safety=~d, Space=~d, Speed=~d, Debug=~d~%;;;~%" *safety* *space* *speed* *debug*)) @@ -1022,78 +386,6 @@ from the C language code. NIL means \"do not create the file\"." (declare (ignore options)) `(progn ,@body)) -(defun need-to-dump-precompiled-header () - (let* ((config *precompiled-header-cc-config*) - (need-to-dump (or (null config) - (not (eq (svref config 0) *cc*)) - (not (eq (svref config 1) (ecl-include-directory))) - (not (eq (svref config 2) *cc-flags*)) - (not (eq (svref config 3) *cc-optimize*)) - (not (eq (svref config 4) *user-cc-flags*))))) - (when need-to-dump - (setf *precompiled-header-cc-config* - (vector *cc* (ecl-include-directory) *cc-flags* - *cc-optimize* *user-cc-flags*))) - need-to-dump)) - -(defun precompiled-header-flags () - (when *use-precompiled-headers* - (when (need-to-dump-precompiled-header) - (handler-case - (dump-precompiled-header) - (error (err) - (setf *use-precompiled-headers* nil - *precompiled-header-flags* nil - *precompiled-header-cc-config* nil) - (cmpnote "Disabling precompiled header files due to error:~% ~A" err)))) - *precompiled-header-flags*)) - -#+msvc -(defun dump-precompiled-header () - ;; The way precompiled headers work on msvc is not compatible with - ;; what we want to use them for. The msvc compiler creates a - ;; precompiled header file out of ordinary source files by - ;; processing them up to a certain point at which all needed headers - ;; are included. This creates both a precompiled header and a object - ;; file. The object file created by this compilation must be - ;; included in all binaries which are linked together from other - ;; source files compiled using the precompiled header. Thus, we - ;; would need to include the first object file created in a session - ;; in all further object files if we wanted to support that. - (error "Precompiled headers are not supported for msvc.")) - -#-msvc -(defun dump-precompiled-header () - (let* ((input-file (make-pathname - :directory (append (pathname-directory (ecl-include-directory)) - '("ecl")) - :defaults (ecl-include-directory) - :name "ecl-cmp" - :type "h")) - (output-dir (merge-pathnames - (format nil "ecl-include~4,'0x/" (random #xffff)) - (translate-logical-pathname "TMP:"))) - (output-file (compile-file-pathname - (make-pathname :name "ecl-cmp" :defaults output-dir) - :type :precompiled-header))) - (ensure-directories-exist output-dir) - (push output-dir *files-to-be-deleted*) - (safe-run-program - *cc* - `("-x" "c-header" - ,(fix-for-mingw (namestring input-file)) - ,(concatenate 'string "-I" (fix-for-mingw (ecl-include-directory))) - ,@(split-program-options *cc-flags*) - ,@(split-program-options *cc-optimize*) - "-o" - ,(fix-for-mingw (namestring output-file)) - ,@(split-program-options *user-cc-flags*))) - (push output-file *files-to-be-deleted*) - (setf *precompiled-header-flags* - (list (concatenate 'string "-I" (namestring output-dir)) - "-include" - (concatenate 'string (namestring output-dir) "ecl-cmp.h"))))) - (ext:package-lock "CL" t) (setf *features* (delete :ecl-bytecmp *features*)) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 357b4183c..160d3f7d1 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -81,6 +81,7 @@ ;; Other "src:cmp;cmpos-run.lsp" "src:cmp;cmpos-features.lsp" + "src:cmp;cmpbackend-cxx.lsp" "src:cmp;cmpmain.lsp" "src:cmp;proclamations.lsp")) From 244f4e048557b5ea2f4b5f9f9695eef0af99d54c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 13 Mar 2023 17:21:44 +0100 Subject: [PATCH 03/23] cmp: separate cmpbackend from cmpmain (2) Introduce compiler-pass/assemble-cxx. --- src/cmp/cmpbackend-cxx.lsp | 31 ++++++++++-- src/cmp/cmpmain.lsp | 96 +++++++++++--------------------------- 2 files changed, 54 insertions(+), 73 deletions(-) diff --git a/src/cmp/cmpbackend-cxx.lsp b/src/cmp/cmpbackend-cxx.lsp index 74f5f38f7..2cea0f2b1 100644 --- a/src/cmp/cmpbackend-cxx.lsp +++ b/src/cmp/cmpbackend-cxx.lsp @@ -530,8 +530,7 @@ WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdS ;;; Code generation -(defun compiler-pass/generate-cxx (c-pathname h-pathname data-pathname init-name - &key input-designator) +(defun compiler-pass/generate-cxx (c-pathname h-pathname data-pathname init-name source) (setq *compiler-phase* 't2) (with-open-file (*compiler-output1* c-pathname :direction :output @@ -544,7 +543,7 @@ WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdS (declare (ignore second)) (wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute) (wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type))) - (wt-comment-nl "Source: ~A" input-designator) + (wt-comment-nl "Source: ~A" source) (with-open-file (*compiler-output2* h-pathname :direction :output :if-does-not-exist :create :if-exists :supersede) @@ -554,6 +553,32 @@ WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdS (terpri *compiler-output2*))) (data-c-dump data-pathname)) +(defun compiler-pass/assemble-cxx (input-file output-file + &key + (c-file nil) + (h-file nil) + (data-file nil) + (system-p nil) + &allow-other-keys) + (let* ((cpath (compile-file-pathname output-file :output-file c-file :type :c)) + (hpath (compile-file-pathname output-file :output-file h-file :type :h)) + (dpath (compile-file-pathname output-file :output-file data-file :type :data)) + (opath (compile-file-pathname output-file :type :object)) + (to-delete (nconc (unless c-file (list cpath)) + (unless h-file (list hpath)) + (unless data-file (list dpath)) + (unless system-p (list opath)))) + (init-name (compute-init-name output-file :kind (if system-p :object :fasl)))) + (compiler-pass/generate-cxx cpath hpath dpath init-name input-file) + (if system-p + (compiler-cc cpath opath) + (progn + (compiler-cc cpath opath) + (bundle-cc (brief-namestring output-file) + init-name + (list (brief-namestring opath))))) + (mapc 'cmp-delete-file to-delete))) + ;;; The builder. diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index a3641632e..b9673b447 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -20,12 +20,11 @@ (in-package "COMPILER") -(defun compile-file-pathname (name &key (output-file T) (type nil type-supplied-p) - verbose print c-file h-file data-file - system-p load external-format source-truename - source-offset) - (declare (ignore verbose print c-file h-file data-file load - external-format source-truename source-offset)) +(defun compile-file-pathname (name &key + (output-file T) + (type nil type-supplied-p) + (system-p nil) + &allow-other-keys) (let* ((format '()) (extension '())) (unless type-supplied-p @@ -76,14 +75,15 @@ (ext:*source-location* (cons source-truename 0)) (*suppress-compiler-messages* (or *suppress-compiler-messages* (not *compile-verbose*)))) - (declare (notinline compiler-cc)) + (declare (notinline compiler-cc) + (ignorable c-file h-file data-file)) "Compiles the file specified by INPUT-PATHNAME and generates a fasl file specified by OUTPUT-FILE. If the filetype is not specified in INPUT-PATHNAME, then \".lsp\" is used as the default file type for the source file. LOAD specifies whether to load the generated fasl file after compilation. The :O-FILE, :C-FILE, :H-FILE, and :DATA-FILE keyword parameters allow you to control the intermediate files generated by the ECL compiler.If the file was -compiled successfully, returns the pathname of the compiled file" +compiled successfully, returns the pathname of the compiled file." #-dlopen (unless system-p (format t "~%;;;~ @@ -105,47 +105,23 @@ compiled successfully, returns the pathname of the compiled file" (let* ((input-file (truename *compile-file-pathname*)) (*compile-file-truename* input-file) (*compiler-in-use* *compiler-in-use*) - (*load-time-values* nil) ;; Load time values are compiled - (output-file (apply #'compile-file-pathname input-file - :output-file output-file args)) - (true-output-file nil) ;; Will be set at the end - (c-pathname (apply #'compile-file-pathname output-file :output-file c-file - :type :c args)) - (h-pathname (apply #'compile-file-pathname output-file :output-file h-file - :type :h args)) - (data-pathname (apply #'compile-file-pathname output-file - :output-file data-file :type :data args)) - (compiler-conditions nil) - (to-delete (nconc (unless c-file (list c-pathname)) - (unless h-file (list h-pathname)) - (unless data-file (list data-pathname)))) - (init-name (compute-init-name output-file - :kind (if system-p :object :fasl)))) + (*load-time-values* nil) ; Load time values are compiled. + (output-file (apply #'compile-file-pathname input-file :output-file output-file args)) + (true-output-file nil) ; Will be set at the end. + (compiler-conditions nil)) (with-compiler-env (compiler-conditions) (print-compiler-info) (when (probe-file "./cmpinit.lsp") (load "./cmpinit.lsp" :verbose *compile-verbose*)) - (with-open-file (stream *compile-file-pathname* - :external-format external-format) + (with-open-file (stream *compile-file-pathname* :external-format external-format) (unless source-truename (setf (car ext:*source-location*) *compile-file-pathname*)) (compiler-pass1 stream source-offset)) (compiler-pass/propagate-types) - (compiler-pass/generate-cxx c-pathname h-pathname data-pathname init-name - :input-designator (namestring input-pathname)) - (if system-p - (compiler-cc c-pathname output-file) - (let ((o-pathname (compile-file-pathname output-file :type :object))) - (compiler-cc c-pathname o-pathname) - (push o-pathname to-delete) - (bundle-cc (brief-namestring output-file) - init-name - (list (brief-namestring o-pathname))))) + (apply #'compiler-pass/assemble-cxx input-file output-file args) (if (setf true-output-file (probe-file output-file)) - (cmpprogress "~&;;; Finished compiling ~a.~%;;;~%" - (namestring input-pathname)) + (cmpprogress "~&;;; Finished compiling ~a.~%;;;~%" (namestring input-pathname)) (cmperr "The C compiler failed to compile the intermediate file.")) - (mapc #'cmp-delete-file to-delete) (when load (load true-output-file :verbose *compile-verbose*))) ; with-compiler-env (compiler-output-values true-output-file compiler-conditions))) @@ -224,12 +200,7 @@ after compilation." (let* ((*load-time-values* 'values) ;; Only the value is kept (tmp-names (safe-mkstemp (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*)))) - (data-pathname (first tmp-names)) - (c-pathname (compile-file-pathname data-pathname :type :c)) - (h-pathname (compile-file-pathname data-pathname :type :h)) - (o-pathname (compile-file-pathname data-pathname :type :object)) - (so-pathname (compile-file-pathname data-pathname)) - (init-name (compute-init-name so-pathname :kind :fasl)) + (so-pathname (compile-file-pathname (first tmp-names))) (compiler-conditions nil) (*permanent-data* t) ; needed for literal objects in closures (*cmp-env-root* *cmp-env-root*)) @@ -239,18 +210,7 @@ after compilation." (compiler-pass1 form) (compiler-pass/propagate-types) (let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t)) - (compiler-pass/generate-cxx c-pathname h-pathname data-pathname init-name - :input-designator (let* ((*print-circle* t) - (*print-length* 8) - (*print-depth* 4)) - (format nil "~W" def)))) - (compiler-cc c-pathname o-pathname) - (bundle-cc (brief-namestring so-pathname) - init-name - (list (brief-namestring o-pathname))) - (cmp-delete-file c-pathname) - (cmp-delete-file h-pathname) - (cmp-delete-file o-pathname) + (compiler-pass/assemble-cxx nil so-pathname)) (mapc 'cmp-delete-file tmp-names) (cond ((probe-file so-pathname) (load so-pathname :verbose nil) @@ -260,10 +220,6 @@ after compilation." (set 'GAZONK nil) (cmperr "The C compiler failed to compile the intermediate code for ~s." name))) ) ; with-compiler-env - (cmp-delete-file c-pathname) - (cmp-delete-file h-pathname) - (cmp-delete-file so-pathname) - (mapc 'cmp-delete-file tmp-names) (let ((output (or name (and (boundp 'GAZONK) (symbol-value 'GAZONK)) #'(lambda (&rest x) (declare (ignore x)) @@ -293,24 +249,24 @@ disassembled. If THING is a lambda expression, it is disassembled as a function definition. Otherwise, THING itself is disassembled as a top-level form. H-FILE and DATA-FILE specify intermediate files to build a fasl file from the C language code. NIL means \"do not create the file\"." - (when (si::valid-function-name-p thing) + (when (si:valid-function-name-p thing) (setq thing (fdefinition thing))) (when (and (functionp thing) (function-lambda-expression thing)) (multiple-value-setq (thing lexenv) (function-lambda-expression thing)) (when (eq lexenv t) - (warn "DISASSEMBLE can not disassemble C closures") + (warn "DISASSEMBLE can not disassemble C closures.") (return-from disassemble nil))) (cond ((null thing)) ((functionp thing) - (unless (si::bc-disassemble thing) + (unless (si:bc-disassemble thing) (warn "Cannot disassemble the binary function ~S because I do not have its source code." thing) (return-from disassemble nil))) ((atom thing) (error 'simple-type-error :datum thing :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) - :format-control "DISASSEMBLE cannot accept ~A" + :format-control "DISASSEMBLE cannot accept ~A." :format-arguments (list thing))) ((eq (car thing) 'LAMBDA) (setq disassembled-form `(defun gazonk ,@(cdr thing)))) @@ -320,7 +276,7 @@ from the C language code. NIL means \"do not create the file\"." (error 'simple-type-error :datum thing :expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P)) - :format-control "DISASSEMBLE cannot accept ~A" + :format-control "DISASSEMBLE cannot accept ~A." :format-arguments (list thing)))) (let* ((null-stream (make-broadcast-stream)) @@ -358,8 +314,8 @@ from the C language code. NIL means \"do not create the file\"." (if (streamp object) (do* ((eof '(NIL)) (*compile-file-position* 0 (file-position object)) - (form (si::read-object-or-ignore object eof) - (si::read-object-or-ignore object eof))) + (form (si:read-object-or-ignore object eof) + (si:read-object-or-ignore object eof))) ((eq form eof)) (when form (setf (cdr ext:*source-location*) @@ -395,12 +351,12 @@ from the C language code. NIL means \"do not create the file\"." (compile-file #'compile-file) (compile-file-pathname #'compile-file-pathname)) (defun ext:install-c-compiler () - (ext::package-lock (find-package :cl) nil) + (ext:package-lock (find-package :cl) nil) (setf *features* (delete :ecl-bytecmp *features*)) (setf (fdefinition 'disassemble) disassemble (fdefinition 'compile) compile (fdefinition 'compile-file) compile-file (fdefinition 'compile-file-pathname) compile-file-pathname) - (ext::package-lock (find-package :cl) t))) + (ext:package-lock (find-package :cl) t))) (provide 'cmp) From b8aa49a05352c481de9ef0751d9e3577a93913fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 19 May 2023 12:50:20 +0200 Subject: [PATCH 04/23] cmp: add a helper function GET-OBJECT for the data segment This function may be used to get the object from one of the segments or fail -- most notably it does not add the object to the data segment. --- src/cmp/cmppass1-data.lsp | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/src/cmp/cmppass1-data.lsp b/src/cmp/cmppass1-data.lsp index 01bddb9ef..e990a1680 100644 --- a/src/cmp/cmppass1-data.lsp +++ b/src/cmp/cmppass1-data.lsp @@ -79,6 +79,19 @@ (defun data-empty-loc () (add-object 0 :duplicate t :permanent t)) +;;; Note that we can't use GET-OBJECT to probe for referenced objects because +;;; ADD-OBJECT (when failed and :DUPLICATE is T) may return an object that is +;;; not in any storage when the object is a known ECL symbol. +(defun get-object (object &key permanent (errorp t)) + (let* ((test (if si:*compiler-constants* 'eq 'equal-with-circularity)) + (item (if permanent + (find object *permanent-objects* :test test :key #'vv-value) + (or (find object *permanent-objects* :test test :key #'vv-value) + (find object *temporary-objects* :test test :key #'vv-value))))) + (when (and (null item) errorp) + (cmperr "Unable to find object ~s." object)) + item)) + (defun add-object (object &key (duplicate nil) (used-p nil) @@ -97,11 +110,7 @@ ;; temporary storage from being created (we can't move objects from the ;; temporary into the permanent storage once they have been created). (setf load-form-p t permanent t)) - (let* ((test (if si:*compiler-constants* 'eq 'equal-with-circularity)) - (item (if permanent - (find object *permanent-objects* :test test :key #'vv-value) - (or (find object *permanent-objects* :test test :key #'vv-value) - (find object *temporary-objects* :test test :key #'vv-value)))) + (let* ((item (get-object object :permanent permanent :errorp nil)) (array (if permanent *permanent-objects* *temporary-objects*)) From aae21dc9ae0a391ac99d253eb1b20ab28bce5b1b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 19 May 2023 14:36:46 +0200 Subject: [PATCH 05/23] cmp: return-from: fix a problem where block-name was never used The intention of c2return-from was to print the block name in the error message when the block was referenced outside of its dynamic extent, but CCB was never passed as the return type. The code is simplified to always use the same code path for non-local returns. --- src/cmp/cmppass1-cont.lsp | 11 +++++------ src/cmp/cmppass2-cont.lsp | 21 ++++++++++----------- src/cmp/cmptables.lsp | 4 ++-- 3 files changed, 17 insertions(+), 19 deletions(-) diff --git a/src/cmp/cmppass1-cont.lsp b/src/cmp/cmppass1-cont.lsp index 31f12532e..ad4592d4a 100644 --- a/src/cmp/cmppass1-cont.lsp +++ b/src/cmp/cmppass1-cont.lsp @@ -43,7 +43,7 @@ body)))) (defun c1return-from (args) - (check-args-number 'RETURN-FROM args 1 2) + (check-args-number 'CL:RETURN-FROM args 1 2) (let ((name (first args))) (unless (symbolp name) (cmperr "The block name ~s is not a symbol." name)) @@ -53,13 +53,12 @@ (cmperr "The block ~s is undefined." name)) (let* ((val (c1expr (second args))) (var (blk-var blk)) - (type T)) - (cond (cfb (setf type 'CLB - (var-ref-clb var) T)) - (unw (setf type 'UNWIND-PROTECT))) + (nonlocal (or cfb unw))) + (when cfb + (setf (var-ref-ccb var) T)) (incf (blk-ref blk)) (setf (blk-type blk) (values-type-or (blk-type blk) (c1form-type val))) - (let ((output (make-c1form* 'RETURN-FROM :type 'T :args blk type val))) + (let ((output (make-c1form* 'CL:RETURN-FROM :type 'T :args blk nonlocal val))) (when (or cfb unw) (add-to-read-nodes var output)) output))))) diff --git a/src/cmp/cmppass2-cont.lsp b/src/cmp/cmppass2-cont.lsp index fc666ae9d..72c285ec5 100644 --- a/src/cmp/cmppass2-cont.lsp +++ b/src/cmp/cmppass2-cont.lsp @@ -45,18 +45,17 @@ (wt-nl-close-brace)) (c2expr body))) -(defun c2return-from (c1form blk type val) +(defun c2return-from (c1form blk nonlocal val) (declare (ignore c1form)) - (case type - (CCB - (let ((*destination* 'VALUES)) (c2expr* val)) - (wt-nl "cl_return_from(" (blk-var blk) "," (add-symbol (blk-name blk)) ");")) - ((CLB UNWIND-PROTECT) - (let ((*destination* 'VALUES)) (c2expr* val)) - (wt-nl "cl_return_from(" (blk-var blk) ",ECL_NIL);")) - (T (let ((*destination* (blk-destination blk)) - (*exit* (blk-exit blk))) - (c2expr val))))) + (if nonlocal + (progn + (let ((*destination* 'VALUES)) + (c2expr* val)) + (let ((name (add-symbol (blk-name blk)))) + (wt-nl "cl_return_from(" (blk-var blk) "," name ");"))) + (let ((*destination* (blk-destination blk)) + (*exit* (blk-exit blk))) + (c2expr val)))) (defun c2tagbody (c1form tag-loc body) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index bcbd32e0d..ea911f448 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -25,14 +25,14 @@ (cl:PROGN body :pure) (cl:PROGV symbols values form :side-effects) (cl:TAGBODY tag-var tag-body :pure) - (cl:RETURN-FROM blk-var return-type value :side-effects) + (cl:RETURN-FROM blk-var nonlocal value :side-effects) (cl:FUNCALL fun-value (arg-value*) :side-effects) (CALL-LOCAL obj-fun (arg-value*) :side-effects) (CALL-GLOBAL fun-name (arg-value*)) (cl:CATCH catch-value body :side-effects) (cl:UNWIND-PROTECT protected-c1form body :side-effects) (cl:THROW catch-value output-value :side-effects) - (cl:GO tag-var return-type :side-effects) + (cl:GO tag-var nonlocal :side-effects) (ffi:C-INLINE (arg-c1form*) (arg-type-symbol*) output-rep-type From e23c82b90d345ea1e47fa970e033e16975f0ce41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 19 May 2023 14:39:51 +0200 Subject: [PATCH 06/23] cmp: cosmetic: don't use nconc in ctop-write We simply iterate over both lists without nconcing them. --- src/cmp/cmppass2-top.lsp | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/cmp/cmppass2-top.lsp b/src/cmp/cmppass2-top.lsp index 025da4177..a22a9f294 100644 --- a/src/cmp/cmppass2-top.lsp +++ b/src/cmp/cmppass2-top.lsp @@ -90,8 +90,11 @@ (wt-nl "ECL_DEFINE_SETF_FUNCTIONS") - (loop for form in (nconc *make-forms* *top-level-forms*) - do (emit-toplevel-form form c-output-file)) + (dolist (form *make-forms*) + (emit-toplevel-form form c-output-file)) + (dolist (form *top-level-forms*) + (emit-toplevel-form form c-output-file)) + (wt-nl-close-many-braces 0) (setq top-output-string (get-output-stream-string *compiler-output1*))) From 0ccb877b8a13f2227878231f5a588b10b2d4ce1f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 22 May 2023 15:30:11 +0200 Subject: [PATCH 07/23] cmp: remove a kludge from the function object-type The function OBJECT-TYPE special-cased NIL and returned SYMBOL as its type. git-blame shown that this kludge was part of the initial release so I could not find any reason why it does not return NULL instead. Removing the kludge did not yield any noticeable regressions. My guess is that the type system was deficient at that time and type-of did not work on the type NIL. Returning SYMBOL instead of NULL lead to a sloppy type propagation of locations containing NIL. --- src/cmp/cmptype-arith.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cmp/cmptype-arith.lsp b/src/cmp/cmptype-arith.lsp index 22c5e0cfb..9e337f308 100644 --- a/src/cmp/cmptype-arith.lsp +++ b/src/cmp/cmptype-arith.lsp @@ -50,7 +50,7 @@ ;;; Depends on the implementation of TYPE-OF. ;;; (only used for saving constants?) (defun object-type (thing) - (let ((type (if thing (type-of thing) 'SYMBOL))) + (let ((type (type-of thing))) (case type ((FIXNUM SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT SYMBOL NULL) type) ((BASE-CHAR STANDARD-CHAR CHARACTER EXTENDED-CHAR) 'CHARACTER) From 18030bf1b485deeab2944af2e8d6f445394e645a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 22 May 2023 18:11:15 +0200 Subject: [PATCH 08/23] cmp: rearrange the order in +all-c1-forms+ to hint top-levelness --- src/cmp/cmptables.lsp | 66 +++++++++++++++++++++++-------------------- 1 file changed, 36 insertions(+), 30 deletions(-) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index ea911f448..170862b12 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -17,42 +17,54 @@ (eval-when (:compile-toplevel :execute) (defconstant +all-c1-forms+ - '((LOCATION loc :pure :single-valued) + '(;; top-level forms + (ORDINARY c1form :pure) + (MAKE-FORM vv-loc value-c1form :side-effects) + (INIT-FORM vv-loc value-c1form :side-effects) + ;; both-level forms (different semantics) + (EXT:COMPILER-LET symbols values body) + (SI:FSET function-object vv-loc macro-p pprint-p lambda-form :side-effects) + (CL:LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued) + (CL:PROGN body :pure) + ;; sub-level forms + (LOCATION loc :pure :single-valued) (VAR var :single-valued) - (cl:SETQ var value-c1form :side-effects) - (cl:PSETQ var-list value-c1form-list :side-effects) - (cl:BLOCK blk-var progn-c1form :pure) - (cl:PROGN body :pure) - (cl:PROGV symbols values form :side-effects) - (cl:TAGBODY tag-var tag-body :pure) - (cl:RETURN-FROM blk-var nonlocal value :side-effects) - (cl:FUNCALL fun-value (arg-value*) :side-effects) + (CL:SETQ var value-c1form :side-effects) + (CL:PSETQ var-list value-c1form-list :side-effects) + (CL:BLOCK blk-var progn-c1form :pure) + + (CL:PROGV symbols values form :side-effects) + (CL:TAGBODY tag-var tag-body :pure) + (CL:RETURN-FROM blk-var nonlocal value :side-effects) + (CL:FUNCALL fun-value (arg-value*) :side-effects) (CALL-LOCAL obj-fun (arg-value*) :side-effects) (CALL-GLOBAL fun-name (arg-value*)) - (cl:CATCH catch-value body :side-effects) - (cl:UNWIND-PROTECT protected-c1form body :side-effects) - (cl:THROW catch-value output-value :side-effects) - (cl:GO tag-var nonlocal :side-effects) - (ffi:C-INLINE (arg-c1form*) + (CL:CATCH catch-value body :side-effects) + (CL:UNWIND-PROTECT protected-c1form body :side-effects) + (CL:THROW catch-value output-value :side-effects) + (CL:GO tag-var nonlocal :side-effects) + + (FFI:C-INLINE (arg-c1form*) (arg-type-symbol*) output-rep-type c-expression-string side-effects-p one-liner-p) - (ffi:C-PROGN variables forms) + (FFI:C-PROGN variables forms) + (LOCALS local-fun-list body labels-p :pure) - (cl:IF fmla-c1form true-c1form false-c1form :pure) + (CL:IF fmla-c1form true-c1form false-c1form :pure) (FMLA-NOT fmla-c1form :pure) (FMLA-AND * :pure) (FMLA-OR * :pure) - (cl:LAMBDA lambda-list doc body-c1form) - (cl:LET* vars-list var-init-c1form-list decl-body-c1form :pure) - (cl:VALUES values-c1form-list :pure) - (cl:MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects) - (cl:MULTIPLE-VALUE-BIND vars-list init-c1form body :pure) - (ext:COMPILER-LET symbols values body) - (cl:FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued) - (cl:RPLACD (dest-c1form value-c1form) :side-effects) + (CL:LAMBDA lambda-list doc body-c1form) + (CL:LET* vars-list var-init-c1form-list decl-body-c1form :pure) + (CL:VALUES values-c1form-list :pure) + (CL:MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects) + (CL:MULTIPLE-VALUE-BIND vars-list init-c1form body :pure) + + (CL:FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued) + (CL:RPLACD (dest-c1form value-c1form) :side-effects) (SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure) (SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form :side-effects) @@ -60,12 +72,6 @@ (WITH-STACK body :side-effects) (STACK-PUSH-VALUES value-c1form push-statement-c1form :side-effects) - (ORDINARY c1form :pure) - (cl:LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued) - (SI:FSET function-object vv-loc macro-p pprint-p lambda-form - :side-effects) - (MAKE-FORM vv-loc value-c1form :side-effects) - (INIT-FORM vv-loc value-c1form :side-effects) (ext:COMPILER-TYPECASE var expressions) (ext:CHECKED-VALUE type value-c1form let-form)))) From 1e9786fd0aafa77a16f3a1949b108cfa631f70b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 23 May 2023 12:39:50 +0200 Subject: [PATCH 09/23] cmp: simplify the type propagation pass Previously we've carries the "assumption" list through all calls, but said assumption list was never used to make any decisions (and we had numerous assertions that it must be null at various places). The assumption list made the code less readable because it intorduced numerous loops and multiple-value-bind calls just to maintain it. Removal introduces no known regressions. --- src/cmp/cmpmain.lsp | 4 +- src/cmp/cmpprop.lsp | 341 ++++++++++++++++---------------------------- 2 files changed, 124 insertions(+), 221 deletions(-) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index b9673b447..3e50dfe2c 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -330,9 +330,9 @@ from the C language code. NIL means \"do not create the file\"." (when *do-type-propagation* (setq *compiler-phase* 'p1propagate) (dolist (form *top-level-forms*) - (p1propagate form nil)) + (p1propagate form)) (dolist (fun *local-funs*) - (p1propagate (fun-lambda fun) nil)))) + (p1propagate (fun-lambda fun))))) (defun print-compiler-info () (cmpprogress "~&;;; OPTIMIZE levels: Safety=~d, Space=~d, Speed=~d, Debug=~d~%;;;~%" diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 8cbce8b8b..eaa5a15c0 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -21,17 +21,17 @@ (when *type-propagation-messages* `(format *standard-output* ,string ,@args)))) -(defun p1ordinary (c1form assumptions form) +(defun p1ordinary (c1form form) (declare (ignore c1form)) - (p1propagate form assumptions)) + (p1propagate form)) -(defun p1fset (c1form assumptions fun fname macro pprint c1forms) +(defun p1fset (c1form fun fname macro pprint c1forms) (declare (ignore c1form fun fname macro pprint c1forms)) - (values 'function assumptions)) + 'function) -(defun p1propagate (form assumptions) +(defun p1propagate (form) (unless form - (return-from p1propagate (values 'null assumptions))) + (return-from p1propagate 'null)) (when (c1form-p form) (let ((*cmp-env* (c1form-env form)) (*compile-file-pathname* (c1form-file form)) @@ -41,211 +41,145 @@ (name (c1form-name form))) (ext:when-let ((propagator (gethash name *p1-dispatch-table*))) (prop-message "~&;;; Entering type propagation for ~A" name) - (multiple-value-bind (new-type assumptions) - (apply propagator form assumptions (c1form-args form)) - (when assumptions - (baboon :format-control "Non-empty assumptions found in P1PROPAGATE")) + (let ((new-type (apply propagator form (c1form-args form)))) (prop-message "~&;;; Propagating ~A gives type ~A" name new-type) (return-from p1propagate - (values (setf (c1form-type form) - (values-type-and (c1form-type form) - new-type)) - assumptions)))))) + (setf (c1form-type form) + (values-type-and (c1form-type form) new-type))))))) (cmpnote "Refusing to propagate ~A" form) - (values (c1form-type form) assumptions)) + (c1form-type form)) -(defun p1trivial (form assumptions &rest rest) +(defun p1trivial (form &rest rest) (declare (ignore rest)) - (values (c1form-type form) assumptions)) + (c1form-type form)) -(defun p1var (form assumptions var) - (let* ((record (and (assoc var assumptions) - (baboon :format-control "Non empty assumptions found in P1VAR"))) - ;; Use the type of C1FORM because it might have been +(defun p1var (form var) + (let* (;; Use the type of C1FORM because it might have been ;; coerced by a THE form. - (var-type (if record (cdr record) (var-type var))) + (var-type (var-type var)) (type (type-and var-type (c1form-primary-type form)))) (prop-message "~&;;; Querying variable ~A gives ~A" (var-name var) type) - (values type assumptions))) + type)) -(defun p1values (form assumptions values) +(defun p1values (form values) (declare (ignore form)) (loop for v in values - collect (multiple-value-bind (type new-assumptions) - (p1propagate v assumptions) - (setf assumptions new-assumptions) - (values-type-primary-type type)) + collect (values-type-primary-type (p1propagate v)) into all-values - finally (return (values `(values ,@all-values) assumptions)))) + finally (return `(values ,@all-values)))) -(defun p1propagate-list (list assumptions) +(defun p1propagate-list (list) (loop with final-type = t - for f in list - do (multiple-value-setq (final-type assumptions) (p1propagate f assumptions)) - finally (return (values final-type assumptions)))) + for f in list + do (setf final-type (p1propagate f)) + finally (return final-type))) -(defun p1merge-branches (root chains) - "ROOT is a list of assumptions, while CHAINS is list of extended versions of -ROOT. This function takes all those extensions and makes a final list in which -type assumptions have been merged, giving the variables the OR type of each -of the occurrences in those lists." - (unless (and (null root) - (every #'null chains)) - (baboon :format-control "P1MERGE-BRANCHES got a non-empty list of assumptions"))) - -(defun revise-var-type (variable assumptions where-to-stop) - (declare (ignore variable)) - (unless (and (null assumptions) (null where-to-stop)) - (baboon :format-control "REVISE-VAR-TYPE got a non-empty list of assumptions"))) - -(defun p1block (c1form assumptions blk body) +(defun p1block (c1form blk body) (declare (ignore c1form)) (setf (blk-type blk) nil) - (multiple-value-bind (normal-type assumptions) - (p1propagate body assumptions) - (let ((blk-type (blk-type blk))) - (values (if blk-type (values-type-or blk-type normal-type) normal-type) - assumptions)))) + (let ((normal-type (p1propagate body)) + (blk-type (blk-type blk))) + (if blk-type + (values-type-or blk-type normal-type) + normal-type))) -(defun p1return-from (c1form assumptions blk return-type value) +(defun p1return-from (c1form blk return-type value) (declare (ignore c1form return-type)) - (let* ((values-type (p1propagate value assumptions)) + (let* ((values-type (p1propagate value)) (blk-type (blk-type blk))) (setf (blk-type blk) (if blk-type (values-type-or blk-type values-type) values-type)) - (values values-type assumptions))) + values-type)) -(defun p1call-global (c1form assumptions fname args) +(defun p1call-global (c1form fname args) (declare (ignore c1form)) (loop for v in args - do (multiple-value-bind (arg-type local-ass) - (p1propagate v assumptions) - (declare (ignore arg-type)) - (setf assumptions local-ass)) + do (p1propagate v) finally (let ((type (propagate-types fname args))) (prop-message "~&;;; Computing output of function ~A with args~&;;; ~{ ~A~}~&;;; gives ~A, while before ~A" fname (mapcar #'c1form-primary-type args) type (c1form-type c1form)) - (return (values type assumptions))))) + (return type)))) -(defun p1call-local (c1form assumptions fun args) +(defun p1call-local (c1form fun args) (declare (ignore c1form)) (loop for v in args - do (multiple-value-bind (arg-type local-ass) - (p1propagate v assumptions) - (declare (ignore arg-type)) - (setf assumptions local-ass)) - finally (return (values (fun-return-type fun) - assumptions)))) + do (p1propagate v) + finally (return (fun-return-type fun)))) -(defun p1catch (c1form assumptions tag body) +(defun p1catch (c1form tag body) (declare (ignore c1form)) - (multiple-value-bind (tag-type assumptions) - (p1propagate tag assumptions) - (declare (ignore tag-type)) - (p1propagate body assumptions)) - (values t assumptions)) + (p1propagate tag) + (p1propagate body) + t) -(defun p1throw (c1form assumptions catch-value output-value) +(defun p1throw (c1form catch-value output-value) (declare (ignore c1form)) - (multiple-value-bind (type new-assumptions) - (p1propagate catch-value assumptions) - (declare (ignore type)) - (p1propagate output-value new-assumptions)) - (values t assumptions)) + (p1propagate catch-value) + (p1propagate output-value) + t) -(defun p1if (c1form assumptions fmla true-branch false-branch) +(defun p1if (c1form fmla true-branch false-branch) (declare (ignore c1form)) - (multiple-value-bind (fmla-type base-assumptions) - (p1propagate fmla assumptions) - (declare (ignore fmla-type)) - (multiple-value-bind (t1 a1) - (p1propagate true-branch base-assumptions) - (multiple-value-bind (t2 a2) - (p1propagate false-branch base-assumptions) - (values (values-type-or t1 t2) - (p1merge-branches base-assumptions (list a1 a2))))))) + (p1propagate fmla) + (let ((t1 (p1propagate true-branch)) + (t2 (p1propagate false-branch))) + (values-type-or t1 t2))) -(defun p1fmla-not (c1form assumptions form) +(defun p1fmla-not (c1form form) (declare (ignore c1form)) - (multiple-value-bind (type assumptions) - (p1propagate form assumptions) - (declare (ignore type)) - (values '(member t nil) assumptions))) + (p1propagate form) + '(member t nil)) -(defun p1fmla-and (c1form orig-assumptions butlast last) +(defun p1fmla-and (c1form butlast last) (declare (ignore c1form)) (loop with type = t - with assumptions = orig-assumptions for form in (append butlast (list last)) - collect (progn - (multiple-value-setq (type assumptions) - (p1propagate form assumptions)) - assumptions) - into assumptions-list - finally (return (values (type-or 'null (values-type-primary-type type)) - (p1merge-branches orig-assumptions - assumptions-list))))) + do (setf type (p1propagate form)) + finally (return (type-or 'null (values-type-primary-type type))))) -(defun p1fmla-or (c1form orig-assumptions butlast last) +(defun p1fmla-or (c1form butlast last) (declare (ignore c1form)) (loop with type with output-type = t - with assumptions = orig-assumptions for form in (append butlast (list last)) - collect (progn - (multiple-value-setq (type assumptions) - (p1propagate form assumptions)) - (setf output-type (type-or (values-type-primary-type type) - output-type)) - assumptions) - into assumptions-list - finally (return (values output-type - (p1merge-branches orig-assumptions - assumptions-list))))) + do (setf type (p1propagate form) + output-type (type-or (values-type-primary-type type) + output-type)) + finally (return output-type))) -(defun p1lambda (c1form assumptions lambda-list doc body &rest not-used) +(defun p1lambda (c1form lambda-list doc body &rest not-used) (declare (ignore c1form lambda-list doc not-used)) (prop-message "~&;;;~&;;; Propagating function~&;;;") - (let ((type (p1propagate body assumptions))) - (values type assumptions))) + (p1propagate body)) -(defun p1propagate-function (fun assumptions) - (multiple-value-bind (output-type assumptions) - (p1propagate (fun-lambda fun) assumptions) - (values (setf (fun-return-type fun) output-type) - assumptions))) +(defun p1propagate-function (fun) + (setf (fun-return-type fun) (p1propagate (fun-lambda fun)))) -(defun p1let* (c1form base-assumptions vars forms body) +(defun p1let* (c1form vars forms body) (declare (ignore c1form)) - (let ((assumptions base-assumptions)) - (loop with type - for v in vars - for f in forms - unless (or (global-var-p v) (var-set-nodes v)) - do (progn - (multiple-value-setq (type assumptions) (p1propagate f assumptions)) - (setf (var-type v) (type-and (values-type-primary-type type) - (var-type v))) - (prop-message "~&;;; Variable ~A assigned type ~A" - (var-name v) (var-type v)))) - (multiple-value-bind (type assumptions) - (p1propagate body assumptions) - (loop for v in vars - do (revise-var-type v assumptions base-assumptions)) - (values type assumptions)))) + (loop with type + for v in vars + for f in forms + unless (or (global-var-p v) (var-set-nodes v)) + do (progn + (setf type (p1propagate f)) + (setf (var-type v) + (type-and (values-type-primary-type type) (var-type v))) + (prop-message "~&;;; Variable ~A assigned type ~A" + (var-name v) (var-type v)))) + (p1propagate body)) -(defun p1locals (c1form assumptions funs body labels) +(defun p1locals (c1form funs body labels) (declare (ignore c1form labels)) (loop for f in funs - do (p1propagate-function f assumptions)) - (p1propagate body assumptions)) + do (p1propagate-function f)) + (p1propagate body)) -(defun p1multiple-value-bind (c1form assumptions vars-list init-c1form body) +(defun p1multiple-value-bind (c1form vars-list init-c1form body) (declare (ignore c1form)) - (multiple-value-bind (init-form-type assumptions) - (p1propagate init-c1form assumptions) + (let ((init-form-type (p1propagate init-c1form))) (loop for v in vars-list for type in (values-type-to-n-types init-form-type (length vars-list)) unless (or (global-var-p v) @@ -253,116 +187,85 @@ of the occurrences in those lists." do (setf (var-type v) (type-and (var-type v) type)) and do (prop-message "~&;;; Variable ~A assigned type ~A" (var-name v) (var-type v))) - (p1propagate body assumptions))) + (p1propagate body))) -(defun p1multiple-value-setq (c1form assumptions vars-list value-c1form) +(defun p1multiple-value-setq (c1form vars-list value-c1form) (declare (ignore c1form vars-list)) - (multiple-value-bind (init-form-type assumptions) - (p1propagate value-c1form assumptions) - (values init-form-type assumptions))) + (p1propagate value-c1form)) -(defun p1progn (c1form assumptions forms) +(defun p1progn (c1form forms) (declare (ignore c1form)) - (p1propagate-list forms assumptions)) + (p1propagate-list forms)) -(defun p1compiler-typecase (c1form assumptions variable expressions) +(defun p1compiler-typecase (c1form variable expressions) (declare (ignore c1form)) (let ((var-type (var-type variable))) (loop with output-type = t for (a-type c1form) in expressions - for c1form-type = (p1propagate c1form assumptions) + for c1form-type = (p1propagate c1form) when (or (member a-type '(t otherwise)) (subtypep var-type a-type)) do (setf output-type c1form-type) - finally (return (values output-type assumptions))))) + finally (return output-type)))) -(defun p1checked-value (c1form assumptions type value let-form) +(defun p1checked-value (c1form type value let-form) (declare (ignore c1form let-form)) - (let ((value-type (p1propagate value assumptions)) - ;;(alt-type (p1propagate let-form assumptions)) + (let ((value-type (p1propagate value)) + ;;(alt-type (p1propagate let-form)) ) (if (subtypep value-type type) value-type type))) -(defun p1progv (c1form assumptions variables values body) +(defun p1progv (c1form variables values body) (declare (ignore c1form)) - (let (type) - (multiple-value-setq (type assumptions) - (p1propagate variables assumptions)) - (multiple-value-setq (type assumptions) - (p1propagate values assumptions)) - (p1propagate body assumptions))) + (p1propagate variables) + (p1propagate values) + (p1propagate body)) -(defun p1setq (c1form assumptions var value-c1form) +(defun p1setq (c1form var value-c1form) (declare (ignore c1form)) - (multiple-value-bind (value-type assumptions) - (p1propagate value-c1form assumptions) - (values (type-and (var-type var) (values-type-primary-type value-type)) - assumptions))) + (let ((value-type (p1propagate value-c1form))) + (type-and (var-type var) (values-type-primary-type value-type)))) -(defun p1psetq (c1form assumptions vars c1forms) +(defun p1psetq (c1form vars c1forms) (declare (ignore c1form vars)) (loop for form in c1forms - do (p1propagate form assumptions)) - (values 'null assumptions)) + do (p1propagate form)) + 'null) -(defun p1with-stack (c1form assumptions body) +(defun p1with-stack (c1form body) (declare (ignore c1form)) - (p1propagate body assumptions)) + (p1propagate body)) -(defun p1stack-push-values (c1form assumptions form inline) +(defun p1stack-push-values (c1form form inline) (declare (ignore c1form inline)) - (multiple-value-bind (form-type assumptions) - (p1propagate form assumptions) - (declare (ignore form-type)) - (values nil assumptions))) + (p1propagate form) + nil) (defvar *tagbody-depth* -1 "If n > 0, limit the number of passes to converge tagbody forms. If -1, let the compiler do as many passes as it wishes. Complexity grows as 2^*tagbody-limit* in the worst cases.") -(defun p1go (c1form assumptions tag-var return-type) +(defun p1go (c1form tag-var return-type) (declare (ignore c1form tag-var return-type)) - (values t assumptions)) + t) -(defun filter-only-declarations (assumptions) - (when assumptions - (baboon :format-control "FILTER-ONLY-DECLARATIONS gets a non-empty assumption list")) - nil) - -(defun p1tagbody (c1form orig-assumptions tag-loc body) - (prop-message "~&;;; P1TAGBODY-SIMPLE pass") - (let* ((assumptions (filter-only-declarations orig-assumptions)) - (ass-list (p1tagbody-one-pass c1form assumptions tag-loc body))) - (values 'null (append (p1merge-branches nil ass-list) orig-assumptions)))) - -(defun p1tagbody-one-pass (c1form assumptions tag-loc body) +(defun p1tagbody (c1form tag-loc body) (declare (ignore c1form tag-loc)) - (loop with local-ass = assumptions - with ass-list = '() - with aux - for f in body - do (if (tag-p f) - (let ((diff (ldiff local-ass assumptions))) - (when diff - (push diff ass-list)) - (prop-message "~&;;; Label ~A found" (tag-name f)) - (setf local-ass assumptions)) - (multiple-value-setq (aux local-ass) (p1propagate f local-ass))) - finally (return - (let ((diff (ldiff local-ass assumptions))) - (if diff - (cons diff ass-list) - ass-list))))) + (prop-message "~&;;; P1TAGBODY-SIMPLE pass") + (loop for f in body do + (if (tag-p f) + (prop-message "~&;;; Label ~A found" (tag-name f)) + (p1propagate f))) + 'null) -(defun p1unwind-protect (c1form assumptions form body) +(defun p1unwind-protect (c1form form body) (declare (ignore c1form)) - (multiple-value-bind (output-type assumptions) - (p1propagate form assumptions) - (p1propagate body assumptions) - (values output-type assumptions))) + (let ((output-type (p1propagate form))) + (p1propagate body) + output-type)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From 0321023572ef513f1589d8463b75697e790c7166 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 23 May 2023 14:42:38 +0200 Subject: [PATCH 10/23] cmp: propagate types in functions too The propagator for FSET did not descend to the function object while the propagator for LOCALS did (that was inconsistent). Also cmpmain called P1PROPAGATE on *LOCAL-FUNS* before the second pass so that was no-op. --- src/cmp/cmpmain.lsp | 4 +--- src/cmp/cmpprop.lsp | 3 ++- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index 3e50dfe2c..e8af20c06 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -330,9 +330,7 @@ from the C language code. NIL means \"do not create the file\"." (when *do-type-propagation* (setq *compiler-phase* 'p1propagate) (dolist (form *top-level-forms*) - (p1propagate form)) - (dolist (fun *local-funs*) - (p1propagate (fun-lambda fun))))) + (p1propagate form)))) (defun print-compiler-info () (cmpprogress "~&;;; OPTIMIZE levels: Safety=~d, Space=~d, Speed=~d, Debug=~d~%;;;~%" diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index eaa5a15c0..7006b61bc 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -26,7 +26,8 @@ (p1propagate form)) (defun p1fset (c1form fun fname macro pprint c1forms) - (declare (ignore c1form fun fname macro pprint c1forms)) + (declare (ignore c1form fname macro pprint c1forms)) + (p1propagate-function fun) 'function) (defun p1propagate (form) From 3565c89ca913c1a03c4f690f0c9c3f23a56468e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Jun 2023 14:47:57 +0200 Subject: [PATCH 11/23] cmp: cosmetic: write `(function ,foo) instead of `#',foo --- src/cmp/cmppass1-call.lsp | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp index c282be923..55af6949a 100644 --- a/src/cmp/cmppass1-call.lsp +++ b/src/cmp/cmppass1-call.lsp @@ -125,10 +125,9 @@ (if (and macros-allowed (setf fd (cmp-macro-function fname))) (cmp-expand-macro fd (list* fname args)) - ;; When it is a function and takes many arguments, we will - ;; need a special C form to call it. It takes extra code for - ;; handling the stack - (unoptimized-long-call `#',fname args))) + ;; When it is a function and takes too many arguments, we need a + ;; special C form to call it with the stack (see with-stack). + (unoptimized-long-call `(function ,fname) args))) ((setq fd (local-function-ref fname)) (c1call-local fname fd args)) ((and macros-allowed ; macrolet From d62cf434c6df66509b87c6880ace5919a5b68667 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Jun 2023 13:00:15 +0200 Subject: [PATCH 12/23] cmp: enable externalizing NAN --- src/cmp/cmpc-wt.lsp | 4 ++-- src/cmp/cmppass1-eval.lsp | 6 ------ 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/src/cmp/cmpc-wt.lsp b/src/cmp/cmpc-wt.lsp index 603ee6ce9..93dc130f2 100644 --- a/src/cmp/cmpc-wt.lsp +++ b/src/cmp/cmpc-wt.lsp @@ -23,8 +23,8 @@ (princ form *compiler-output1*)) (VAR (wt-var form)) (t (wt-loc form)))) - ;; ((ext:float-nan-p form) - ;; (format *compiler-output1* "NAN")) + ((ext:float-nan-p form) + (format *compiler-output1* "NAN")) ((ext:float-infinity-p form) (if (minusp form) (format *compiler-output1* "-INFINITY") diff --git a/src/cmp/cmppass1-eval.lsp b/src/cmp/cmppass1-eval.lsp index 3a83e76cc..3cc72ed2d 100644 --- a/src/cmp/cmppass1-eval.lsp +++ b/src/cmp/cmppass1-eval.lsp @@ -135,18 +135,12 @@ (make-c1form* 'LOCATION :type 'CHARACTER :args (list 'CHARACTER-VALUE (char-code val)))) ((typep val 'DOUBLE-FLOAT) - (when (and (ext:float-nan-p val) (not only-small-values)) - (cmperr "Cannot externalize value ~A" val)) (make-c1form* 'LOCATION :type 'DOUBLE-FLOAT :args (list 'DOUBLE-FLOAT-VALUE val (add-object val)))) ((typep val 'SINGLE-FLOAT) - (when (and (ext:float-nan-p val) (not only-small-values)) - (cmperr "Cannot externalize value ~A" val)) (make-c1form* 'LOCATION :type 'SINGLE-FLOAT :args (list 'SINGLE-FLOAT-VALUE val (add-object val)))) ((typep val 'LONG-FLOAT) - (when (and (ext:float-nan-p val) (not only-small-values)) - (cmperr "Cannot externalize value ~A" val)) (make-c1form* 'LOCATION :type 'LONG-FLOAT :args (list 'LONG-FLOAT-VALUE val (add-object val)))) #+sse2 From e9f05ac85efa47c7bf9d51add2a7bfa29b41e528 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Jun 2023 13:03:20 +0200 Subject: [PATCH 13/23] cmp: c1constant-value: remove defunct parameter ONLY-SMALL-VALUES After inclusion of the externalizable NAN values the parameter ':ONLY-SMALL-VALUES T' is the same as ':ALWAYS NIL' (the default). That makes the the operator slightly easier to understand. --- src/cmp/cmppass1-call.lsp | 6 ++---- src/cmp/cmppass1-eval.lsp | 8 +++----- src/cmp/cmptype.lsp | 2 +- 3 files changed, 6 insertions(+), 10 deletions(-) diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp index 55af6949a..39b0ebf45 100644 --- a/src/cmp/cmppass1-call.lsp +++ b/src/cmp/cmppass1-call.lsp @@ -244,10 +244,8 @@ (return (let ((results (multiple-value-list (apply fname (nreverse all-values))))) (if (endp (rest results)) - (c1constant-value (first results) :only-small-values nil) - (let ((results (mapcar (lambda (r) - (c1constant-value r :only-small-values nil)) - results))) + (c1constant-value (first results)) + (let ((results (mapcar #'c1constant-value results))) (when (every #'identity results) (make-c1form* 'values :args results))))))) (error (c) (cmpdebug "Can't constant-fold ~s ~s: ~a~%" fname forms c))))) diff --git a/src/cmp/cmppass1-eval.lsp b/src/cmp/cmppass1-eval.lsp index 3cc72ed2d..f795cca64 100644 --- a/src/cmp/cmppass1-eval.lsp +++ b/src/cmp/cmppass1-eval.lsp @@ -25,9 +25,8 @@ ((keywordp form) (make-c1form* 'LOCATION :type (object-type form) :args (add-symbol form))) - ((constantp form *cmp-env*) - (or (c1constant-value (symbol-value form) :only-small-values t) - (c1var form))) + ((and (constantp form *cmp-env*) + (c1constant-value (symbol-value form)))) (t (c1var form)))) ((consp form) (cmpck (not (si:proper-list-p form)) @@ -117,7 +116,7 @@ (return form)) (setf form new-form)))) -(defun c1constant-value (val &key always only-small-values) +(defun c1constant-value (val &key always) (cond ;; FIXME includes in c1 pass. ((ext:when-let ((x (assoc val *optimizable-constants*))) @@ -146,7 +145,6 @@ #+sse2 ((typep val 'EXT:SSE-PACK) (c1constant-value/sse val)) - (only-small-values nil) (always (make-c1form* 'LOCATION :type `(eql ,val) :args (add-object val))) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 55132af6b..363133649 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -49,7 +49,7 @@ (si:complex-single-float . #c(0.0l0 0.0l0))) :test #'subtypep)))) (if new-value - (c1constant-value new-value :only-small-values t) + (c1constant-value new-value) (c1nil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From 1472bb18e6630b72341c69313edb2b5cd3d5eb78 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Jun 2023 09:32:00 +0200 Subject: [PATCH 14/23] cmpc: move c/c++ backend to a separate directory --- .../{ => cmpbackend-cxx}/cmpbackend-cxx.lsp | 0 src/cmp/{ => cmpbackend-cxx}/cmpc-inliner.lsp | 0 .../cmpc-mach.lsp} | 1 + src/cmp/{ => cmpbackend-cxx}/cmpc-wt.lsp | 0 .../{ => cmpbackend-cxx}/cmppass2-call.lsp | 0 .../{ => cmpbackend-cxx}/cmppass2-cont.lsp | 0 .../{ => cmpbackend-cxx}/cmppass2-data.lsp | 0 .../{ => cmpbackend-cxx}/cmppass2-eval.lsp | 0 .../{ => cmpbackend-cxx}/cmppass2-exit.lsp | 0 src/cmp/{ => cmpbackend-cxx}/cmppass2-ffi.lsp | 0 src/cmp/{ => cmpbackend-cxx}/cmppass2-fun.lsp | 0 src/cmp/{ => cmpbackend-cxx}/cmppass2-loc.lsp | 0 .../{ => cmpbackend-cxx}/cmppass2-special.lsp | 0 .../{ => cmpbackend-cxx}/cmppass2-stack.lsp | 0 src/cmp/{ => cmpbackend-cxx}/cmppass2-top.lsp | 0 src/cmp/{ => cmpbackend-cxx}/cmppass2-var.lsp | 0 src/cmp/load.lsp.in | 35 ++++++++++--------- 17 files changed, 19 insertions(+), 17 deletions(-) rename src/cmp/{ => cmpbackend-cxx}/cmpbackend-cxx.lsp (100%) rename src/cmp/{ => cmpbackend-cxx}/cmpc-inliner.lsp (100%) rename src/cmp/{cmpmach.lsp => cmpbackend-cxx/cmpc-mach.lsp} (99%) rename src/cmp/{ => cmpbackend-cxx}/cmpc-wt.lsp (100%) rename src/cmp/{ => cmpbackend-cxx}/cmppass2-call.lsp (100%) rename src/cmp/{ => cmpbackend-cxx}/cmppass2-cont.lsp (100%) rename src/cmp/{ => cmpbackend-cxx}/cmppass2-data.lsp (100%) rename src/cmp/{ => cmpbackend-cxx}/cmppass2-eval.lsp (100%) rename src/cmp/{ => cmpbackend-cxx}/cmppass2-exit.lsp (100%) rename src/cmp/{ => cmpbackend-cxx}/cmppass2-ffi.lsp (100%) rename src/cmp/{ => cmpbackend-cxx}/cmppass2-fun.lsp (100%) rename src/cmp/{ => cmpbackend-cxx}/cmppass2-loc.lsp (100%) rename src/cmp/{ => cmpbackend-cxx}/cmppass2-special.lsp (100%) rename src/cmp/{ => cmpbackend-cxx}/cmppass2-stack.lsp (100%) rename src/cmp/{ => cmpbackend-cxx}/cmppass2-top.lsp (100%) rename src/cmp/{ => cmpbackend-cxx}/cmppass2-var.lsp (100%) diff --git a/src/cmp/cmpbackend-cxx.lsp b/src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp similarity index 100% rename from src/cmp/cmpbackend-cxx.lsp rename to src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp diff --git a/src/cmp/cmpc-inliner.lsp b/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp similarity index 100% rename from src/cmp/cmpc-inliner.lsp rename to src/cmp/cmpbackend-cxx/cmpc-inliner.lsp diff --git a/src/cmp/cmpmach.lsp b/src/cmp/cmpbackend-cxx/cmpc-mach.lsp similarity index 99% rename from src/cmp/cmpmach.lsp rename to src/cmp/cmpbackend-cxx/cmpc-mach.lsp index 5c2e7e8d2..b79c57bc4 100644 --- a/src/cmp/cmpmach.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-mach.lsp @@ -1,4 +1,5 @@ +;;;; ;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya ;;;; Copyright (c) 1990, Giuseppe Attardi ;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll diff --git a/src/cmp/cmpc-wt.lsp b/src/cmp/cmpbackend-cxx/cmpc-wt.lsp similarity index 100% rename from src/cmp/cmpc-wt.lsp rename to src/cmp/cmpbackend-cxx/cmpc-wt.lsp diff --git a/src/cmp/cmppass2-call.lsp b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp similarity index 100% rename from src/cmp/cmppass2-call.lsp rename to src/cmp/cmpbackend-cxx/cmppass2-call.lsp diff --git a/src/cmp/cmppass2-cont.lsp b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp similarity index 100% rename from src/cmp/cmppass2-cont.lsp rename to src/cmp/cmpbackend-cxx/cmppass2-cont.lsp diff --git a/src/cmp/cmppass2-data.lsp b/src/cmp/cmpbackend-cxx/cmppass2-data.lsp similarity index 100% rename from src/cmp/cmppass2-data.lsp rename to src/cmp/cmpbackend-cxx/cmppass2-data.lsp diff --git a/src/cmp/cmppass2-eval.lsp b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp similarity index 100% rename from src/cmp/cmppass2-eval.lsp rename to src/cmp/cmpbackend-cxx/cmppass2-eval.lsp diff --git a/src/cmp/cmppass2-exit.lsp b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp similarity index 100% rename from src/cmp/cmppass2-exit.lsp rename to src/cmp/cmpbackend-cxx/cmppass2-exit.lsp diff --git a/src/cmp/cmppass2-ffi.lsp b/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp similarity index 100% rename from src/cmp/cmppass2-ffi.lsp rename to src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp diff --git a/src/cmp/cmppass2-fun.lsp b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp similarity index 100% rename from src/cmp/cmppass2-fun.lsp rename to src/cmp/cmpbackend-cxx/cmppass2-fun.lsp diff --git a/src/cmp/cmppass2-loc.lsp b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp similarity index 100% rename from src/cmp/cmppass2-loc.lsp rename to src/cmp/cmpbackend-cxx/cmppass2-loc.lsp diff --git a/src/cmp/cmppass2-special.lsp b/src/cmp/cmpbackend-cxx/cmppass2-special.lsp similarity index 100% rename from src/cmp/cmppass2-special.lsp rename to src/cmp/cmpbackend-cxx/cmppass2-special.lsp diff --git a/src/cmp/cmppass2-stack.lsp b/src/cmp/cmpbackend-cxx/cmppass2-stack.lsp similarity index 100% rename from src/cmp/cmppass2-stack.lsp rename to src/cmp/cmpbackend-cxx/cmppass2-stack.lsp diff --git a/src/cmp/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp similarity index 100% rename from src/cmp/cmppass2-top.lsp rename to src/cmp/cmpbackend-cxx/cmppass2-top.lsp diff --git a/src/cmp/cmppass2-var.lsp b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp similarity index 100% rename from src/cmp/cmppass2-var.lsp rename to src/cmp/cmpbackend-cxx/cmppass2-var.lsp diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 160d3f7d1..92e6f799b 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -10,7 +10,6 @@ "src:cmp;cmptype-arith.lsp" "src:cmp;cmppolicy.lsp" ;; Internal representation - "src:cmp;cmpmach.lsp" "src:cmp;cmprefs.lsp" "src:cmp;cmplocs.lsp" ;; Environment @@ -32,9 +31,6 @@ "src:cmp;cmptype-prop.lsp" "src:cmp;cmptype.lsp" "src:cmp;cmptype-assert.lsp" - ;; Abstract C machine - "src:cmp;cmpc-wt.lsp" - "src:cmp;cmpc-inliner.lsp" ;; AST building pass "src:cmp;cmppass1-data.lsp" "src:cmp;cmppass1-top.lsp" @@ -48,19 +44,25 @@ "src:cmp;cmppass1-ffi.lsp" ;; Type propagation pass "src:cmp;cmpprop.lsp" + ;; C/C++ backend + ;; Abstract C machine + "src:cmp;cmpbackend-cxx;cmpc-mach.lsp" + "src:cmp;cmpbackend-cxx;cmpc-wt.lsp" + "src:cmp;cmpbackend-cxx;cmpc-inliner.lsp" ;; Code generation pass - "src:cmp;cmppass2-data.lsp" - "src:cmp;cmppass2-top.lsp" - "src:cmp;cmppass2-stack.lsp" - "src:cmp;cmppass2-special.lsp" - "src:cmp;cmppass2-exit.lsp" - "src:cmp;cmppass2-cont.lsp" - "src:cmp;cmppass2-eval.lsp" - "src:cmp;cmppass2-call.lsp" - "src:cmp;cmppass2-var.lsp" - "src:cmp;cmppass2-loc.lsp" - "src:cmp;cmppass2-fun.lsp" - "src:cmp;cmppass2-ffi.lsp" + "src:cmp;cmpbackend-cxx;cmppass2-data.lsp" + "src:cmp;cmpbackend-cxx;cmppass2-top.lsp" + "src:cmp;cmpbackend-cxx;cmppass2-stack.lsp" + "src:cmp;cmpbackend-cxx;cmppass2-special.lsp" + "src:cmp;cmpbackend-cxx;cmppass2-exit.lsp" + "src:cmp;cmpbackend-cxx;cmppass2-cont.lsp" + "src:cmp;cmpbackend-cxx;cmppass2-eval.lsp" + "src:cmp;cmpbackend-cxx;cmppass2-call.lsp" + "src:cmp;cmpbackend-cxx;cmppass2-var.lsp" + "src:cmp;cmpbackend-cxx;cmppass2-loc.lsp" + "src:cmp;cmpbackend-cxx;cmppass2-fun.lsp" + "src:cmp;cmpbackend-cxx;cmppass2-ffi.lsp" + "src:cmp;cmpbackend-cxx;cmpbackend-cxx.lsp" ;; Optimizations "src:cmp;cmpct.lsp" "src:cmp;cmpmap.lsp" @@ -81,7 +83,6 @@ ;; Other "src:cmp;cmpos-run.lsp" "src:cmp;cmpos-features.lsp" - "src:cmp;cmpbackend-cxx.lsp" "src:cmp;cmpmain.lsp" "src:cmp;proclamations.lsp")) From 03be475fb9f50d5e8ae6f26dc8d7ecba724768ed Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Jun 2023 09:52:54 +0200 Subject: [PATCH 15/23] cmpc: clean up numeric optimizers and propagators - merge bits and numeric optimizers in a single file - move c/c++ optimizers to the backend - move bits and numeric propagators to a separate file --- src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp | 137 +++++++++ src/cmp/cmpnum.lsp | 322 -------------------- src/cmp/{cmpopt-bits.lsp => cmpopt-num.lsp} | 113 ++++--- src/cmp/cmpprop-num.lsp | 172 +++++++++++ src/cmp/load.lsp.in | 5 +- 5 files changed, 378 insertions(+), 371 deletions(-) create mode 100644 src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp delete mode 100644 src/cmp/cmpnum.lsp rename src/cmp/{cmpopt-bits.lsp => cmpopt-num.lsp} (62%) create mode 100644 src/cmp/cmpprop-num.lsp diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp new file mode 100644 index 000000000..08656d56a --- /dev/null +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp @@ -0,0 +1,137 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +;;;; +;;;; Copyright (c) 2010, Juan Jose Garcia Ripoll +;;;; Copyright (c) 2023, Daniel Kochmański +;;;; +;;;; See the file 'LICENSE' for the copyright details. +;;;; + +;;;; C/C++ specific optimizer for numerical expressions. + +(in-package "COMPILER") + +;;; +;;; Bit fiddling. It is a bit tricky because C does not allow +;;; shifts in << or >> which exceed the integer size. In those +;;; cases the compiler may do whatever it wants (and gcc does!) +;;; +(define-c-inliner shift (return-type argument orig-shift) + (let* ((arg-type (inlined-arg-type argument)) + (arg-c-type (lisp-type->rep-type arg-type)) + (return-c-type (lisp-type->rep-type return-type)) + (shift (loc-immediate-value (inlined-arg-loc orig-shift)))) + (if (or (not (c-integer-rep-type-p arg-c-type)) + (not (c-integer-rep-type-p return-c-type))) + (produce-inline-loc (list argument orig-shift) '(:object :fixnum) '(:object) + "ecl_ash(#0,#1)" nil t) + (let* ((arg-bits (c-integer-rep-type-bits arg-c-type)) + (return-bits (c-integer-rep-type-bits return-c-type)) + (max-type (if (and (plusp shift) + (< arg-bits return-bits)) + return-c-type + arg-c-type))) + (produce-inline-loc (list argument) (list max-type) (list return-type) + (format nil + (if (minusp shift) + "((#0) >> (~D))" + "((#0) << (~D))") + (abs shift)) + nil t))))) + +;;; +;;; Inliners for arithmetic operations. +;;; + +(defun most-generic-number-rep-type (r1 r2) + (let* ((r1 (rep-type-record r1)) + (r2 (rep-type-record r2))) + (rep-type-name (if (< (rep-type-index r1) (rep-type-index r2)) + r2 + r1)))) + +(defun inline-binop (expected-type arg1 arg2 consing non-consing) + (let ((arg1-type (inlined-arg-type arg1)) + (arg2-type (inlined-arg-type arg2))) + (if (and (policy-assume-right-type) + (c-number-type-p expected-type) + (c-number-type-p arg1-type) + (c-number-type-p arg2-type)) + ;; The input arguments have to be coerced to a C + ;; type that fits the output, to avoid overflow which + ;; would happen if we used say, long c = (int)a * (int)b + ;; as the output would be an integer, not a long. + (let* ((arg1-rep (lisp-type->rep-type arg1-type)) + (arg2-rep (lisp-type->rep-type arg2-type)) + (out-rep (lisp-type->rep-type expected-type)) + (max-rep (most-generic-number-rep-type + (most-generic-number-rep-type + arg1-rep arg2-rep) out-rep)) + (max-name (rep-type->c-name max-rep))) + (produce-inline-loc + (list arg1 arg2) + (list arg1-rep arg2-rep) + (list max-rep) + (format nil "(~@[(~A)~]#0)~A(~@[(~A)~]#1)" + (unless (eq arg1-rep max-rep) max-name) + non-consing + (unless (eq arg2-rep max-rep) max-name)) + nil t)) + (produce-inline-loc (list arg1 arg2) '(:object :object) '(:object) + consing nil t)))) + +(defun inline-arith-unop (expected-type arg1 consing non-consing) + (let ((arg1-type (inlined-arg-type arg1))) + (if (and (policy-assume-right-type) + (c-number-type-p expected-type) + (c-number-type-p arg1-type)) + (produce-inline-loc (list arg1) + (list (lisp-type->rep-type arg1-type)) + (list (lisp-type->rep-type expected-type)) + non-consing nil t) + (produce-inline-loc (list arg1) '(:object :object) '(:object) + consing nil t)))) + +(define-c-inliner + (return-type &rest arguments &aux arg1 arg2) + (when (null arguments) + (return '(fixnum-value 0))) + (setf arg1 (pop arguments)) + (when (null arguments) + (return (inlined-arg-loc arg1))) + (loop for arg2 = (pop arguments) + for result = (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+) + do (if arguments + (setf arg1 (save-inline-loc result)) + (return result)))) + +(define-c-inliner - (return-type arg1 &rest arguments &aux arg2) + (when (null arguments) + (return (inline-arith-unop return-type arg1 "ecl_negate(#0)" "-(#0)"))) + (loop for arg2 = (pop arguments) + for result = (inline-binop return-type arg1 arg2 "ecl_minus(#0,#1)" #\-) + do (if arguments + (setf arg1 (save-inline-loc result)) + (return result)))) + +(define-c-inliner * (return-type &rest arguments &aux arg1 arg2) + (when (null arguments) + (return '(fixnum-value 1))) + (setf arg1 (pop arguments)) + (when (null arguments) + (return (inlined-arg-loc arg1))) + (loop for arg2 = (pop arguments) + for result = (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*) + do (if arguments + (setf arg1 (save-inline-loc result)) + (return result)))) + +(define-c-inliner / (return-type arg1 &rest arguments &aux arg2) + (when (null arguments) + (return (inline-arith-unop return-type arg1 + "ecl_divide(ecl_make_fixnum(1),(#0))" "1/(#0)"))) + (loop for arg2 = (pop arguments) + for result = (inline-binop return-type arg1 arg2 "ecl_divide(#0,#1)" #\/) + do (if arguments + (setf arg1 (save-inline-loc result)) + (return result)))) diff --git a/src/cmp/cmpnum.lsp b/src/cmp/cmpnum.lsp deleted file mode 100644 index 54a59fe67..000000000 --- a/src/cmp/cmpnum.lsp +++ /dev/null @@ -1,322 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; -;;;; CMPNUM -- Optimizer for numerical expressions. - -;;;; Copyright (c) 2005, Juan Jose Garcia Ripoll -;;;; -;;;; ECoLisp is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. -;;;; -;;;; See file '../Copyright' for full details. - -(in-package "COMPILER") - -;;---------------------------------------------------------------------- -;; We transform BOOLE into the individual operations, which have -;; inliners -;; - -(define-compiler-macro boole (&whole form op-code op1 op2) - (or (and (constantp op-code *cmp-env*) - (case (ext:constant-form-value op-code *cmp-env*) - (#. boole-clr `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) 0)) - (#. boole-set `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) -1)) - (#. boole-1 `(prog1 (ext:checked-value integer ,op1) (ext:checked-value integer ,op2))) - (#. boole-2 `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2))) - (#. boole-c1 `(prog1 (lognot ,op1) (ext:checked-value integer ,op2))) - (#. boole-c2 `(progn (ext:checked-value integer ,op1) (lognot ,op2))) - (#. boole-and `(logand ,op1 ,op2)) - (#. boole-ior `(logior ,op1 ,op2)) - (#. boole-xor `(logxor ,op1 ,op2)) - (#. boole-eqv `(logeqv ,op1 ,op2)) - (#. boole-nand `(lognand ,op1 ,op2)) - (#. boole-nor `(lognor ,op1 ,op2)) - (#. boole-andc1 `(logandc1 ,op1 ,op2)) - (#. boole-andc2 `(logandc2 ,op1 ,op2)) - (#. boole-orc1 `(logorc1 ,op1 ,op2)) - (#. boole-orc2 `(logorc2 ,op1 ,op2)))) - form)) - -(defun simplify-arithmetic (operator args whole) - (if (every #'numberp args) - (apply operator args) - (let ((l (length args))) - (cond ((> l 2) - (simplify-arithmetic - operator - (list* (simplify-arithmetic operator - (list (first args) (second args)) - nil) - (cddr args)) - nil)) - ((= l 2) - (or whole (list* operator args))) - ((= l 1) - (if (or (eq operator '*) (eq operator '+)) - (first args) - (or whole (list* operator args)))) - ((eq operator '*) - 1) - ((eq operator '+) - 0) - (t - (error 'simple-program-error - :format-error "Wrong number of arguments for operator ~a in ~a" - :format-arguments (list operator (or whole - (list* operator args))))))))) - -(define-compiler-macro * (&whole all &rest args) - (simplify-arithmetic '* args all)) - -(define-compiler-macro + (&whole all &rest args) - (simplify-arithmetic '+ args all)) - -(define-compiler-macro / (&whole all &rest args) - (simplify-arithmetic '/ args all)) - -(define-compiler-macro - (&whole all &rest args) - (simplify-arithmetic '- args all)) - -;;; -;;; The following are type propagators for arithmetic operations. Note -;;; that some of they have become binary operators. -;;; - -(defun maximum-number-type (type1 type2 &key only-real integer-result) - ;; Computes the output type of an operation between number types T1 - ;; and T2 using the rules of floating point contagion. It returns - ;; the type of the result, and the types of T1 and T2, if they - ;; represent known types, or NUMBER, in other cases. - (let ((t1-eq nil) - (t2-eq nil) - (t1 type1) - (t2 type2) - (output nil) - (complex-t1 nil) - (complex-t2 nil) - (default (if only-real 'REAL 'NUMBER)) - (number-types #(FIXNUM INTEGER RATIONAL SINGLE-FLOAT - DOUBLE-FLOAT LONG-FLOAT FLOAT REAL))) - (when (and (consp t1) (eq (first t1) 'COMPLEX)) - (setf t1 (second t1) complex-t1 t)) - (when (and (consp t2) (eq (first t2) 'COMPLEX)) - (setf t2 (second t2) complex-t2 t)) - (when (and only-real (or complex-t1 complex-t2)) - (return-from maximum-number-type (values default default default))) - (loop for i across number-types - do (when (and (null t1-eq) (type>= i t1)) - (when (equalp t1 t2) - (setf t2-eq i)) - (setf t1-eq i output i)) - (when (and (null t2-eq) (type>= i t2)) - (setf t2-eq i output i))) - (unless (and t1-eq t2-eq output) - (setf output default)) - (when (and integer-result (or (eq output 'FIXNUM) (eq output 'INTEGER))) - (setf output integer-result)) - (when (and (or complex-t1 complex-t2) (not (eq output 'NUMBER))) - (setf output (if (eq output 'REAL) 'COMPLEX `(COMPLEX ,output)))) - (values output (if t1-eq type1 default) (if t2-eq type2 default)))) - -(defun ensure-number-type (general-type &key integer-result) - (maximum-number-type general-type general-type :integer-result integer-result)) - -(defun ensure-nonrational-type (general-type) - (maximum-number-type general-type 'single-float)) - -(defun ensure-real-type (general-type) - (maximum-number-type general-type 'integer :only-real t)) - -(defun arithmetic-propagator (op1-type others integer-result) - ;; Propagates types for an associative operator (we do not care which one). - ;; We collect either the types of the arguments or 'NUMBER, as a generic - ;; expected type. The output type is computed using the rules of floating - ;; point contagion, with the exception that an operation between two - ;; integers has type INTEGER-RESULT (integer for *,-,+ and rational else) - (multiple-value-bind (result-type op1-type) - (ensure-number-type op1-type :integer-result integer-result) - (loop with arg-types = (list op1-type) - for x in others - for op2-type = x - do (progn - (multiple-value-setq (result-type op1-type op2-type) - (maximum-number-type result-type op2-type :integer-result integer-result)) - (setf arg-types (cons op2-type arg-types))) - finally (return (values (nreverse arg-types) result-type))))) - -(def-type-propagator * (fname op1 &rest others) - (arithmetic-propagator op1 others 'integer)) - -(copy-type-propagator '* '(+ -)) - -(def-type-propagator / (fname op1 &rest others) - (arithmetic-propagator op1 others 'rational)) - -(defun most-generic-number-rep-type (r1 r2) - (let* ((r1 (rep-type-record r1)) - (r2 (rep-type-record r2))) - (rep-type-name (if (< (rep-type-index r1) (rep-type-index r2)) - r2 - r1)))) - -(defun inline-binop (expected-type arg1 arg2 consing non-consing) - (let ((arg1-type (inlined-arg-type arg1)) - (arg2-type (inlined-arg-type arg2))) - (if (and (policy-assume-right-type) - (c-number-type-p expected-type) - (c-number-type-p arg1-type) - (c-number-type-p arg2-type)) - ;; The input arguments have to be coerced to a C - ;; type that fits the output, to avoid overflow which - ;; would happen if we used say, long c = (int)a * (int)b - ;; as the output would be an integer, not a long. - (let* ((arg1-rep (lisp-type->rep-type arg1-type)) - (arg2-rep (lisp-type->rep-type arg2-type)) - (out-rep (lisp-type->rep-type expected-type)) - (max-rep (most-generic-number-rep-type - (most-generic-number-rep-type - arg1-rep arg2-rep) out-rep)) - (max-name (rep-type->c-name max-rep))) - (produce-inline-loc - (list arg1 arg2) - (list arg1-rep arg2-rep) - (list max-rep) - (format nil "(~@[(~A)~]#0)~A(~@[(~A)~]#1)" - (unless (eq arg1-rep max-rep) max-name) - non-consing - (unless (eq arg2-rep max-rep) max-name)) - nil t)) - (produce-inline-loc (list arg1 arg2) '(:object :object) '(:object) - consing nil t)))) - -(defun inline-arith-unop (expected-type arg1 consing non-consing) - (let ((arg1-type (inlined-arg-type arg1))) - (if (and (policy-assume-right-type) - (c-number-type-p expected-type) - (c-number-type-p arg1-type)) - (produce-inline-loc (list arg1) - (list (lisp-type->rep-type arg1-type)) - (list (lisp-type->rep-type expected-type)) - non-consing nil t) - (produce-inline-loc (list arg1) '(:object :object) '(:object) - consing nil t)))) - -(define-c-inliner + (return-type &rest arguments &aux arg1 arg2) - (when (null arguments) - (return '(fixnum-value 0))) - (setf arg1 (pop arguments)) - (when (null arguments) - (return (inlined-arg-loc arg1))) - (loop for arg2 = (pop arguments) - for result = (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+) - do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) - -(define-c-inliner - (return-type arg1 &rest arguments &aux arg2) - (when (null arguments) - (return (inline-arith-unop return-type arg1 "ecl_negate(#0)" "-(#0)"))) - (loop for arg2 = (pop arguments) - for result = (inline-binop return-type arg1 arg2 "ecl_minus(#0,#1)" #\-) - do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) - -(define-c-inliner * (return-type &rest arguments &aux arg1 arg2) - (when (null arguments) - (return '(fixnum-value 1))) - (setf arg1 (pop arguments)) - (when (null arguments) - (return (inlined-arg-loc arg1))) - (loop for arg2 = (pop arguments) - for result = (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*) - do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) - -(define-c-inliner / (return-type arg1 &rest arguments &aux arg2) - (when (null arguments) - (return (inline-arith-unop return-type arg1 - "ecl_divide(ecl_make_fixnum(1),(#0))" "1/(#0)"))) - (loop for arg2 = (pop arguments) - for result = (inline-binop return-type arg1 arg2 "ecl_divide(#0,#1)" #\/) - do (if arguments - (setf arg1 (save-inline-loc result)) - (return result)))) - -;;; -;;; SPECIAL FUNCTIONS -;;; - -(def-type-propagator cos (fname op1-type) - (multiple-value-bind (output-type op1-type) - (ensure-nonrational-type op1-type) - (values (list op1-type) output-type))) - -(copy-type-propagator 'cos '(sin tan cosh sinh tanh exp)) - -(def-type-propagator acos (fname op1-type) - (multiple-value-bind (output-type op1-type) - (ensure-nonrational-type op1-type) - (declare (ignore output-type)) - (values (list op1-type) 'NUMBER))) - -(def-type-propagator atan (fname op1-type &optional (op2-type t op2-p)) - (multiple-value-bind (float-t1 t1) - (ensure-nonrational-type op1-type) - (if op2-p - (multiple-value-bind (result t1 t2) - (maximum-number-type t1 op2-type :only-real t) - (values (list t1 t2) result)) - (values (list t1) float-t1)))) - -(def-type-propagator expt (fname base exponent) - ;; Rules: - ;; (expt fixnum integer) -> integer - ;; (expt number-type integer) -> number-type - ;; (expt number-type1 number-type2) -> (max-float number-type1 number-type2) - ;; - (let ((exponent (ensure-real-type exponent))) - (values (list base exponent) - (cond ((eql exponent 'integer) - (if (subtypep base 'fixnum) - 'integer - base)) - ((type>= '(real 0 *) base) - (let* ((exponent (ensure-nonrational-type exponent))) - (maximum-number-type exponent base))) - (t - 'number))))) - -(def-type-propagator abs (fname arg) - (multiple-value-bind (output arg) - (ensure-number-type arg) - (values (list arg) - (or (cdr (assoc output - '((FIXNUM . (INTEGER 0 #.MOST-POSITIVE-FIXNUM)) - (INTEGER . (INTEGER 0 *)) - (RATIONAL . (RATIONAL 0 *)) - (SHORT-FLOAT . (SHORT-FLOAT 0 *)) - (SINGLE-FLOAT . (SINGLE-FLOAT 0 *)) - (DOUBLE-FLOAT . (DOUBLE-FLOAT 0 *)) - (LONG-FLOAT . (LONG-FLOAT 0 *)) - (REAL . (REAL 0 *)) - (NUMBER . (REAL 0 *))))) - output)))) - -(def-type-propagator sqrt (fname arg) - (multiple-value-bind (output arg) - (ensure-nonrational-type arg) - (values (list arg) - (if (type>= '(REAL 0 *) arg) output 'NUMBER)))) - -(def-type-propagator isqrt (fname arg) - (if (type>= '(integer 0 #.MOST-POSITIVE-FIXNUM) arg) - (values '((integer 0 #.MOST-POSITIVE-FIXNUM)) - '(integer 0 #.MOST-POSITIVE-FIXNUM)) - (values '((integer 0 *)) '(integer 0 *)))) - diff --git a/src/cmp/cmpopt-bits.lsp b/src/cmp/cmpopt-num.lsp similarity index 62% rename from src/cmp/cmpopt-bits.lsp rename to src/cmp/cmpopt-num.lsp index 88c7d42b3..4a02ab562 100644 --- a/src/cmp/cmpopt-bits.lsp +++ b/src/cmp/cmpopt-num.lsp @@ -1,21 +1,40 @@ ;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- ;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: +;;;; Copyright (c) 2010, Juan Jose Garcia Ripoll ;;;; -;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll -;;;; -;;;; This program is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. -;;;; -;;;; See file '../Copyright' for full details. -;;;; -;;;; CMPOPT-BITS -- Optimize operations acting on bits +;;;; See the file 'LICENSE' for the copyright details. ;;;; +;;;; Optimizer for numerical expressions. + (in-package "COMPILER") +;;; +;;; We transform BOOLE into the individual operations, which have inliners +;;; + +(define-compiler-macro boole (&whole form op-code op1 op2) + (or (and (constantp op-code *cmp-env*) + (case (ext:constant-form-value op-code *cmp-env*) + (#. boole-clr `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) 0)) + (#. boole-set `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) -1)) + (#. boole-1 `(prog1 (ext:checked-value integer ,op1) (ext:checked-value integer ,op2))) + (#. boole-2 `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2))) + (#. boole-c1 `(prog1 (lognot ,op1) (ext:checked-value integer ,op2))) + (#. boole-c2 `(progn (ext:checked-value integer ,op1) (lognot ,op2))) + (#. boole-and `(logand ,op1 ,op2)) + (#. boole-ior `(logior ,op1 ,op2)) + (#. boole-xor `(logxor ,op1 ,op2)) + (#. boole-eqv `(logeqv ,op1 ,op2)) + (#. boole-nand `(lognand ,op1 ,op2)) + (#. boole-nor `(lognor ,op1 ,op2)) + (#. boole-andc1 `(logandc1 ,op1 ,op2)) + (#. boole-andc2 `(logandc2 ,op1 ,op2)) + (#. boole-orc1 `(logorc1 ,op1 ,op2)) + (#. boole-orc2 `(logorc2 ,op1 ,op2)))) + form)) + ;;; ;;; LDB ;;; Look for inline expansion of LDB1 in sysfun.lsp @@ -123,9 +142,6 @@ ;;; ;;; ASH -;;; Bit fiddling. It is a bit tricky because C does not allow -;;; shifts in << or >> which exceed the integer size. In those -;;; cases the compiler may do whatever it wants (and gcc does!) ;;; (define-compiler-macro ash (&whole whole argument shift) @@ -140,39 +156,42 @@ (t whole))) -(define-c-inliner shift (return-type argument orig-shift) - (let* ((arg-type (inlined-arg-type argument)) - (arg-c-type (lisp-type->rep-type arg-type)) - (return-c-type (lisp-type->rep-type return-type)) - (shift (loc-immediate-value (inlined-arg-loc orig-shift)))) - (if (or (not (c-integer-rep-type-p arg-c-type)) - (not (c-integer-rep-type-p return-c-type))) - (produce-inline-loc (list argument orig-shift) '(:object :fixnum) '(:object) - "ecl_ash(#0,#1)" nil t) - (let* ((arg-bits (c-integer-rep-type-bits arg-c-type)) - (return-bits (c-integer-rep-type-bits return-c-type)) - (max-type (if (and (plusp shift) - (< arg-bits return-bits)) - return-c-type - arg-c-type))) - (produce-inline-loc (list argument) (list max-type) (list return-type) - (format nil - (if (minusp shift) - "((#0) >> (~D))" - "((#0) << (~D))") - (abs shift)) - nil t))))) +(defun simplify-arithmetic (operator args whole) + (if (every #'numberp args) + (apply operator args) + (let ((l (length args))) + (cond ((> l 2) + (simplify-arithmetic + operator + (list* (simplify-arithmetic operator + (list (first args) (second args)) + nil) + (cddr args)) + nil)) + ((= l 2) + (or whole (list* operator args))) + ((= l 1) + (if (or (eq operator '*) (eq operator '+)) + (first args) + (or whole (list* operator args)))) + ((eq operator '*) + 1) + ((eq operator '+) + 0) + (t + (error 'simple-program-error + :format-error "Wrong number of arguments for operator ~a in ~a" + :format-arguments (list operator (or whole + (list* operator args))))))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; TYPE PROPAGATION -;;; +(define-compiler-macro * (&whole all &rest args) + (simplify-arithmetic '* args all)) -(def-type-propagator logand (fname &rest args) - (values args - (if args - (dolist (int-type '((UNSIGNED-BYTE 8) FIXNUM) 'integer) - (when (loop for value in args - always (subtypep value int-type)) - (return int-type))) - 'fixnum))) +(define-compiler-macro + (&whole all &rest args) + (simplify-arithmetic '+ args all)) + +(define-compiler-macro / (&whole all &rest args) + (simplify-arithmetic '/ args all)) + +(define-compiler-macro - (&whole all &rest args) + (simplify-arithmetic '- args all)) diff --git a/src/cmp/cmpprop-num.lsp b/src/cmp/cmpprop-num.lsp new file mode 100644 index 000000000..7eccdf2d7 --- /dev/null +++ b/src/cmp/cmpprop-num.lsp @@ -0,0 +1,172 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +;;;; Copyright (c) 2010, Juan Jose Garcia Ripoll +;;;; +;;;; See the file 'LICENSE' for the copyright details. +;;;; + +;;;; Type propagators for numerical expressions. + +(in-package "COMPILER") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; TYPE PROPAGATION +;;; + +(def-type-propagator logand (fname &rest args) + (values args + (if args + (dolist (int-type '((UNSIGNED-BYTE 8) FIXNUM) 'integer) + (when (loop for value in args + always (subtypep value int-type)) + (return int-type))) + 'fixnum))) + +;;; +;;; The following are type propagators for arithmetic operations. Note +;;; that some of they have become binary operators. +;;; + +(defun maximum-number-type (type1 type2 &key only-real integer-result) + ;; Computes the output type of an operation between number types T1 + ;; and T2 using the rules of floating point contagion. It returns + ;; the type of the result, and the types of T1 and T2, if they + ;; represent known types, or NUMBER, in other cases. + (let ((t1-eq nil) + (t2-eq nil) + (t1 type1) + (t2 type2) + (output nil) + (complex-t1 nil) + (complex-t2 nil) + (default (if only-real 'REAL 'NUMBER)) + (number-types #(FIXNUM INTEGER RATIONAL SINGLE-FLOAT + DOUBLE-FLOAT LONG-FLOAT FLOAT REAL))) + (when (and (consp t1) (eq (first t1) 'COMPLEX)) + (setf t1 (second t1) complex-t1 t)) + (when (and (consp t2) (eq (first t2) 'COMPLEX)) + (setf t2 (second t2) complex-t2 t)) + (when (and only-real (or complex-t1 complex-t2)) + (return-from maximum-number-type (values default default default))) + (loop for i across number-types + do (when (and (null t1-eq) (type>= i t1)) + (when (equalp t1 t2) + (setf t2-eq i)) + (setf t1-eq i output i)) + (when (and (null t2-eq) (type>= i t2)) + (setf t2-eq i output i))) + (unless (and t1-eq t2-eq output) + (setf output default)) + (when (and integer-result (or (eq output 'FIXNUM) (eq output 'INTEGER))) + (setf output integer-result)) + (when (and (or complex-t1 complex-t2) (not (eq output 'NUMBER))) + (setf output (if (eq output 'REAL) 'COMPLEX `(COMPLEX ,output)))) + (values output (if t1-eq type1 default) (if t2-eq type2 default)))) + +(defun ensure-number-type (general-type &key integer-result) + (maximum-number-type general-type general-type :integer-result integer-result)) + +(defun ensure-nonrational-type (general-type) + (maximum-number-type general-type 'single-float)) + +(defun ensure-real-type (general-type) + (maximum-number-type general-type 'integer :only-real t)) + +(defun arithmetic-propagator (op1-type others integer-result) + ;; Propagates types for an associative operator (we do not care which one). + ;; We collect either the types of the arguments or 'NUMBER, as a generic + ;; expected type. The output type is computed using the rules of floating + ;; point contagion, with the exception that an operation between two + ;; integers has type INTEGER-RESULT (integer for *,-,+ and rational else) + (multiple-value-bind (result-type op1-type) + (ensure-number-type op1-type :integer-result integer-result) + (loop with arg-types = (list op1-type) + for x in others + for op2-type = x + do (progn + (multiple-value-setq (result-type op1-type op2-type) + (maximum-number-type result-type op2-type :integer-result integer-result)) + (setf arg-types (cons op2-type arg-types))) + finally (return (values (nreverse arg-types) result-type))))) + +(def-type-propagator * (fname op1 &rest others) + (arithmetic-propagator op1 others 'integer)) + +(copy-type-propagator '* '(+ -)) + +(def-type-propagator / (fname op1 &rest others) + (arithmetic-propagator op1 others 'rational)) + +;;; +;;; SPECIAL FUNCTIONS +;;; + +(def-type-propagator cos (fname op1-type) + (multiple-value-bind (output-type op1-type) + (ensure-nonrational-type op1-type) + (values (list op1-type) output-type))) + +(copy-type-propagator 'cos '(sin tan cosh sinh tanh exp)) + +(def-type-propagator acos (fname op1-type) + (multiple-value-bind (output-type op1-type) + (ensure-nonrational-type op1-type) + (declare (ignore output-type)) + (values (list op1-type) 'NUMBER))) + +(def-type-propagator atan (fname op1-type &optional (op2-type t op2-p)) + (multiple-value-bind (float-t1 t1) + (ensure-nonrational-type op1-type) + (if op2-p + (multiple-value-bind (result t1 t2) + (maximum-number-type t1 op2-type :only-real t) + (values (list t1 t2) result)) + (values (list t1) float-t1)))) + +(def-type-propagator expt (fname base exponent) + ;; Rules: + ;; (expt fixnum integer) -> integer + ;; (expt number-type integer) -> number-type + ;; (expt number-type1 number-type2) -> (max-float number-type1 number-type2) + ;; + (let ((exponent (ensure-real-type exponent))) + (values (list base exponent) + (cond ((eql exponent 'integer) + (if (subtypep base 'fixnum) + 'integer + base)) + ((type>= '(real 0 *) base) + (let* ((exponent (ensure-nonrational-type exponent))) + (maximum-number-type exponent base))) + (t + 'number))))) + +(def-type-propagator abs (fname arg) + (multiple-value-bind (output arg) + (ensure-number-type arg) + (values (list arg) + (or (cdr (assoc output + '((FIXNUM . (INTEGER 0 #.MOST-POSITIVE-FIXNUM)) + (INTEGER . (INTEGER 0 *)) + (RATIONAL . (RATIONAL 0 *)) + (SHORT-FLOAT . (SHORT-FLOAT 0 *)) + (SINGLE-FLOAT . (SINGLE-FLOAT 0 *)) + (DOUBLE-FLOAT . (DOUBLE-FLOAT 0 *)) + (LONG-FLOAT . (LONG-FLOAT 0 *)) + (REAL . (REAL 0 *)) + (NUMBER . (REAL 0 *))))) + output)))) + +(def-type-propagator sqrt (fname arg) + (multiple-value-bind (output arg) + (ensure-nonrational-type arg) + (values (list arg) + (if (type>= '(REAL 0 *) arg) output 'NUMBER)))) + +(def-type-propagator isqrt (fname arg) + (if (type>= '(integer 0 #.MOST-POSITIVE-FIXNUM) arg) + (values '((integer 0 #.MOST-POSITIVE-FIXNUM)) + '(integer 0 #.MOST-POSITIVE-FIXNUM)) + (values '((integer 0 *)) '(integer 0 *)))) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 92e6f799b..2465fdff5 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -44,11 +44,13 @@ "src:cmp;cmppass1-ffi.lsp" ;; Type propagation pass "src:cmp;cmpprop.lsp" + "src:cmp;cmpprop-num.lsp" ;; C/C++ backend ;; Abstract C machine "src:cmp;cmpbackend-cxx;cmpc-mach.lsp" "src:cmp;cmpbackend-cxx;cmpc-wt.lsp" "src:cmp;cmpbackend-cxx;cmpc-inliner.lsp" + "src:cmp;cmpbackend-cxx;cmpc-opt-num.lsp" ;; Code generation pass "src:cmp;cmpbackend-cxx;cmppass2-data.lsp" "src:cmp;cmpbackend-cxx;cmppass2-top.lsp" @@ -66,10 +68,9 @@ ;; Optimizations "src:cmp;cmpct.lsp" "src:cmp;cmpmap.lsp" - "src:cmp;cmpnum.lsp" "src:cmp;cmpname.lsp" "src:cmp;cmpopt.lsp" - "src:cmp;cmpopt-bits.lsp" + "src:cmp;cmpopt-num.lsp" "src:cmp;cmpopt-clos.lsp" "src:cmp;cmpopt-constant.lsp" "src:cmp;cmpopt-cons.lsp" From 220b7c736382f6068e5ae86e3888da6aed42b398 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Jun 2023 10:19:49 +0200 Subject: [PATCH 16/23] cmpc: move constant and inlining c/c++ optimizations Move appropriate files to the C/C++ backend. --- .../cmpc-opt-ct.lsp} | 10 ++---- .../cmpc-opt-inl.lsp} | 34 ++++--------------- src/cmp/cmpform.lsp | 1 - src/cmp/cmpfun.lsp | 7 ++++ src/cmp/cmppass1-var.lsp | 4 +-- src/cmp/cmpvar.lsp | 2 +- src/cmp/load.lsp.in | 4 +-- 7 files changed, 21 insertions(+), 41 deletions(-) rename src/cmp/{cmpct.lsp => cmpbackend-cxx/cmpc-opt-ct.lsp} (92%) rename src/cmp/{cmpinline.lsp => cmpbackend-cxx/cmpc-opt-inl.lsp} (84%) diff --git a/src/cmp/cmpct.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp similarity index 92% rename from src/cmp/cmpct.lsp rename to src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp index 09a4265ec..7cf5550cb 100644 --- a/src/cmp/cmpct.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp @@ -2,16 +2,12 @@ ;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: ;;;; -;;;; CMPCT -- Optimizer for several constant values - ;;;; Copyright (c) 2003, Juan Jose Garcia Ripoll. ;;;; -;;;; ECoLisp is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. +;;;; See the file 'LICENSE' for the copyright details. ;;;; -;;;; See file '../Copyright' for full details. + +;;;; Optimizer for several constant values (in-package "COMPILER") diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp similarity index 84% rename from src/cmp/cmpinline.lsp rename to src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp index 086fa9bce..7bf2e431d 100644 --- a/src/cmp/cmpinline.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-inl.lsp @@ -2,17 +2,13 @@ ;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: ;;;; -;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. -;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya +;;;; Copyright (c) 1990, Giuseppe Attardi ;;;; -;;;; This program is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. +;;;; See the file 'LICENSE' for the copyright details. ;;;; -;;;; See file '../Copyright' for full details. -;;;; CMPINLINE Open coding optimizer. +;;;; Open coding optimizer. (in-package "COMPILER") @@ -50,11 +46,6 @@ (set-loc loc) temp)) -(defmacro with-inlined-loc ((temp-loc loc) &rest body) - `(let ((,temp-loc (save-inline-loc ,loc))) - (setf ,temp-loc (list (var-type ,temp-loc) ,temp-loc)) - ,@body)) - (defun emit-inlined-variable (form rest-forms) (let ((var (c1form-arg 0 form)) (value-type (c1form-primary-type form))) @@ -104,7 +95,7 @@ (defun emit-inlined-structure-ref (form rest-forms) (let ((type (c1form-primary-type form))) - (if (args-cause-side-effect rest-forms) + (if (some #'c1form-side-effects rest-forms) (let* ((temp (make-inline-temp-var type :object)) (*destination* temp)) (c2expr* form) @@ -119,7 +110,7 @@ (defun emit-inlined-instance-ref (form rest-forms) (let ((type (c1form-primary-type form))) - (if (args-cause-side-effect rest-forms) + (if (some #'c1form-side-effects rest-forms) (let* ((temp (make-inline-temp-var type :object)) (*destination* temp)) (c2expr* form) @@ -185,16 +176,3 @@ (defun close-inline-blocks () (loop for i of-type fixnum from 0 below *inline-blocks* do (wt-nl-close-brace))) - -(defun form-causes-side-effect (form) - (c1form-side-effects form)) - -(defun args-cause-side-effect (forms) - (some #'c1form-side-effects forms)) - -(defun function-may-have-side-effects (fname) - (not (si:get-sysprop fname 'no-side-effects))) - -(defun function-may-change-sp (fname) - (not (or (si:get-sysprop fname 'no-side-effects) - (si:get-sysprop fname 'no-sp-change)))) diff --git a/src/cmp/cmpform.lsp b/src/cmp/cmpform.lsp index e5ede9ad0..45fc4b8a4 100644 --- a/src/cmp/cmpform.lsp +++ b/src/cmp/cmpform.lsp @@ -251,4 +251,3 @@ (defun c1form-constant-p (form) (when (eq (c1form-name form) 'LOCATION) (loc-immediate-value-p (c1form-arg 0 form)))) - diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp index c571eeb1a..7b1908496 100644 --- a/src/cmp/cmpfun.lsp +++ b/src/cmp/cmpfun.lsp @@ -176,3 +176,10 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (if (and (symbolp name) (setf cname (si:get-sysprop name 'Lfun))) (values cname t) (values (next-cfun "L~D~A" name) nil)))) + +(defun function-may-have-side-effects (fname) + (not (si:get-sysprop fname 'no-side-effects))) + +(defun function-may-change-sp (fname) + (not (or (si:get-sysprop fname 'no-side-effects) + (si:get-sysprop fname 'no-sp-change)))) diff --git a/src/cmp/cmppass1-var.lsp b/src/cmp/cmppass1-var.lsp index 1448935a6..0d41aae6c 100644 --- a/src/cmp/cmppass1-var.lsp +++ b/src/cmp/cmppass1-var.lsp @@ -171,7 +171,7 @@ ;; - e2 produces no side effects (when (and (= 0 (var-ref var)) (not (member (var-kind var) '(special global))) - (not (form-causes-side-effect form))) + (not (c1form-side-effects form))) (unless (var-ignorable var) (cmpdebug "Removing unused variable ~A" (var-name var))) (delete-c1forms form) @@ -210,7 +210,7 @@ ;; - e2 does not affect v1 nor e3, e3 does not affect e2 ;; - e4 does not affect e2 (when (and (= 1 (var-ref var)) - (not (form-causes-side-effect form)) + (not (c1form-side-effects form)) ;; it does not refer to special variables which ;; are changed in the LET form (notany #'(lambda (v) (var-referenced-in-form v form)) rest-vars) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index 40ca8d8de..7347ab4f3 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -37,7 +37,7 @@ (last-form (car (last args)))) (VAR (c1form-arg 0 x)) (t x)))) - (and (not (form-causes-side-effect form)) + (and (not (c1form-side-effects form)) (or (< (var-ref var) 1) (and (= (var-ref var) 1) (eq var (last-form body)) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 2465fdff5..6bd8dfee3 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -26,7 +26,6 @@ "src:cmp;cmpform.lsp" "src:cmp;cmpvar.lsp" "src:cmp;cmpfun.lsp" - "src:cmp;cmpinline.lsp" ;; Types "src:cmp;cmptype-prop.lsp" "src:cmp;cmptype.lsp" @@ -50,7 +49,9 @@ "src:cmp;cmpbackend-cxx;cmpc-mach.lsp" "src:cmp;cmpbackend-cxx;cmpc-wt.lsp" "src:cmp;cmpbackend-cxx;cmpc-inliner.lsp" + "src:cmp;cmpbackend-cxx;cmpc-opt-inl.lsp" "src:cmp;cmpbackend-cxx;cmpc-opt-num.lsp" + "src:cmp;cmpbackend-cxx;cmpc-opt-ct.lsp" ;; Code generation pass "src:cmp;cmpbackend-cxx;cmppass2-data.lsp" "src:cmp;cmpbackend-cxx;cmppass2-top.lsp" @@ -66,7 +67,6 @@ "src:cmp;cmpbackend-cxx;cmppass2-ffi.lsp" "src:cmp;cmpbackend-cxx;cmpbackend-cxx.lsp" ;; Optimizations - "src:cmp;cmpct.lsp" "src:cmp;cmpmap.lsp" "src:cmp;cmpname.lsp" "src:cmp;cmpopt.lsp" From ae6614ebba54b9fadc09633a84f77e3b14b11f3e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Jun 2023 11:49:02 +0200 Subject: [PATCH 17/23] cmpc: move variables related to code generation to the backend --- src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp | 38 +++--- src/cmp/cmpbackend-cxx/cmpc-util.lsp | 140 ++++++++++++++++++++++ src/cmp/cmpglobals.lsp | 69 ----------- src/cmp/cmputil.lsp | 74 ------------ src/cmp/load.lsp.in | 2 +- 5 files changed, 160 insertions(+), 163 deletions(-) create mode 100644 src/cmp/cmpbackend-cxx/cmpc-util.lsp diff --git a/src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp b/src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp index 2cea0f2b1..778cb59fe 100644 --- a/src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp +++ b/src/cmp/cmpbackend-cxx/cmpbackend-cxx.lsp @@ -531,27 +531,27 @@ WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdS ;;; Code generation (defun compiler-pass/generate-cxx (c-pathname h-pathname data-pathname init-name source) - - (setq *compiler-phase* 't2) - (with-open-file (*compiler-output1* c-pathname :direction :output - :if-does-not-exist :create - :if-exists :supersede) - (wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version)) - #-ecl-min - (multiple-value-bind (second minute hour day month year) - (get-decoded-time) - (declare (ignore second)) - (wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute) - (wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type))) - (wt-comment-nl "Source: ~A" source) - (with-open-file (*compiler-output2* h-pathname :direction :output + (with-cxx-env () + (setq *compiler-phase* 't2) + (with-open-file (*compiler-output1* c-pathname :direction :output :if-does-not-exist :create :if-exists :supersede) - (wt-nl1 "#include " *cmpinclude*) - (ctop-write init-name h-pathname data-pathname) - (terpri *compiler-output1*) - (terpri *compiler-output2*))) - (data-c-dump data-pathname)) + (wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version)) + #-ecl-min + (multiple-value-bind (second minute hour day month year) + (get-decoded-time) + (declare (ignore second)) + (wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute) + (wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type))) + (wt-comment-nl "Source: ~A" source) + (with-open-file (*compiler-output2* h-pathname :direction :output + :if-does-not-exist :create + :if-exists :supersede) + (wt-nl1 "#include " *cmpinclude*) + (ctop-write init-name h-pathname data-pathname) + (terpri *compiler-output1*) + (terpri *compiler-output2*))) + (data-c-dump data-pathname))) (defun compiler-pass/assemble-cxx (input-file output-file &key diff --git a/src/cmp/cmpbackend-cxx/cmpc-util.lsp b/src/cmp/cmpbackend-cxx/cmpc-util.lsp new file mode 100644 index 000000000..fdfe63f1b --- /dev/null +++ b/src/cmp/cmpbackend-cxx/cmpc-util.lsp @@ -0,0 +1,140 @@ + +;;; Global variables, flag definitions and utilities. + +(in-package "COMPILER") + +;;; *inline-blocks* holds the number of C blocks opened for declaring temps for +;;; intermediate results of the evaluation of inlined function calls. + +(defvar *inline-blocks* 0) +(defvar *opened-c-braces* 0) + +(defvar *emitted-local-funs* nil) + +;;; Compiled code uses the following kinds of variables: +;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl) +;;; 2. Ti, declared collectively, of type object, may be reused (*temp*, next-temp) +;;; 4. lexi[j], for lexical variables in local functions +;;; 5. CLVi, for lexical variables in closures + +(defvar *lcl* 0) ; number of local variables + +(defvar *temp* 0) ; number of temporary variables +(defvar *max-temp* 0) ; maximum *temp* reached + +(defvar *level* 0) ; nesting level for local functions + +(defvar *lex* 0) ; number of lexical variables in local functions +(defvar *max-lex* 0) ; maximum *lex* reached + +(defvar *env* 0) ; number of variables in current form +(defvar *max-env* 0) ; maximum *env* in whole function +(defvar *env-lvl* 0) ; number of levels of environments +(defvar *aux-closure* nil) ; stack allocated closure needed for indirect calls +(defvar *ihs-used-p* nil) ; function must be registered in IHS? + +(defvar *next-cfun* 0) ; holds the last cfun used. + +;;; *tail-recursion-info* holds NIL, if tail recursion is impossible. +;;; If possible, *tail-recursion-info* holds +;;; ( c1-lambda-form required-arg .... required-arg ), +;;; where each required-arg is a var-object. +(defvar *tail-recursion-info* nil) + +;;; --cmpexit.lsp-- +;;; +;;; *last-label* holds the label# of the last used label. +;;; *exit* holds an 'exit', which is +;; ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM, +;; RETURN-CHARACTER, RETURN-LONG-FLOAT, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT, +;; RETURN-CSFLOAT, RETURN-CDFLOAT, RETURN-CLFLOAT or RETURN-OBJECT). +;;; *unwind-exit* holds a list consisting of: +;; ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME, +;; JUMP, BDS-BIND (each pushed for a single special binding), or a +;; LCL (which holds the bind stack pointer used to unbind). +;;; +(defvar *last-label* 0) +(defvar *exit*) +(defvar *unwind-exit*) + +;;; ---------------------------------------------------------------------- +;;; CONVENIENCE FUNCTIONS / MACROS +;;; + +(defmacro with-cxx-env (() &body body) + `(let ((*inline-blocks* 0) + (*open-c-braces* 0) + (*temp* 0) + (*max-temp* 0) + (*next-cfun* 0) + (*last-label* 0)) + ,@body)) + +(defun-cached env-var-name (n) eql + (format nil "env~D" n)) + +(defun-cached lex-env-var-name (n) eql + (format nil "lex~D" n)) + +(defun next-lcl (&optional name) + (list 'LCL (incf *lcl*) T + (if (and name (symbol-package name)) + (lisp-to-c-name name) + ""))) + +(defun next-temp () + (prog1 *temp* + (incf *temp*) + (setq *max-temp* (max *temp* *max-temp*)))) + +(defun next-lex () + (prog1 (cons *level* *lex*) + (incf *lex*) + (setq *max-lex* (max *lex* *max-lex*)))) + +(defun next-env () + (prog1 *env* + (incf *env*) + (setq *max-env* (max *env* *max-env*)))) + +(defun env-grows (possibily) + ;; if additional closure variables are introduced and this is not + ;; last form, we must use a new env. + (and possibily + (plusp *env*) + (dolist (exit *unwind-exit*) + (case exit + (RETURN (return NIL)) + (BDS-BIND) + (t (return T)))))) + +(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil)) + (let ((code (incf *next-cfun*))) + (format nil prefix code (lisp-to-c-name lisp-name)))) + +(defun next-label () + (cons (incf *last-label*) nil)) + +(defun next-label* () + (cons (incf *last-label*) t)) + +(defun labelp (x) + (and (consp x) (integerp (si:cons-car x)))) + +(defun maybe-next-label () + (if (labelp *exit*) + *exit* + (next-label))) + +(defmacro with-exit-label ((label) &body body) + `(let* ((,label (next-label)) + (*unwind-exit* (cons ,label *unwind-exit*))) + ,@body + (wt-label ,label))) + +(defmacro with-optional-exit-label ((label) &body body) + `(let* ((,label (maybe-next-label)) + (*unwind-exit* (adjoin ,label *unwind-exit*))) + ,@body + (unless (eq ,label *exit*) + (wt-label ,label)))) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index a3eb614e9..98078ea82 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -20,24 +20,10 @@ ;;; VARIABLES ;;; -;;; --cmpinline.lsp-- -;;; -;;; Empty info struct -;;; -;; (defvar *info* (make-info)) ;unused - -(defvar *inline-blocks* 0) -(defvar *opened-c-braces* 0) -;;; *inline-blocks* holds the number of C blocks opened for declaring -;;; temporaries for intermediate results of the evaluation of inlined -;;; function calls. - (defvar *inline-max-depth* 3 "Depth at which inlining of functions stops.") (defvar *inline-information* nil) -(defvar *emitted-local-funs* nil) - ;;; --cmputil.lsp-- ;;; ;;; Variables and constants for error handling @@ -100,55 +86,6 @@ running the compiler. It may be updated by running ") (defvar *debug* 0) (defvar *compilation-speed* 2) -;;; -;;; Compiled code uses the following kinds of variables: -;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl) -;;; 2. Ti, declared collectively, of type object, may be reused (*temp*, next-temp) -;;; 4. lexi[j], for lexical variables in local functions -;;; 5. CLVi, for lexical variables in closures - -(defvar *lcl* 0) ; number of local variables - -(defvar *temp* 0) ; number of temporary variables -(defvar *max-temp* 0) ; maximum *temp* reached - -(defvar *level* 0) ; nesting level for local functions - -(defvar *lex* 0) ; number of lexical variables in local functions -(defvar *max-lex* 0) ; maximum *lex* reached - -(defvar *env* 0) ; number of variables in current form -(defvar *max-env* 0) ; maximum *env* in whole function -(defvar *env-lvl* 0) ; number of levels of environments -(defvar *aux-closure* nil) ; stack allocated closure needed for indirect calls -(defvar *ihs-used-p* nil) ; function must be registered in IHS? - -(defvar *next-cfun* 0) ; holds the last cfun used. - -;;; -;;; *tail-recursion-info* holds NIL, if tail recursion is impossible. -;;; If possible, *tail-recursion-info* holds -;; ( c1-lambda-form required-arg .... required-arg ), -;;; where each required-arg is a var-object. -;;; -(defvar *tail-recursion-info* nil) - -;;; --cmpexit.lsp-- -;;; -;;; *last-label* holds the label# of the last used label. -;;; *exit* holds an 'exit', which is -;; ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM, -;; RETURN-CHARACTER, RETURN-LONG-FLOAT, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT, -;; RETURN-CSFLOAT, RETURN-CDFLOAT, RETURN-CLFLOAT or RETURN-OBJECT). -;;; *unwind-exit* holds a list consisting of: -;; ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME, -;; JUMP, BDS-BIND (each pushed for a single special binding), or a -;; LCL (which holds the bind stack pointer used to unbind). -;;; -(defvar *last-label* 0) -(defvar *exit*) -(defvar *unwind-exit*) - (defvar *current-function* nil) (defvar *cmp-env* nil @@ -313,10 +250,6 @@ be deleted if they have been opened with LoadLibrary.") (*callbacks* nil) (*cmp-env-root* (copy-tree *cmp-env-root*)) (*cmp-env* nil) - (*max-temp* 0) - (*temp* 0) - (*next-cfun* 0) - (*last-label* 0) (*load-objects* (make-hash-table :size 128 :test #'equal)) (*setf-definitions* nil) (*make-forms* nil) @@ -331,8 +264,6 @@ be deleted if they have been opened with LoadLibrary.") (*top-level-forms* nil) (*compile-time-too* nil) (*clines-string-list* '()) - (*inline-blocks* 0) - (*open-c-braces* 0) (si::*defun-inline-hook* 'maybe-install-inline-function) (*machine* (or *machine* *default-machine*)) (*optimizable-constants* (make-optimizable-constants *machine*)) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 02d3fc2bd..0d1e19050 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -478,79 +478,5 @@ comparing circular objects." (defmacro defun-equal-cached (name lambda-list &body body) `(defun-cached ,name ,lambda-list equal-with-circularity ,@body)) -;;; ---------------------------------------------------------------------- -;;; CONVENIENCE FUNCTIONS / MACROS -;;; - -(defun-cached env-var-name (n) eql - (format nil "env~D" n)) - -(defun-cached lex-env-var-name (n) eql - (format nil "lex~D" n)) - (defun same-fname-p (name1 name2) (equal name1 name2)) - -;;; from cmplabel.lsp -(defun next-label () - (cons (incf *last-label*) nil)) - -(defun next-label* () - (cons (incf *last-label*) t)) - -(defun labelp (x) - (and (consp x) (integerp (si:cons-car x)))) - -(defun maybe-next-label () - (if (labelp *exit*) - *exit* - (next-label))) - -(defmacro with-exit-label ((label) &body body) - `(let* ((,label (next-label)) - (*unwind-exit* (cons ,label *unwind-exit*))) - ,@body - (wt-label ,label))) - -(defmacro with-optional-exit-label ((label) &body body) - `(let* ((,label (maybe-next-label)) - (*unwind-exit* (adjoin ,label *unwind-exit*))) - ,@body - (unless (eq ,label *exit*) - (wt-label ,label)))) - -(defun next-lcl (&optional name) - (list 'LCL (incf *lcl*) T - (if (and name (symbol-package name)) - (lisp-to-c-name name) - ""))) - -(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil)) - (let ((code (incf *next-cfun*))) - (format nil prefix code (lisp-to-c-name lisp-name)))) - -(defun next-temp () - (prog1 *temp* - (incf *temp*) - (setq *max-temp* (max *temp* *max-temp*)))) - -(defun next-lex () - (prog1 (cons *level* *lex*) - (incf *lex*) - (setq *max-lex* (max *lex* *max-lex*)))) - -(defun next-env () - (prog1 *env* - (incf *env*) - (setq *max-env* (max *env* *max-env*)))) - -(defun env-grows (possibily) - ;; if additional closure variables are introduced and this is not - ;; last form, we must use a new env. - (and possibily - (plusp *env*) - (dolist (exit *unwind-exit*) - (case exit - (RETURN (return NIL)) - (BDS-BIND) - (t (return T)))))) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 6bd8dfee3..5e0a8f96f 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -45,7 +45,7 @@ "src:cmp;cmpprop.lsp" "src:cmp;cmpprop-num.lsp" ;; C/C++ backend - ;; Abstract C machine + "src:cmp;cmpbackend-cxx;cmpc-util.lsp" "src:cmp;cmpbackend-cxx;cmpc-mach.lsp" "src:cmp;cmpbackend-cxx;cmpc-wt.lsp" "src:cmp;cmpbackend-cxx;cmpc-inliner.lsp" From ff67ebfa1a5cc9bccd9705265ac810ff56cba54f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Jun 2023 13:38:00 +0200 Subject: [PATCH 18/23] cmpc: move wt "call" routines to cmpc-wt --- src/cmp/cmpbackend-cxx/cmpc-mach.lsp | 24 ++ src/cmp/cmpbackend-cxx/cmppass2-call.lsp | 57 +--- src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp | 203 ------------ src/cmp/cmpbackend-cxx/cmppass2-loc.lsp | 337 +++++++++++++++++++- src/cmp/cmpbackend-cxx/cmppass2-special.lsp | 77 +---- 5 files changed, 354 insertions(+), 344 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-mach.lsp b/src/cmp/cmpbackend-cxx/cmpc-mach.lsp index b79c57bc4..b55ba45b2 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-mach.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-mach.lsp @@ -62,6 +62,30 @@ (when (subtypep type (rep-type-lisp-type record)) (return-from lisp-type->rep-type (rep-type-name record))))))) +(defun c-number-rep-type-p (rep-type) + (let ((r (rep-type-record-unsafe rep-type))) + (and r (rep-type-numberp r)))) + +(defun c-integer-rep-type-p (rep-type) + (let ((r (rep-type-record-unsafe rep-type))) + (and r (rep-type-integerp r)))) + +(defun c-integer-rep-type-bits (rep-type) + (let ((r (rep-type-record-unsafe rep-type))) + (and r (rep-type-bits r)))) + +(defun c-number-type-p (type) + (c-number-rep-type-p (lisp-type->rep-type type))) + +(defun c-integer-type-p (type) + (c-integer-rep-type-p (lisp-type->rep-type type))) + +(defun c-integer-type-bits (type) + (c-number-rep-type-bits (lisp-type->rep-type type))) + +(defun rep-type->c-name (type) + (rep-type-c-name (rep-type-record type))) + ;; These types can be used by ECL to unbox data They are sorted from ;; the most specific, to the least specific one. All functions must ;; be declared in external.h (not internal.h) header file. diff --git a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp index 34b4cd8a4..5bed4952f 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp @@ -72,7 +72,8 @@ (defun tail-recursion-possible () (dolist (ue *unwind-exit* (baboon :format-control "tail-recursion-possible: should never return.")) - (cond ((eq ue 'TAIL-RECURSION-MARK) (return t)) + (cond ((eq ue 'TAIL-RECURSION-MARK) + (return t)) ((or (numberp ue) (eq ue 'BDS-BIND) (eq ue 'FRAME)) (return nil)) ((or (consp ue) (eq ue 'JUMP) (eq ue 'IHS-ENV))) @@ -230,58 +231,4 @@ function-p t))) `(CALL-INDIRECT ,loc ,(coerce-locs args) ,fname ,function-p)) - -;;; wt routines -(defun wt-call (fun args &optional fname env) - (if env - (progn - (setf *aux-closure* t) - (wt "(aux_closure.env="env",cl_env_copy->function=(cl_object)&aux_closure,") - (wt-call fun args) - (wt ")")) - (progn - (wt fun "(") - (let ((comma "")) - (dolist (arg args) - (wt comma arg) - (setf comma ", "))) - (wt ")"))) - (when fname (wt-comment fname))) - -(defun wt-call-indirect (fun-loc args fname function-p) - (let ((narg (length args))) - (if function-p - (wt "(cl_env_copy->function=" fun-loc ")->cfun.entry(" narg) - (wt "ecl_function_dispatch(cl_env_copy," fun-loc ")(" narg)) - (dolist (arg args) - (wt ", " arg)) - (wt ")") - (when fname (wt-comment fname)))) - -(defun wt-call-normal (fun args type) - (declare (ignore type)) - (unless (fun-cfun fun) - (baboon "Function without a C name: ~A" (fun-name fun))) - (let* ((minarg (fun-minarg fun)) - (maxarg (fun-maxarg fun)) - (fun-c-name (fun-cfun fun)) - (fun-lisp-name (fun-name fun)) - (narg (length args)) - (env nil)) - (case (fun-closure fun) - (CLOSURE - (when (plusp *max-env*) - (setf env (environment-accessor fun)))) - (LEXICAL - (let ((lex-lvl (fun-level fun))) - (dotimes (n lex-lvl) - (let* ((j (- lex-lvl n 1)) - (x (lex-env-var-name j))) - (push x args)))))) - (unless (<= minarg narg maxarg) - (cmperr "Wrong number of arguments for function ~S" - (or fun-lisp-name 'ANONYMOUS))) - (when (fun-needs-narg fun) - (push narg args)) - (wt-call fun-c-name args nil env))) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp b/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp index bc36c7140..555f155a8 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp @@ -15,170 +15,6 @@ (in-package "COMPILER") -(defun c-number-rep-type-p (rep-type) - (let ((r (rep-type-record-unsafe rep-type))) - (and r (rep-type-numberp r)))) - -(defun c-integer-rep-type-p (rep-type) - (let ((r (rep-type-record-unsafe rep-type))) - (and r (rep-type-integerp r)))) - -(defun c-integer-rep-type-bits (rep-type) - (let ((r (rep-type-record-unsafe rep-type))) - (and r (rep-type-bits r)))) - -(defun c-number-type-p (type) - (c-number-rep-type-p (lisp-type->rep-type type))) - -(defun c-integer-type-p (type) - (c-integer-rep-type-p (lisp-type->rep-type type))) - -(defun c-integer-type-bits (type) - (c-number-rep-type-bits (lisp-type->rep-type type))) - -(defun rep-type->c-name (type) - (rep-type-c-name (rep-type-record type))) - -(defun wt-to-object-conversion (loc-rep-type loc) - (when (and (consp loc) (member (first loc) - '(single-float-value - double-float-value - long-float-value - csfloat-value - cdfloat-value - clfloat-value))) - (wt (third loc)) ;; VV index - (return-from wt-to-object-conversion)) - (let ((record (rep-type-record loc-rep-type))) - (unless record - (cmperr "Cannot coerce C variable of type ~A to lisp object" loc-rep-type)) - (wt (rep-type-to-lisp record) "(" loc ")"))) - -(defun wt-from-object-conversion (dest-type loc-type rep-type loc) - (let* ((record (rep-type-record rep-type)) - (coercer (and record (rep-type-from-lisp record)))) - (unless coercer - (cmperr "Cannot coerce lisp object to C type ~A" rep-type)) - (wt (if (or (policy-assume-no-errors) - (subtypep loc-type dest-type)) - (rep-type-from-lisp-unsafe record) - coercer) - "(" loc ")"))) - -(defun wt-coerce-loc (dest-rep-type loc) - (setq dest-rep-type (lisp-type->rep-type dest-rep-type)) - ;(print dest-rep-type) - ;(print loc) - (let* ((dest-type (rep-type->lisp-type dest-rep-type)) - (loc-type (loc-type loc)) - (loc-rep-type (loc-representation-type loc))) - (labels ((coercion-error () - (cmpwarn "Unable to coerce lisp object from type (~S,~S)~%~ - to C/C++ type (~S,~S)" - loc-type loc-rep-type dest-type dest-rep-type)) - (ensure-valid-object-type (a-lisp-type) - (when (subtypep `(AND ,loc-type ,a-lisp-type) NIL) - (coercion-error)))) - (when (eq dest-rep-type loc-rep-type) - (wt loc) - (return-from wt-coerce-loc)) - (case dest-rep-type - ((:char :unsigned-char :wchar) - (case loc-rep-type - ((:char :unsigned-char :wchar) - (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")")) - ((:object) - (ensure-valid-object-type dest-type) - (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) - (otherwise - (coercion-error)))) - ((:float :double :long-double) - (cond - ((c-number-rep-type-p loc-rep-type) - (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")")) - ((eq loc-rep-type :object) - ;; We relax the check a bit, because it is valid in C to coerce - ;; between floats of different types. - (ensure-valid-object-type 'FLOAT) - (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) - (t - (coercion-error)))) - ((:csfloat :cdfloat :clfloat) - (cond - ((c-number-rep-type-p loc-rep-type) - (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")")) - ((eq loc-rep-type :object) - ;; We relax the check a bit, because it is valid in C to coerce - ;; between COMPLEX floats of different types. - (ensure-valid-object-type 'SI:COMPLEX-FLOAT) - (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) - (t - (coercion-error)))) - ((:bool) - (cond - ((c-number-rep-type-p loc-rep-type) - (wt "1")) - ((eq loc-rep-type :object) - (wt "(" loc ")!=ECL_NIL")) - (t - (coercion-error)))) - ((:object) - (case loc-rep-type - ((:int-sse-pack :float-sse-pack :double-sse-pack) - (when (>= (cmp-env-optimization 'speed) 1) - (cmpwarn-style "Boxing a value of type ~S - performance degraded." - loc-rep-type)))) - (wt-to-object-conversion loc-rep-type loc)) - ((:pointer-void) - (case loc-rep-type - ((:object) - (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) - ((:cstring) - (wt "(char *)(" loc ")")) - (otherwise - (coercion-error)))) - ((:cstring) - (coercion-error)) - ((:char*) - (case loc-rep-type - ((:object) - (wt "ecl_base_string_pointer_safe(" loc ")")) - ((:pointer-void) - (wt "(char *)(" loc ")")) - (otherwise - (coercion-error)))) - ((:int-sse-pack :float-sse-pack :double-sse-pack) - (case loc-rep-type - ((:object) - (wt-from-object-conversion 'ext:sse-pack loc-type dest-rep-type loc)) - ;; Implicitly cast between SSE subtypes - ((:int-sse-pack :float-sse-pack :double-sse-pack) - (wt (ecase dest-rep-type - (:int-sse-pack (ecase loc-rep-type - (:float-sse-pack "_mm_castps_si128") - (:double-sse-pack "_mm_castpd_si128"))) - (:float-sse-pack (ecase loc-rep-type - (:int-sse-pack "_mm_castsi128_ps") - (:double-sse-pack "_mm_castpd_ps"))) - (:double-sse-pack (ecase loc-rep-type - (:int-sse-pack "_mm_castsi128_pd") - (:float-sse-pack "_mm_castps_pd")))) - "(" loc ")")) - (otherwise - (coercion-error)))) - (t - ;; At this point we only have coercions to integers - (cond - ((not (c-integer-rep-type-p dest-rep-type)) - (coercion-error)) - ((c-number-rep-type-p loc-rep-type) - (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")")) - ((eq :object loc-rep-type) - (ensure-valid-object-type dest-type) - (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) - (t - (coercion-error)))))))) - ;;; ---------------------------------------------------------------------- ;;; C/C++ DECLARATIONS AND HEADERS ;;; @@ -341,45 +177,6 @@ (t `(COERCE-LOC ,rep-type ,loc))))) -(defun wt-c-inline-loc (output-rep-type c-expression coerced-arguments side-effects output-vars) - (declare (ignore output-rep-type side-effects)) - (with-input-from-string (s c-expression) - (when (and output-vars (not (eq output-vars 'VALUES))) - (wt-nl)) - (do ((c (read-char s nil nil) - (read-char s nil nil))) - ((null c)) - (case c - (#\@ - (let ((object (read s))) - (cond ((and (consp object) (equal (first object) 'RETURN)) - (if (eq output-vars 'VALUES) - (cmperr "User @(RETURN ...) in a C-INLINE form with no output values") - (let ((ndx (or (second object) 0)) - (l (length output-vars))) - (if (< ndx l) - (wt (nth ndx output-vars)) - (cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values" - ndx l))))) - (t - (when (and (consp object) (eq (first object) 'QUOTE)) - (setq object (second object))) - (wt (add-object object :permanent t)))))) - (#\# - (let* ((k (read-char s)) - (next-char (peek-char nil s nil nil)) - (index (digit-char-p k 36))) - (cond ((eq k #\#) - (wt #\#)) - ((or (null index) (and next-char (alphanumericp next-char))) - (wt #\# k)) - ((< index (length coerced-arguments)) - (wt (nth index coerced-arguments))) - (t - (cmperr "C-INLINE: Variable code exceeds number of arguments"))))) - (otherwise - (write-char c *compiler-output1*)))))) - (defun c-inline-safe-string (constant-string) ;; Produce a text representation of a string that can be used ;; in a C-INLINE form, without triggering the @ or # escape diff --git a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp index 14525bc63..f1d371eec 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp @@ -5,17 +5,18 @@ ;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. ;;;; Copyright (c) 1990, Giuseppe Attardi. ;;;; -;;;; This program is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. +;;;; See the file 'LICENSE' for the copyright details. ;;;; -;;;; See file '../Copyright' for full details. -;;;; CMPLOC Set-loc and Wt-loc. +;;;; Set-loc and Wt-loc. (in-package "COMPILER") + +;;; +;;; Mundane locs +;;; + (defun wt-loc (loc) (cond ((consp loc) (let ((fd (gethash (car loc) *wt-loc-dispatch-table*))) @@ -37,8 +38,9 @@ (unknown-location 'wt-loc loc)))) (defun wt-lcl (lcl) - (unless (numberp lcl) (baboon :format-control "wt-lcl: ~s NaN" - :format-arguments (list lcl))) + (unless (numberp lcl) + (baboon :format-control "wt-lcl: ~s NaN" + :format-arguments (list lcl))) (wt "v" lcl)) (defun wt-lcl-loc (lcl &optional type name) @@ -79,14 +81,326 @@ ;; 'char' which have sign problems (wt value)) -(defun wt-value (i) (wt "cl_env_copy->values[" i "]")) +(defun wt-value (i) + (wt "cl_env_copy->values[" i "]")) -(defun wt-keyvars (i) (wt "keyvars[" i "]")) +(defun wt-keyvars (i) + (wt "keyvars[" i "]")) (defun wt-the (type loc) (declare (ignore type)) (wt-loc loc)) + +;;; +;;; CALL-LOC +;;; + +(defun wt-call (fun args &optional fname env) + (if env + (progn + (setf *aux-closure* t) + (wt "(aux_closure.env="env",cl_env_copy->function=(cl_object)&aux_closure,") + (wt-call fun args) + (wt ")")) + (progn + (wt fun "(") + (let ((comma "")) + (dolist (arg args) + (wt comma arg) + (setf comma ", "))) + (wt ")"))) + (when fname (wt-comment fname))) + +(defun wt-call-indirect (fun-loc args fname function-p) + (let ((narg (length args))) + (if function-p + (wt "(cl_env_copy->function=" fun-loc ")->cfun.entry(" narg) + (wt "ecl_function_dispatch(cl_env_copy," fun-loc ")(" narg)) + (dolist (arg args) + (wt ", " arg)) + (wt ")") + (when fname (wt-comment fname)))) + +(defun wt-call-normal (fun args type) + (declare (ignore type)) + (unless (fun-cfun fun) + (baboon "Function without a C name: ~A" (fun-name fun))) + (let* ((minarg (fun-minarg fun)) + (maxarg (fun-maxarg fun)) + (fun-c-name (fun-cfun fun)) + (fun-lisp-name (fun-name fun)) + (narg (length args)) + (env nil)) + (case (fun-closure fun) + (CLOSURE + (when (plusp *max-env*) + (setf env (environment-accessor fun)))) + (LEXICAL + (let ((lex-lvl (fun-level fun))) + (dotimes (n lex-lvl) + (let* ((j (- lex-lvl n 1)) + (x (lex-env-var-name j))) + (push x args)))))) + (unless (<= minarg narg maxarg) + (cmperr "Wrong number of arguments for function ~S" + (or fun-lisp-name 'ANONYMOUS))) + (when (fun-needs-narg fun) + (push narg args)) + (wt-call fun-c-name args nil env))) + + +;;; +;;; FDEFINITION, MAKE-CLOSURE +;;; +(defun wt-fdefinition (fun-name) + (let* ((name (si::function-block-name fun-name)) + (package (symbol-package name)) + (safe (or (not (safe-compile)) + (and (or (eq package (find-package "CL")) + (eq package (find-package "CLOS")) + (eq package (find-package "SI"))) + (fboundp fun-name) + (functionp (fdefinition fun-name)))))) + (if (eq name fun-name) + ;; #'symbol + (let ((vv (add-symbol name))) + (if safe + (wt "(" vv "->symbol.gfdef)") + (wt "ecl_fdefinition(" vv ")"))) + ;; #'(SETF symbol) + (if safe + #+(or) + (let ((set-loc (assoc name *setf-definitions*))) + (unless set-loc + (let* ((setf-vv (data-empty-loc)) + (name-vv (add-symbol name)) + (setf-form-vv (add-object fun-name))) + (setf set-loc (list name setf-vv name-vv setf-form-vv)) + (push set-loc *setf-definitions*))) + (wt "ECL_SETF_DEFINITION(" (second set-loc) "," (fourth set-loc) ")")) + (let ((set-loc (assoc name *setf-definitions*))) + (unless set-loc + (let* ((setf-vv (data-empty-loc)) + (name-vv (add-symbol name))) + (setf set-loc (list name setf-vv name-vv)) + (push set-loc *setf-definitions*))) + (wt "ECL_CONS_CAR(" (second set-loc) ")")) + (let ((vv (add-symbol fun-name))) + (wt "ecl_fdefinition(" vv ")")))))) + +(defun environment-accessor (fun) + (let* ((env-var (env-var-name *env-lvl*)) + (expected-env-size (fun-env fun))) + (if (< expected-env-size *env*) + (format nil "ecl_nthcdr(~D,~A)" (- *env* expected-env-size) env-var) + env-var))) + +(defun wt-make-closure (fun &aux (cfun (fun-cfun fun))) + (declare (type fun fun)) + (let* ((closure (fun-closure fun)) + narg) + (cond ((eq closure 'CLOSURE) + (wt "ecl_make_cclosure_va((cl_objectfn)" cfun "," + (environment-accessor fun) + ",Cblock," (min (fun-minarg fun) si:c-arguments-limit) ")")) + ((eq closure 'LEXICAL) + (baboon :format-control "wt-make-closure: lexical closure detected.")) + ((setf narg (fun-fixed-narg fun)) ; empty environment fixed number of args + (wt "ecl_make_cfun((cl_objectfn_fixed)" cfun ",ECL_NIL,Cblock," narg ")")) + (t ; empty environment variable number of args + (wt "ecl_make_cfun_va((cl_objectfn)" cfun ",ECL_NIL,Cblock," + (min (fun-minarg fun) si:c-arguments-limit) ")"))))) + +;;; +;;; COERCE-LOC +;;; + +(defun wt-to-object-conversion (loc-rep-type loc) + (when (and (consp loc) (member (first loc) + '(single-float-value + double-float-value + long-float-value + csfloat-value + cdfloat-value + clfloat-value))) + (wt (third loc)) ;; VV index + (return-from wt-to-object-conversion)) + (let ((record (rep-type-record loc-rep-type))) + (unless record + (cmperr "Cannot coerce C variable of type ~A to lisp object" loc-rep-type)) + (wt (rep-type-to-lisp record) "(" loc ")"))) + +(defun wt-from-object-conversion (dest-type loc-type rep-type loc) + (let* ((record (rep-type-record rep-type)) + (coercer (and record (rep-type-from-lisp record)))) + (unless coercer + (cmperr "Cannot coerce lisp object to C type ~A" rep-type)) + (wt (if (or (policy-assume-no-errors) + (subtypep loc-type dest-type)) + (rep-type-from-lisp-unsafe record) + coercer) + "(" loc ")"))) + +(defun wt-coerce-loc (dest-rep-type loc) + (setq dest-rep-type (lisp-type->rep-type dest-rep-type)) + ;(print dest-rep-type) + ;(print loc) + (let* ((dest-type (rep-type->lisp-type dest-rep-type)) + (loc-type (loc-type loc)) + (loc-rep-type (loc-representation-type loc))) + (labels ((coercion-error () + (cmpwarn "Unable to coerce lisp object from type (~S,~S)~%~ + to C/C++ type (~S,~S)" + loc-type loc-rep-type dest-type dest-rep-type)) + (ensure-valid-object-type (a-lisp-type) + (when (subtypep `(AND ,loc-type ,a-lisp-type) NIL) + (coercion-error)))) + (when (eq dest-rep-type loc-rep-type) + (wt loc) + (return-from wt-coerce-loc)) + (case dest-rep-type + ((:char :unsigned-char :wchar) + (case loc-rep-type + ((:char :unsigned-char :wchar) + (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")")) + ((:object) + (ensure-valid-object-type dest-type) + (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) + (otherwise + (coercion-error)))) + ((:float :double :long-double) + (cond + ((c-number-rep-type-p loc-rep-type) + (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")")) + ((eq loc-rep-type :object) + ;; We relax the check a bit, because it is valid in C to coerce + ;; between floats of different types. + (ensure-valid-object-type 'FLOAT) + (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) + (t + (coercion-error)))) + ((:csfloat :cdfloat :clfloat) + (cond + ((c-number-rep-type-p loc-rep-type) + (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")")) + ((eq loc-rep-type :object) + ;; We relax the check a bit, because it is valid in C to coerce + ;; between COMPLEX floats of different types. + (ensure-valid-object-type 'SI:COMPLEX-FLOAT) + (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) + (t + (coercion-error)))) + ((:bool) + (cond + ((c-number-rep-type-p loc-rep-type) + (wt "1")) + ((eq loc-rep-type :object) + (wt "(" loc ")!=ECL_NIL")) + (t + (coercion-error)))) + ((:object) + (case loc-rep-type + ((:int-sse-pack :float-sse-pack :double-sse-pack) + (when (>= (cmp-env-optimization 'speed) 1) + (cmpwarn-style "Boxing a value of type ~S - performance degraded." + loc-rep-type)))) + (wt-to-object-conversion loc-rep-type loc)) + ((:pointer-void) + (case loc-rep-type + ((:object) + (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) + ((:cstring) + (wt "(char *)(" loc ")")) + (otherwise + (coercion-error)))) + ((:cstring) + (coercion-error)) + ((:char*) + (case loc-rep-type + ((:object) + (wt "ecl_base_string_pointer_safe(" loc ")")) + ((:pointer-void) + (wt "(char *)(" loc ")")) + (otherwise + (coercion-error)))) + ((:int-sse-pack :float-sse-pack :double-sse-pack) + (case loc-rep-type + ((:object) + (wt-from-object-conversion 'ext:sse-pack loc-type dest-rep-type loc)) + ;; Implicitly cast between SSE subtypes + ((:int-sse-pack :float-sse-pack :double-sse-pack) + (wt (ecase dest-rep-type + (:int-sse-pack (ecase loc-rep-type + (:float-sse-pack "_mm_castps_si128") + (:double-sse-pack "_mm_castpd_si128"))) + (:float-sse-pack (ecase loc-rep-type + (:int-sse-pack "_mm_castsi128_ps") + (:double-sse-pack "_mm_castpd_ps"))) + (:double-sse-pack (ecase loc-rep-type + (:int-sse-pack "_mm_castsi128_pd") + (:float-sse-pack "_mm_castps_pd")))) + "(" loc ")")) + (otherwise + (coercion-error)))) + (t + ;; At this point we only have coercions to integers + (cond + ((not (c-integer-rep-type-p dest-rep-type)) + (coercion-error)) + ((c-number-rep-type-p loc-rep-type) + (wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")")) + ((eq :object loc-rep-type) + (ensure-valid-object-type dest-type) + (wt-from-object-conversion dest-type loc-type dest-rep-type loc)) + (t + (coercion-error)))))))) + + +;;; +;;; INLINE-LOC +;;; + +(defun wt-c-inline-loc (output-rep-type c-expression coerced-arguments side-effects output-vars) + (declare (ignore output-rep-type side-effects)) + (with-input-from-string (s c-expression) + (when (and output-vars (not (eq output-vars 'VALUES))) + (wt-nl)) + (do ((c (read-char s nil nil) + (read-char s nil nil))) + ((null c)) + (case c + (#\@ + (let ((object (read s))) + (cond ((and (consp object) (equal (first object) 'RETURN)) + (if (eq output-vars 'VALUES) + (cmperr "User @(RETURN ...) in a C-INLINE form with no output values") + (let ((ndx (or (second object) 0)) + (l (length output-vars))) + (if (< ndx l) + (wt (nth ndx output-vars)) + (cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values" + ndx l))))) + (t + (when (and (consp object) (eq (first object) 'QUOTE)) + (setq object (second object))) + (wt (add-object object :permanent t)))))) + (#\# + (let* ((k (read-char s)) + (next-char (peek-char nil s nil nil)) + (index (digit-char-p k 36))) + (cond ((eq k #\#) + (wt #\#)) + ((or (null index) (and next-char (alphanumericp next-char))) + (wt #\# k)) + ((< index (length coerced-arguments)) + (wt (nth index coerced-arguments))) + (t + (cmperr "C-INLINE: Variable code exceeds number of arguments"))))) + (otherwise + (write-char c *compiler-output1*)))))) + + ;;; ;;; SET-LOC ;;; @@ -113,7 +427,8 @@ (if fd (apply fd loc (rest destination)) (progn - (wt-nl) (wt-loc destination) (wt " = ") + (wt-nl) + (wt-loc destination) (wt " = ") (wt-coerce-loc (loc-representation-type *destination*) loc) (wt ";")))))))) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-special.lsp b/src/cmp/cmpbackend-cxx/cmppass2-special.lsp index 35f364375..d649804cb 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-special.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-special.lsp @@ -22,7 +22,7 @@ (declare (ignore c1form funob)) (case kind (GLOBAL - (unwind-exit (list 'FDEFINITION fun))) + (unwind-exit `(FDEFINITION ,fun))) (CLOSURE ;; XXX: we have some code after baboon – is CLOSURE legal or not? (baboon :format-control "c2function: c1form is of unexpected kind.") @@ -44,77 +44,4 @@ (fun-env fun) 0)) (otherwise (setf (fun-env fun) 0 (fun-level fun) 0))) - (let ((previous - nil - #+(or) - (dolist (old *local-funs*) - (when (similar fun old) - (return old))))) - (if previous - (progn - (if (eq (fun-closure fun) 'CLOSURE) - (cmpnote "Sharing code for closure") - (cmpnote "Sharing code for local function ~A" (fun-name fun))) - (setf (fun-cfun fun) (fun-cfun previous) - (fun-lambda fun) nil) - previous) - (push fun *local-funs*)))) - -(defun wt-fdefinition (fun-name) - (let* ((name (si::function-block-name fun-name)) - (package (symbol-package name)) - (safe (or (not (safe-compile)) - (and (or (eq package (find-package "CL")) - (eq package (find-package "CLOS")) - (eq package (find-package "SI"))) - (fboundp fun-name) - (functionp (fdefinition fun-name)))))) - (if (eq name fun-name) - ;; #'symbol - (let ((vv (add-symbol name))) - (if safe - (wt "(" vv "->symbol.gfdef)") - (wt "ecl_fdefinition(" vv ")"))) - ;; #'(SETF symbol) - (if safe - #+(or) - (let ((set-loc (assoc name *setf-definitions*))) - (unless set-loc - (let* ((setf-vv (data-empty-loc)) - (name-vv (add-symbol name)) - (setf-form-vv (add-object fun-name))) - (setf set-loc (list name setf-vv name-vv setf-form-vv)) - (push set-loc *setf-definitions*))) - (wt "ECL_SETF_DEFINITION(" (second set-loc) "," (fourth set-loc) ")")) - (let ((set-loc (assoc name *setf-definitions*))) - (unless set-loc - (let* ((setf-vv (data-empty-loc)) - (name-vv (add-symbol name))) - (setf set-loc (list name setf-vv name-vv)) - (push set-loc *setf-definitions*))) - (wt "ECL_CONS_CAR(" (second set-loc) ")")) - (let ((vv (add-symbol fun-name))) - (wt "ecl_fdefinition(" vv ")")))))) - -(defun environment-accessor (fun) - (let* ((env-var (env-var-name *env-lvl*)) - (expected-env-size (fun-env fun))) - (if (< expected-env-size *env*) - (format nil "ecl_nthcdr(~D,~A)" (- *env* expected-env-size) env-var) - env-var))) - -(defun wt-make-closure (fun &aux (cfun (fun-cfun fun))) - (declare (type fun fun)) - (let* ((closure (fun-closure fun)) - narg) - (cond ((eq closure 'CLOSURE) - (wt "ecl_make_cclosure_va((cl_objectfn)" cfun "," - (environment-accessor fun) - ",Cblock," (min (fun-minarg fun) si:c-arguments-limit) ")")) - ((eq closure 'LEXICAL) - (baboon :format-control "wt-make-closure: lexical closure detected.")) - ((setf narg (fun-fixed-narg fun)) ; empty environment fixed number of args - (wt "ecl_make_cfun((cl_objectfn_fixed)" cfun ",ECL_NIL,Cblock," narg ")")) - (t ; empty environment variable number of args - (wt "ecl_make_cfun_va((cl_objectfn)" cfun ",ECL_NIL,Cblock," - (min (fun-minarg fun) si:c-arguments-limit) ")"))))) + (push fun *local-funs*)) From c4b32c5905e0ae107834092f4b81995089d765fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Jun 2023 15:02:51 +0200 Subject: [PATCH 19/23] cmpc: move produce-inline-loc and co to cmpc-inliner These operators are used across different optimizations and clearly do not belong to a specific pass. --- src/cmp/cmpbackend-cxx/cmpc-inliner.lsp | 109 +++++++++++++++++++++++ src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp | 110 ------------------------ 2 files changed, 109 insertions(+), 110 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp b/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp index a507a4d23..c08286b31 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp @@ -185,3 +185,112 @@ (nreverse rts)) inline-info)))) +(defun c-inline-safe-string (constant-string) + ;; Produce a text representation of a string that can be used + ;; in a C-INLINE form, without triggering the @ or # escape + ;; characters + (c-filtered-string + (concatenate 'string + (loop for c across constant-string + when (member c '(#\# #\@)) + collect c + collect c)))) + +(defun produce-inline-loc (inlined-arguments arg-types output-rep-type + c-expression side-effects one-liner) + (let* (args-to-be-saved + coerced-arguments) + ;; If the expression begins with @[0-9a-z]*, this means we are + ;; saving some variables. + (when (and (> (length c-expression) 1) + (eq (char c-expression 0) #\@)) + (do ((ndx 1 (1+ ndx))) + ((>= ndx (length c-expression))) + (let ((c (char c-expression ndx))) + (when (eq c #\;) + (setf c-expression (subseq c-expression (1+ ndx))) + (return)) + (unless (alphanumericp c) + (setf args-to-be-saved nil) + (return)) + (push (- (char-code c) (char-code #\0)) + args-to-be-saved)))) + + (setf coerced-arguments (coerce-locs inlined-arguments arg-types args-to-be-saved)) + ;;(setf output-rep-type (lisp-type->rep-type output-rep-type)) + + ;; If the form does not output any data, and there are no side + ;; effects, try to omit it. + (when (null output-rep-type) + (if side-effects + (progn + (wt-nl) + (wt-c-inline-loc output-rep-type c-expression coerced-arguments t nil) + (when one-liner (wt ";"))) + (cmpnote "Ignoring form ~S" c-expression)) + (wt-nl "value0 = ECL_NIL;") + (wt-nl "cl_env_copy->nvalues = 0;") + (return-from produce-inline-loc 'RETURN)) + + ;; If the form is a one-liner, we can simply propagate this expression until the + ;; place where the value is used. + (when one-liner + (return-from produce-inline-loc + `(ffi:c-inline ,output-rep-type ,c-expression ,coerced-arguments ,side-effects + ,(if (equalp output-rep-type '((VALUES &REST T))) + 'VALUES NIL)))) + + ;; If the output is a in the VALUES vector, just write down the form and output + ;; the location of the data. + (when (equalp output-rep-type '((VALUES &REST T))) + (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects + 'VALUES) + (return-from produce-inline-loc 'VALUES)) + + ;; Otherwise we have to set up variables for holding the output. + (flet ((make-output-var (type) + (let ((var (make-lcl-var :rep-type type))) + (wt-nl (rep-type->c-name type) " " var ";") + var))) + (open-inline-block) + (let ((output-vars (mapcar #'make-output-var output-rep-type))) + (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects output-vars) + (cond ((= (length output-vars) 1) + (first output-vars)) + (t + (loop for v in output-vars + for i from 0 + do (let ((*destination* `(VALUE ,i))) (set-loc v))) + (wt "cl_env_copy->nvalues = " (length output-vars) ";") + 'VALUES)))))) + +(defun coerce-locs (inlined-args &optional types args-to-be-saved) + ;; INLINED-ARGS is a list of (TYPE LOCATION) produced by the + ;; inline code. ARGS-TO-BE-SAVED is a positional list created by + ;; C-INLINE, instructing that the value should be saved in a temporary + ;; variable. Finally, TYPES is a list of destination types, to which + ;; the former values are coerced. The destination types can be + ;; - A lisp type (:OBJECT, :FINXUM, etc) + ;; - A machine representation type (T, INTEGER, etc) + (loop with block-opened = nil + for (lisp-type loc) in inlined-args + for type in (or types '#1=(:object . #1#)) + for i from 0 + for rep-type = (lisp-type->rep-type type) + collect + (cond ((and args-to-be-saved + (member i args-to-be-saved :test #'eql) + (not (loc-movable-p loc))) + (let ((lcl (make-lcl-var :rep-type rep-type))) + (wt-nl) + (unless block-opened + (setf block-opened t) + (open-inline-block)) + (wt (rep-type->c-name rep-type) " " lcl "= ") + (wt-coerce-loc rep-type loc) + (wt ";") + lcl)) + ((equal rep-type (loc-representation-type loc)) + loc) + (t + `(COERCE-LOC ,rep-type ,loc))))) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp b/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp index 555f155a8..b6a628fc7 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-ffi.lsp @@ -71,74 +71,6 @@ (c2expr* form))) finally (unwind-exit nil))) -(defun produce-inline-loc (inlined-arguments arg-types output-rep-type - c-expression side-effects one-liner) - (let* (args-to-be-saved - coerced-arguments) - ;; If the expression begins with @[0-9a-z]*, this means we are - ;; saving some variables. - (when (and (> (length c-expression) 1) - (eq (char c-expression 0) #\@)) - (do ((ndx 1 (1+ ndx))) - ((>= ndx (length c-expression))) - (let ((c (char c-expression ndx))) - (when (eq c #\;) - (setf c-expression (subseq c-expression (1+ ndx))) - (return)) - (unless (alphanumericp c) - (setf args-to-be-saved nil) - (return)) - (push (- (char-code c) (char-code #\0)) - args-to-be-saved)))) - - (setf coerced-arguments (coerce-locs inlined-arguments arg-types args-to-be-saved)) - ;;(setf output-rep-type (lisp-type->rep-type output-rep-type)) - - ;; If the form does not output any data, and there are no side - ;; effects, try to omit it. - (when (null output-rep-type) - (if side-effects - (progn - (wt-nl) - (wt-c-inline-loc output-rep-type c-expression coerced-arguments t nil) - (when one-liner (wt ";"))) - (cmpnote "Ignoring form ~S" c-expression)) - (wt-nl "value0 = ECL_NIL;") - (wt-nl "cl_env_copy->nvalues = 0;") - (return-from produce-inline-loc 'RETURN)) - - ;; If the form is a one-liner, we can simply propagate this expression until the - ;; place where the value is used. - (when one-liner - (return-from produce-inline-loc - `(ffi:c-inline ,output-rep-type ,c-expression ,coerced-arguments ,side-effects - ,(if (equalp output-rep-type '((VALUES &REST T))) - 'VALUES NIL)))) - - ;; If the output is a in the VALUES vector, just write down the form and output - ;; the location of the data. - (when (equalp output-rep-type '((VALUES &REST T))) - (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects - 'VALUES) - (return-from produce-inline-loc 'VALUES)) - - ;; Otherwise we have to set up variables for holding the output. - (flet ((make-output-var (type) - (let ((var (make-lcl-var :rep-type type))) - (wt-nl (rep-type->c-name type) " " var ";") - var))) - (open-inline-block) - (let ((output-vars (mapcar #'make-output-var output-rep-type))) - (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects output-vars) - (cond ((= (length output-vars) 1) - (first output-vars)) - (t - (loop for v in output-vars - for i from 0 - do (let ((*destination* `(VALUE ,i))) (set-loc v))) - (wt "cl_env_copy->nvalues = " (length output-vars) ";") - 'VALUES)))))) - (defun c2c-inline (c1form arguments &rest rest) (declare (ignore c1form)) (let ((*inline-blocks* 0) @@ -146,48 +78,6 @@ (unwind-exit (apply #'produce-inline-loc (inline-args arguments) rest)) (close-inline-blocks))) -(defun coerce-locs (inlined-args &optional types args-to-be-saved) - ;; INLINED-ARGS is a list of (TYPE LOCATION) produced by the - ;; inline code. ARGS-TO-BE-SAVED is a positional list created by - ;; C-INLINE, instructing that the value should be saved in a temporary - ;; variable. Finally, TYPES is a list of destination types, to which - ;; the former values are coerced. The destination types can be - ;; - A lisp type (:OBJECT, :FINXUM, etc) - ;; - A machine representation type (T, INTEGER, etc) - (loop with block-opened = nil - for (lisp-type loc) in inlined-args - for type in (or types '#1=(:object . #1#)) - for i from 0 - for rep-type = (lisp-type->rep-type type) - collect - (cond ((and args-to-be-saved - (member i args-to-be-saved :test #'eql) - (not (loc-movable-p loc))) - (let ((lcl (make-lcl-var :rep-type rep-type))) - (wt-nl) - (unless block-opened - (setf block-opened t) - (open-inline-block)) - (wt (rep-type->c-name rep-type) " " lcl "= ") - (wt-coerce-loc rep-type loc) - (wt ";") - lcl)) - ((equal rep-type (loc-representation-type loc)) - loc) - (t - `(COERCE-LOC ,rep-type ,loc))))) - -(defun c-inline-safe-string (constant-string) - ;; Produce a text representation of a string that can be used - ;; in a C-INLINE form, without triggering the @ or # escape - ;; characters - (c-filtered-string - (concatenate 'string - (loop for c across constant-string - when (member c '(#\# #\@)) - collect c - collect c)))) - (defun t3-defcallback (lisp-name c-name c-name-constant return-type return-type-code arg-types arg-type-constants call-type &aux (return-p t)) (declare (ignore lisp-name)) From 8bb0b99499ab4691e773bb819ee62cf9a7699358 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 6 Jun 2023 15:04:11 +0200 Subject: [PATCH 20/23] cmpc: move c-inline expansions of PRINC to the backend Instead of using DEFINE-COMPILER-MACRO we implement them with DEFINE-C-INLINER because these optimizations are backend-specific. --- src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp | 56 ++++++++++++++ src/cmp/cmpopt-printer.lsp | 85 --------------------- src/cmp/cmpopt.lsp | 12 +++ src/cmp/load.lsp.in | 2 +- 4 files changed, 69 insertions(+), 86 deletions(-) create mode 100644 src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp delete mode 100644 src/cmp/cmpopt-printer.lsp diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp new file mode 100644 index 000000000..9b51075ed --- /dev/null +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp @@ -0,0 +1,56 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +;;;; +;;;; Copyright (c) 2010, Juan Jose Garcia Ripoll +;;;; Copyright (c) 2023, Daniel Kochmański +;;;; +;;;; See the file 'LICENSE' for the copyright details. +;;;; + +;;;; C/C++ specific optimizer for the printer. + +(in-package "COMPILER") + +;;; TODO move mundane inliners to the sysfun database. + +(define-c-inliner terpri (return-type &optional stream) + (produce-inline-loc (list stream) + '(:object) '(:object) + "ecl_terpri(#0)" t t)) + +(define-c-inliner print (return-type value &optional stream) + (produce-inline-loc (list value stream) + '(:object :object) '(:object) + "ecl_print(#0,#1)" t t)) + +(define-c-inliner prin1 (return-type value &optional stream) + (produce-inline-loc (list value stream) + '(:object :object) '(:object) + "ecl_prin1(#0,#1)" t t)) + +#+ (or) +(define-c-inliner princ (return-type expression &optional stream) + (produce-inline-loc (list expression stream) + '(:object :object) '(:object) + "ecl_princ(#0,#1)" t t)) + +(define-c-inliner princ (return-type expression &optional stream) + (multiple-value-bind (foundp value) + (loc-immediate-value-p (inlined-arg-loc expression)) + (cond + ((and foundp (characterp value)) + (produce-inline-loc (list expression stream) + '(:wchar :object) '(:wchar) + "ecl_princ_char(#0,#1)" t t)) + ((and foundp (typep value 'base-string) (< (length value) 80)) + (produce-inline-loc (list stream) + '(:object) '(:void) + (concatenate 'string "ecl_princ_str(" + (c-inline-safe-string value) + ",#0)") + t t)) + (t + (produce-inline-loc (list expression stream) + '(:object :object) '(:object) + "ecl_princ(#0,#1)" t t))))) diff --git a/src/cmp/cmpopt-printer.lsp b/src/cmp/cmpopt-printer.lsp deleted file mode 100644 index fb140c510..000000000 --- a/src/cmp/cmpopt-printer.lsp +++ /dev/null @@ -1,85 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; -;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll -;;;; -;;;; This program is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. -;;;; -;;;; See file '../Copyright' for full details. -;;;; -;;;; CMPOPT-PRINTER -- Optimize output operations -;;;; - -(in-package "COMPILER") - -(defun printer-default-stream (stream env) - (declare (si::c-local)) - (if (constantp stream env) - (let ((value (ext:constant-form-value stream env))) - (case value - ((nil) '*standard-output*) - ((t) '*terminal-io*) - (otherwise (cmpwarn - (if (streamp value) - "Found~%~A~%as expression for a stream, but it cannot be externalized." - "Found~%~A~%where a stream was expected.") - stream) - stream))) - `(ffi:c-inline (,stream) (:object) :object - "_ecl_stream_or_default_output(#0)" - :one-liner t))) - -(define-compiler-macro princ (expression &optional stream &environment env) - (if (constantp expression env) - (let ((value (ext:constant-form-value expression env))) - (cond ((eql value #\Newline) - `(terpri ,stream)) - ((characterp value) - `(ffi:c-inline ,(list value stream) (:wchar :object) :wchar - "ecl_princ_char(#0,#1)" - :one-liner t)) - ((and (stringp value) - (= (length value) 1)) - `(ffi:c-inline ,(list (aref value 0) stream) (:wchar :object) :wchar - "ecl_princ_char(#0,#1)" - :one-liner t)) - ((and (typep value 'base-string) - (< (length value) 80)) - `(progn - (ffi:c-inline ,(list stream) (:object) :void - ,(concatenate 'string - "ecl_princ_str(" - (c-inline-safe-string value) - ",#0)") - :one-liner t) - ,value)) - (t - `(ffi:c-inline ,(list expression stream) (:object :object) :object - "ecl_princ(#0,#1)" - :one-liner t)))) - `(ffi:c-inline ,(list expression stream) (:object :object) :object - "ecl_princ(#0,#1)" - :one-liner t))) - -(define-compiler-macro terpri (&optional stream) - `(ffi:c-inline (,stream) - (:object) :object - "ecl_terpri(#0)" - :one-liner t)) - -(define-compiler-macro print (value &optional stream) - `(ffi:c-inline (,value ,stream) - (:object :object) :object - "ecl_print(#0,#1)" - :one-liner t)) - -(define-compiler-macro prin1 (value &optional stream) - `(ffi:c-inline (,value ,stream) - (:object :object) :object - "ecl_prin1(#0,#1)" - :one-liner t)) - diff --git a/src/cmp/cmpopt.lsp b/src/cmp/cmpopt.lsp index f49f96fab..08b7c4a9d 100644 --- a/src/cmp/cmpopt.lsp +++ b/src/cmp/cmpopt.lsp @@ -361,3 +361,15 @@ (:long-double "ecl_to_long_double(#0)")) :one-liner t :side-effects nil)))))))) form)) + +(define-compiler-macro princ (&whole whole expression &optional stream &environment env) + (if (constantp expression env) + (let ((value (ext:constant-form-value expression env))) + (typecase value + ((eql #\newline) + `(terpri ,stream)) + ((string 1) + `(princ ,(aref value 0) ,stream)) + (otherwise + whole))) + whole)) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 5e0a8f96f..a137936ea 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -52,6 +52,7 @@ "src:cmp;cmpbackend-cxx;cmpc-opt-inl.lsp" "src:cmp;cmpbackend-cxx;cmpc-opt-num.lsp" "src:cmp;cmpbackend-cxx;cmpc-opt-ct.lsp" + "src:cmp;cmpbackend-cxx;cmpc-opt-printer.lsp" ;; Code generation pass "src:cmp;cmpbackend-cxx;cmppass2-data.lsp" "src:cmp;cmpbackend-cxx;cmppass2-top.lsp" @@ -74,7 +75,6 @@ "src:cmp;cmpopt-clos.lsp" "src:cmp;cmpopt-constant.lsp" "src:cmp;cmpopt-cons.lsp" - "src:cmp;cmpopt-printer.lsp" "src:cmp;cmpopt-sequence.lsp" "src:cmp;cmpopt-type.lsp" "src:cmp;cmpclos.lsp" ;unused From 4a1902658c4c2aac65348ffa371d307bede51131 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 7 Jun 2023 13:42:48 +0200 Subject: [PATCH 21/23] cmpc: move sysfun to the cxx backend sysfun declarations revolve strictly around c function inlining that is specific to the C backend. Moreover be more explicit about symbol packages and check feature-conditioned inlines at runtime (not at readtime) in case that we construct the inline information for a cross-compiled target. This should be further improved. --- msvc/Makefile | 7 +- src/cmp/cmpbackend-cxx/cmpc-inl-lspfun.lsp | 203 ++++ src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp | 819 ++++++++++++++ src/cmp/cmpbackend-cxx/cmpc-inliner.lsp | 12 +- src/cmp/cmpbackend-cxx/cmppass2-call.lsp | 38 +- src/cmp/cmpenv-proclaim.lsp | 8 +- src/cmp/cmputil.lsp | 6 - src/cmp/load.lsp.in | 3 +- src/cmp/sysfun.lsp | 1123 -------------------- 9 files changed, 1053 insertions(+), 1166 deletions(-) create mode 100644 src/cmp/cmpbackend-cxx/cmpc-inl-lspfun.lsp create mode 100644 src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp delete mode 100644 src/cmp/sysfun.lsp diff --git a/msvc/Makefile b/msvc/Makefile index 1638b2c9f..4e85a7b53 100755 --- a/msvc/Makefile +++ b/msvc/Makefile @@ -231,7 +231,7 @@ c\cut$(EXE): $(top_srcdir)\util\cut.c $(MAKE) cut$(EXE) cd .. -$(TARGETS): $(UCDDAT) ecl_min$(EXE) compile.lsp sysfun.lsp BUILD-STAMP +$(TARGETS): $(UCDDAT) ecl_min$(EXE) compile.lsp BUILD-STAMP set ECLDIR=./ ecl_min compile BUILD-STAMP: Makefile @@ -377,9 +377,6 @@ eclgmp.lib: $(CP) gmp.h ..\ecl\gmp.h cd .. -sysfun.lsp: - $(CP) $(srcdir)\cmp\sysfun.lsp .\ - install: IF NOT EXIST "$(prefix)" $(MKDIR) "$(prefix)" IF NOT EXIST "$(bindir)" $(MKDIR) "$(bindir)" @@ -454,7 +451,7 @@ clean: clean_ecl clean_lisp clean_ecl: -for %i in (eclgc.lib eclgmp.lib lsp\config.lsp compile.lsp bare.lsp \ lsp\load.lsp clos\load.lsp cmp\load.lsp cmp\cmpdefs.lsp \ - ecl.lib ecl.dll ecl_min$(EXE) eclmin.lib help.doc sysfun.lsp \ + ecl.lib ecl.dll ecl_min$(EXE) eclmin.lib help.doc \ BUILD-STAMP $(TARGETS) *.exp *.ilk *.manifest *.pdb *.c *.obj \ ecl-config.bat ecl-static.lib *.tmp *.implib *.lib ecl.ico \ ecl-cc.bat ecl.rc ecl.res) \ diff --git a/src/cmp/cmpbackend-cxx/cmpc-inl-lspfun.lsp b/src/cmp/cmpbackend-cxx/cmpc-inl-lspfun.lsp new file mode 100644 index 000000000..9083de74e --- /dev/null +++ b/src/cmp/cmpbackend-cxx/cmpc-inl-lspfun.lsp @@ -0,0 +1,203 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +;;;; +;;;; Copyright (c) 1991, Giuseppe Attardi. All rights reserved. +;;;; Copyright (c) 2003, Juan Jose Garcia Ripoll +;;;; +;;;; See the file 'LICENSE' for the copyright details. +;;;; + +;;;; +;;;; Database for Lisp functions accessible from C. +;;;; + +(in-package "COMPILER") + +;;; +;;; FUNCTIONS WHICH CAN BE CALLED FROM C +;;; +;;; The following two lists contain all functions in the core library which do +;;; not belong to the C part of the library, but which should have an exported C +;;; name that users (and compiled code) can refer to. This means, for instance, that +;;; MAKE-ARRAY will be compiled to a function called cl_make_array, etc. +;;; +;;; Note that if the created C function should take only fixed +;;; arguments, a proclamation for the function type must exist so that +;;; the compiler can produce the correct function signature! +;;; + +#+ecl-min +(defvar *in-all-symbols-functions* + ;; These functions are visible from external.h and their function + ;; objects are created in init_all_symbols from the data in + ;; symbols_list.h + `(;; arraylib.lsp + cl:make-array cl:vector cl:array-dimensions cl:array-in-bounds-p cl:array-row-major-index + cl:bit cl:sbit cl:bit-and cl:bit-ior cl:bit-xor cl:bit-eqv cl:bit-nand cl:bit-nor cl:bit-andc1 + cl:bit-andc2 cl:bit-orc1 cl:bit-orc2 cl:bit-not + cl:vector-pop cl:adjust-array + ;; assert.lsp + si:do-check-type si:ecase-error si:etypecase-error + si:wrong-type-argument si:ccase-error si:ctypecase-error + ;; config.lsp + cl:short-site-name cl:long-site-name cl:machine-type cl:machine-instance cl:machine-version + cl:software-type cl:software-version cl:lisp-implementation-type cl:lisp-implementation-version + si:lisp-implementation-vcs-id + ;; assignment.lsp + si:setf-definition + ;; conditions.lsp + si:safe-eval cl:abort cl:continue cl:muffle-warning cl:store-value cl:use-value + si:bind-simple-restarts si:bind-simple-handlers + si:assert-failure cl:compute-restarts cl:find-restart cl:invoke-restart + cl:invoke-restart-interactively cl:make-condition + ;; describe.lsp + cl:describe cl:inspect + ;; iolib.lsp + cl:read-from-string cl:write-to-string cl:prin1-to-string cl:princ-to-string + cl:y-or-n-p cl:yes-or-no-p si:string-to-object cl:dribble + ext:make-encoding ext:load-encoding + ;; listlib.lsp + cl:union cl:nunion cl:intersection cl:nintersection cl:set-difference cl:nset-difference + cl:set-exclusive-or cl:nset-exclusive-or cl:subsetp cl:rassoc-if cl:rassoc-if-not + cl:assoc-if cl:assoc-if-not cl:member-if cl:member-if-not cl:subst-if cl:subst-if-not + cl:nsubst-if cl:nsubst-if-not + ;; mislib.lsp + cl:logical-pathname-translations cl:load-logical-pathname-translations cl:decode-universal-time + cl:encode-universal-time cl:get-decoded-time + cl:ensure-directories-exist si:simple-program-error si:signal-simple-error + ;; module.lsp + cl:provide cl:require + ;; numlib.lsp + cl:isqrt cl:phase cl:signum cl:cis + cl:asin cl:acos cl:asinh cl:acosh cl:atanh cl:ffloor cl:fceiling cl:ftruncate cl:fround + cl:logtest cl:byte cl:byte-size cl:byte-position cl:ldb cl:ldb-test cl:mask-field cl:dpb + cl:deposit-field + ;; packlib.lsp + cl:find-all-symbols cl:apropos cl:apropos-list + ;; pprint.lsp + cl:pprint-fill cl:copy-pprint-dispatch cl:pprint-dispatch + cl:pprint-linear cl:pprint-newline cl:pprint-tab cl:pprint-tabular + cl:set-pprint-dispatch cl:pprint-indent + ;; predlib.lsp + cl:upgraded-array-element-type cl:upgraded-complex-part-type cl:typep cl:subtypep cl:coerce + si:do-deftype si:ratiop si:single-float-p si:short-float-p si:double-float-p + si:long-float-p + ;; process.lsp + ext:run-program + ext:terminate-process + ;; seq.lsp + cl:make-sequence cl:concatenate cl:map cl:some cl:every cl:notany cl:notevery cl:map-into cl:complement + ;; seqlib.lsp + cl:reduce cl:fill cl:replace + cl:remove cl:remove-if cl:remove-if-not cl:delete cl:delete-if cl:delete-if-not + cl:count cl:count-if cl:count-if-not cl:substitute cl:substitute-if cl:substitute-if-not + cl:nsubstitute cl:nsubstitute-if cl:nsubstitute-if-not cl:find cl:find-if cl:find-if-not + cl:position cl:position-if cl:position-if-not cl:remove-duplicates + cl:delete-duplicates cl:mismatch cl:search cl:sort cl:stable-sort cl:merge cl:constantly + si:sequence-count + ;; setf.lsp + si:do-defsetf si:do-define-setf-method + ;; trace.lsp + si:traced-old-definition + + ,@(when (member :clos *features*) + '(;; combin.lsp + cl:invalid-method-error + cl:method-combination-error + clos:compute-effective-method-function + clos:std-compute-effective-method + ;; defclass.lsp + clos::ensure-class + clos:load-defclass + ;; kernel.lsp + clos:std-compute-applicable-methods + ;; method.lsp + clos:extract-lambda-list + clos:extract-specializer-names + ;; predlib.lsp + si:subclassp si:of-class-p + ;; slotvalue.lsp + cl:slot-makunbound + ;; std-slot-value.lsp + cl:slot-boundp + cl:slot-exists-p + cl:slot-value + clos:slot-value-set + clos:standard-instance-access ;; alias clos:funcallable-standard-instance-access + clos:standard-instance-set)) + + ;; cdr-5 + ext:array-index-p + ext:negative-fixnum-p ext:non-negative-fixnum-p + ext:non-positive-fixnum-p ext:positive-fixnum-p + ext:negative-integer-p ext:non-negative-integer-p + ext:non-positive-integer-p ext:positive-integer-p + ext:negative-rational-p ext:non-negative-rational-p + ext:non-positive-rational-p ext:positive-rational-p + ext:negative-ratio-p ext:non-negative-ratio-p + ext:non-positive-ratio-p ext:positive-ratio-p + ext:negative-real-p ext:non-negative-real-p + ext:non-positive-real-p ext:positive-real-p + ext:negative-float-p ext:non-negative-float-p + ext:non-positive-float-p ext:positive-float-p + ext:negative-short-float-p ext:non-negative-short-float-p + ext:non-positive-short-float-p ext:positive-short-float-p + ext:negative-single-float-p ext:non-negative-single-float-p + ext:non-positive-single-float-p ext:positive-single-float-p + ext:negative-double-float-p ext:non-negative-double-float-p + ext:non-positive-double-float-p ext:positive-double-float-p + ext:negative-long-float-p ext:non-negative-long-float-p + ext:non-positive-long-float-p ext:positive-long-float-p)) + +(proclaim + ;; These functions are not visible in external.h and have no entry in + ;; symbols_list.h + `(si::c-export-fname + ,@(when (member :ecl-min *features*) + *in-all-symbols-functions*) + ;; defmacro.lsp + si::find-documentation si::find-declarations + si::search-keyword si::check-keyword + si::dm-too-many-arguments si::dm-too-few-arguments + si::remove-documentation + ;; defstruct.lsp + si::structure-type-error si::define-structure + ;; helpfile.lsp + si::get-documentation si::set-documentation + si::expand-set-documentation + ;; packlib.lsp + si::packages-iterator + ;; pprint.lsp + si::pprint-logical-block-helper si::pprint-pop-helper + ;; seq.lsp + si::make-seq-iterator si::seq-iterator-ref + si::seq-iterator-set si::seq-iterator-next + si::coerce-to-list si::coerce-to-vector + ,@(when (member :formatter *features*) + '(si::format-princ si::format-prin1 si::format-print-named-character + si::format-print-integer + si::format-print-cardinal si::format-print-ordinal si::format-print-old-roman + si::format-print-roman si::format-fixed si::format-exponential + si::format-general si::format-dollars + si::format-relative-tab si::format-absolute-tab + si::format-justification)) + ,@(when (member :clos *features*) + '(;; generic.lsp + clos::associate-methods-to-gfun + ;; kernel.lsp + clos::install-method + ;; std-slot-value.lsp + clos::find-slot-definition + ;; clos::generic-function-lambda-list + ;; clos::generic-function-argument-precedence-order + ;; clos::generic-function-method-combination + ;; clos::generic-function-method-class + ;; clos::generic-function-methods + ;; clos::method-generic-function + ;; clos::method-lambda-list + ;; clos::method-specializers + ;; clos::method-qualifiers + ;; clos::method-function + ;; clos::method-plist + )))) diff --git a/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp b/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp new file mode 100644 index 000000000..001d82199 --- /dev/null +++ b/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp @@ -0,0 +1,819 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- +;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: + +;;;; +;;;; Copyright (c) 1991, Giuseppe Attardi. All rights reserved. +;;;; Copyright (c) 2003, Juan Jose Garcia Ripoll +;;;; +;;;; See the file 'LICENSE' for the copyright details. +;;;; + +;;;; +;;;; Database for system functions. +;;;; + +(in-package "COMPILER") + +;;; +;;; DATABASE OF INLINE EXPANSIONS +;;; +;;; (DEF-INLINE function-name kind ([arg-type]*) return-rep-type +;;; expansion-string) +;;; +;;; Here, ARG-TYPE is the list of argument types belonging to the lisp family, +;;; while RETURN-REP-TYPE is a representation type, i.e. the C type of the +;;; output expression. EXPANSION-STRING is a C/C++ expression template, like the +;;; ones used by C-INLINE. Finally, KIND can be :ALWAYS, :SAFE or :UNSAFE, +;;; depending on whether the inline expression should be applied always, in safe +;;; or in unsafe compilation mode, respectively. +;;; + +(defun inline-information (name safety) + (gethash (list name safety) *inline-information*)) + +(defun (setf inline-information) (value name safety) + (setf (gethash (list name safety) *inline-information*) value)) + +(defun %def-inline (name safety arg-types return-rep-type expansion + &key (one-liner t) (exact-return-type nil) (inline-or-warn nil) + (multiple-values t) + &aux arg-rep-types) + (setf safety + (case safety + (:unsafe :inline-unsafe) + (:safe :inline-safe) + (:always :inline-always) + (t (error "In DEF-INLINE, wrong value of SAFETY")))) + ;; Ensure we can inline this form. We only inline when the features are + ;; there (checked above) and when the C types are part of this machine + ;; (checked here). + (loop for type in (list* return-rep-type arg-types) + unless (or (eq type 'fixnum-float) + (and (consp type) (eq (car type) 'values)) + (lisp-type-p type) + (machine-c-type-p type)) + do (warn "Dropping inline form for ~A because of missing type ~A" name type) + (return-from %def-inline)) + (setf arg-rep-types + (mapcar #'(lambda (x) (if (eq x '*) x (lisp-type->rep-type x))) + arg-types)) + (when (eq return-rep-type t) + (setf return-rep-type :object)) + (when inline-or-warn + (setf (inline-information name 'should-be-inlined) t)) + (let* ((return-type (if (and (consp return-rep-type) + (eq (first return-rep-type) 'values)) + t + (rep-type->lisp-type return-rep-type))) + (inline-info + (make-inline-info :name name + :arg-rep-types arg-rep-types + :return-rep-type return-rep-type + :return-type return-type + :arg-types arg-types + :exact-return-type exact-return-type + :multiple-values multiple-values + ;; :side-effects (not (si:get-sysprop name 'no-side-effects)) + :one-liner one-liner + :expansion expansion))) + #+(or) + (loop for i in (inline-information name safety) + when (and (equalp (inline-info-arg-types i) arg-types) + (not (equalp return-type (inline-info-return-type i)))) + do (format t "~&;;; Redundand inline definition for ~A~&;;; ~<~A~>~&;;; ~<~A~>" + name i inline-info)) + (push inline-info (gethash (list name safety) *inline-information*)))) + +(defmacro def-inline (&rest args) + `(apply #'%def-inline ',args)) + +(defun make-inline-information (*machine*) + (let ((*inline-information* (make-hash-table :size 768 :test 'equal))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; ALL FUNCTION DECLARATIONS AND INLINE FORMS + ;; + (def-inline cl:aref :unsafe (t t t) t "@0;ecl_aref_unsafe(#0,ecl_fixnum(#1)*(#0)->array.dims[1]+ecl_fixnum(#2))") + (def-inline cl:aref :unsafe ((array t) t t) t "@0;(#0)->array.self.t[ecl_fixnum(#1)*(#0)->array.dims[1]+ecl_fixnum(#2)]") + (def-inline cl:aref :unsafe ((array bit) t t) :fixnum "@0;ecl_aref_bv(#0,ecl_fixnum(#1)*(#0)->array.dims[1]+ecl_fixnum(#2))") + (def-inline cl:aref :unsafe ((array t) fixnum fixnum) t "@0;(#0)->array.self.t[#1*(#0)->array.dims[1]+#2]") + (def-inline cl:aref :unsafe ((array bit) fixnum fixnum) :fixnum "@0;ecl_aref_bv(#0,(#1)*(#0)->array.dims[1]+#2)") + (def-inline cl:aref :unsafe ((array base-char) fixnum fixnum) :unsigned-char "@0;(#0)->base_string.self[#1*(#0)->array.dims[1]+#2]") + (def-inline cl:aref :unsafe ((array double-float) fixnum fixnum) :double "@0;(#0)->array.self.df[#1*(#0)->array.dims[1]+#2]") + (def-inline cl:aref :unsafe ((array single-float) fixnum fixnum) :float "@0;(#0)->array.self.sf[#1*(#0)->array.dims[1]+#2]") + (def-inline cl:aref :unsafe ((array long-float) fixnum fixnum) :long-double "@0;(#0)->array.self.lf[#1*(#0)->array.dims[1]+#2]") + (when (member :complex-float *features*) + (def-inline cl:aref :unsafe ((array si:complex-single-float) fixnum fixnum) :csfloat "@0;(#0)->array.self.csf[#1*(#0)->array.dims[1]+#2]") + (def-inline cl:aref :unsafe ((array si:complex-double-float) fixnum fixnum) :cdfloat "@0;(#0)->array.self.cdf[#1*(#0)->array.dims[1]+#2]") + (def-inline cl:aref :unsafe ((array si:complex-long-float) fixnum fixnum) :clfloat "@0;(#0)->array.self.clf[#1*(#0)->array.dims[1]+#2]")) + + (def-inline cl:aref :unsafe ((array fixnum) fixnum fixnum) :fixnum "@0;(#0)->array.self.fix[#1*(#0)->array.dims[1]+#2]") + + (def-inline cl:aref :always (t t) t "ecl_aref1(#0,ecl_to_size(#1))") + (def-inline cl:aref :always (t fixnum) t "ecl_aref1(#0,#1)") + (def-inline cl:aref :unsafe (t t) t "ecl_aref1(#0,ecl_fixnum(#1))") + (def-inline cl:aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,ecl_fixnum(#1))") + (def-inline cl:aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") + (when (member :unicode *features*) + (def-inline cl:aref :unsafe ((array character) fixnum) :wchar "(#0)->string.self[#1]")) + (def-inline cl:aref :unsafe ((array base-char) fixnum) :unsigned-char "(#0)->base_string.self[#1]") + (def-inline cl:aref :unsafe ((array double-float) fixnum) :double "(#0)->array.self.df[#1]") + (def-inline cl:aref :unsafe ((array single-float) fixnum) :float "(#0)->array.self.sf[#1]") + (def-inline cl:aref :unsafe ((array long-float) fixnum) :long-double "(#0)->array.self.lf[#1]") + (when (member :complex-float *features*) + (def-inline cl:aref :unsafe ((array si:complex-single-float) fixnum) :csfloat "(#0)->array.self.csf[#1]") + (def-inline cl:aref :unsafe ((array si:complex-double-float) fixnum) :cdfloat "(#0)->array.self.cdf[#1]") + (def-inline cl:aref :unsafe ((array si:complex-long-float) fixnum) :clfloat "(#0)->array.self.clf[#1]")) + (def-inline cl:aref :unsafe ((array fixnum) fixnum) :fixnum "(#0)->array.self.fix[#1]") + + (def-inline cl:row-major-aref :always (t t) t "ecl_aref(#0,ecl_to_size(#1))") + (def-inline cl:row-major-aref :always (t fixnum) t "ecl_aref(#0,#1)") + (def-inline cl:row-major-aref :unsafe (t t) t "ecl_aref_unsafe(#0,ecl_fixnum(#1))") + (def-inline cl:row-major-aref :unsafe (t fixnum) t "ecl_aref_unsafe(#0,#1)") + (def-inline cl:row-major-aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,ecl_fixnum(#1))") + (def-inline cl:row-major-aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") + (when (member :unicode *features*) + (def-inline cl:row-major-aref :unsafe ((array character) fixnum) :wchar "(#0)->string.self[#1]")) + (def-inline cl:row-major-aref :unsafe ((array base-char) fixnum) :unsigned-char "(#0)->base_string.self[#1]") + (def-inline cl:row-major-aref :unsafe ((array ext:byte8) fixnum) :uint8-t "(#0)->vector.self.b8[#1]") + (def-inline cl:row-major-aref :unsafe ((array ext:integer8) fixnum) :int8-t "(#0)->vector.self.i8[#1]") + (def-inline cl:row-major-aref :unsafe ((array ext:byte16) fixnum) :uint16-t "(#0)->vector.self.b16[#1]") + (def-inline cl:row-major-aref :unsafe ((array ext:integer16) fixnum) :int16-t "(#0)->vector.self.i16[#1]") + (def-inline cl:row-major-aref :unsafe ((array ext:byte32) fixnum) :uint32-t "(#0)->vector.self.b32[#1]") + (def-inline cl:row-major-aref :unsafe ((array ext:integer32) fixnum) :int32-t "(#0)->vector.self.i32[#1]") + (def-inline cl:row-major-aref :unsafe ((array ext:byte64) fixnum) :uint64-t "(#0)->vector.self.b64[#1]") + (def-inline cl:row-major-aref :unsafe ((array ext:integer64) fixnum) :int64-t "(#0)->vector.self.i64[#1]") + (def-inline cl:row-major-aref :unsafe ((array long-float) fixnum) :long-double "(#0)->array.self.lf[#1]") + (def-inline cl:row-major-aref :unsafe ((array double-float) fixnum) :double "(#0)->array.self.df[#1]") + (def-inline cl:row-major-aref :unsafe ((array single-float) fixnum) :float "(#0)->array.self.sf[#1]") + (when (member :complex-float *features*) + (def-inline cl:row-major-aref :unsafe ((array si:complex-single-float) fixnum) :csfloat "(#0)->array.self.csf[#1]") + (def-inline cl:row-major-aref :unsafe ((array si:complex-double-float) fixnum) :cdfloat "(#0)->array.self.cdf[#1]") + (def-inline cl:row-major-aref :unsafe ((array si:complex-long-float) fixnum) :clfloat "(#0)->array.self.clf[#1]")) + (def-inline cl:row-major-aref :unsafe ((array fixnum) fixnum) :fixnum "(#0)->array.self.fix[#1]") + + (def-inline si:row-major-aset :always (t t t) t "ecl_aset(#0,ecl_to_size(#1),#2)") + (def-inline si:row-major-aset :always (t fixnum t) t "ecl_aset(#0,#1,#2)") + (def-inline si:row-major-aset :unsafe (t t t) t "ecl_aset_unsafe(#0,ecl_fixnum(#1),#2)") + (def-inline si:row-major-aset :unsafe (t fixnum t) t "ecl_aset_unsafe(#0,#1,#2)") + (def-inline si:row-major-aset :unsafe ((array t) fixnum t) t "(#0)->vector.self.t[#1]= #2") + (def-inline si:row-major-aset :unsafe ((array bit) fixnum t) :fixnum "ecl_aset_bv(#0,#1,ecl_fixnum(#2))") + (def-inline si:row-major-aset :unsafe ((array bit) fixnum fixnum) :fixnum "ecl_aset_bv(#0,#1,#2)") + (def-inline si:row-major-aset :unsafe ((array base-char) fixnum base-char) :unsigned-char "(#0)->base_string.self[#1]= #2") + (when (member :unicode *features*) + (def-inline si:row-major-aset :unsafe ((array character) fixnum character) :wchar "(#0)->string.self[#1]= #2")) + (def-inline si:row-major-aset :unsafe ((array ext:byte8) fixnum ext:byte8) :uint8-t "(#0)->vector.self.b8[#1]= #2") + (def-inline si:row-major-aset :unsafe ((array ext:integer8) fixnum ext:integer8) :int8-t "(#0)->vector.self.i8[#1]= #2") + (def-inline si:row-major-aset :unsafe ((array ext:byte16) fixnum ext:byte16) :uint16-t "(#0)->vector.self.b16[#1]= #2") + (def-inline si:row-major-aset :unsafe ((array ext:integer16) fixnum ext:integer16) :int16-t "(#0)->vector.self.i16[#1]= #2") + (def-inline si:row-major-aset :unsafe ((array ext:byte32) fixnum ext:byte32) :uint32-t "(#0)->vector.self.b32[#1]= #2") + (def-inline si:row-major-aset :unsafe ((array ext:integer32) fixnum ext:integer32) :int32-t "(#0)->vector.self.i32[#1]= #2") + (def-inline si:row-major-aset :unsafe ((array ext:byte64) fixnum ext:byte64) :uint64-t "(#0)->vector.self.b64[#1]= #2") + (def-inline si:row-major-aset :unsafe ((array ext:integer64) fixnum ext:integer64) :int64-t "(#0)->vector.self.i64[#1]= #2") + (def-inline si:row-major-aset :unsafe ((array long-float) fixnum long-float) :long-double "(#0)->array.self.lf[#1]= #2") + (def-inline si:row-major-aset :unsafe ((array double-float) fixnum double-float) :double "(#0)->array.self.df[#1]= #2") + (def-inline si:row-major-aset :unsafe ((array single-float) fixnum single-float) :float "(#0)->array.self.sf[#1]= #2") + (when (member :complex-float *features*) + (def-inline si:row-major-aset :unsafe ((array si:complex-single-float) fixnum si:complex-single-float) :csfloat "(#0)->array.self.csf[#1]= #2") + (def-inline si:row-major-aset :unsafe ((array si:complex-double-float) fixnum si:complex-double-float) :cdfloat "(#0)->array.self.cdf[#1]= #2") + (def-inline si:row-major-aset :unsafe ((array si:complex-long-float) fixnum si:complex-long-float) :clfloat "(#0)->array.self.clf[#1]= #2")) + (def-inline si:row-major-aset :unsafe ((array fixnum) fixnum fixnum) :fixnum "(#0)->array.self.fix[#1]= #2") + + (def-inline si:copy-subarray :always (array ext:array-index array ext:array-index ext:array-index) array "@0;(ecl_copy_subarray(#0,#1,#2,#3,#4),#0)") + + (def-inline cl:array-rank :unsafe (array) :fixnum "@0;(((#0)->d.t == t_array)?(#0)->array.rank:1)") + (def-inline cl:array-rank :always (array) :fixnum "ecl_array_rank(#0)") + + (def-inline cl:array-dimension :always (t t) fixnum "ecl_array_dimension(#0,ecl_to_size(#1))") + (def-inline cl:array-dimension :always (t fixnum) fixnum "ecl_array_dimension(#0,#1)") + + (def-inline cl:array-total-size :unsafe (t) :fixnum "((#0)->array.dim)") + + (def-inline cl:adjustable-array-p :always (t) :bool "@0;(ECL_ARRAYP(#0)? (void)0: FEtype_error_array(#0),ECL_ADJUSTABLE_ARRAY_P(#0))") + (def-inline cl:adjustable-array-p :unsafe (array) :bool "ECL_ADJUSTABLE_ARRAY_P(#0)") + + (def-inline cl:svref :always (t t) t "ecl_aref1(#0,ecl_to_size(#1))") + (def-inline cl:svref :always (t fixnum) t "ecl_aref1(#0,#1)") + (def-inline cl:svref :unsafe (t t) t "(#0)->vector.self.t[ecl_fixnum(#1)]") + (def-inline cl:svref :unsafe (t fixnum) t "(#0)->vector.self.t[#1]") + + (def-inline si:svset :always (t t t) t "ecl_aset1(#0,ecl_to_size(#1),#2)") + (def-inline si:svset :always (t fixnum t) t "ecl_aset1(#0,#1,#2)") + (def-inline si:svset :unsafe (t t t) t "((#0)->vector.self.t[ecl_fixnum(#1)]=(#2))") + (def-inline si:svset :unsafe (t fixnum t) t "(#0)->vector.self.t[#1]= #2") + + (def-inline cl:array-has-fill-pointer-p :always (t) :bool "@0;(ECL_ARRAYP(#0)?(void)0:FEtype_error_array(#0),ECL_ARRAY_HAS_FILL_POINTER_P(#0))") + (def-inline cl:array-has-fill-pointer-p :unsafe (array) :bool "ECL_ARRAY_HAS_FILL_POINTER_P(#0)") + + (def-inline cl:fill-pointer :unsafe (t) :fixnum "((#0)->vector.fillp)") + (def-inline si:fill-pointer-set :unsafe (t fixnum) :fixnum "((#0)->vector.fillp)=(#1)") + + ;; file character.d + + (def-inline cl:standard-char-p :always (character) :bool "ecl_standard_char_p(#0)") + (def-inline cl:graphic-char-p :always (character) :bool "ecl_graphic_char_p(#0)") + (def-inline cl:alpha-char-p :always (character) :bool "ecl_alpha_char_p(#0)") + (def-inline cl:upper-case-p :always (character) :bool "ecl_upper_case_p(#0)") + (def-inline cl:lower-case-p :always (character) :bool "ecl_lower_case_p(#0)") + (def-inline cl:both-case-p :always (character) :bool "ecl_both_case_p(#0)") + (def-inline cl:alphanumericp :always (character) :bool "ecl_alphanumericp(#0)") + + (def-inline cl:char= :always (t t) :bool "ecl_char_code(#0)==ecl_char_code(#1)") + (def-inline cl:char= :always (character character) :bool "(#0)==(#1)") + + (def-inline cl:char/= :always (t t) :bool "ecl_char_code(#0)!=ecl_char_code(#1)") + (def-inline cl:char/= :always (character character) :bool "(#0)!=(#1)") + + (def-inline cl:char< :always (character character) :bool "(#0)<(#1)") + (def-inline cl:char> :always (character character) :bool "(#0)>(#1)") + (def-inline cl:char<= :always (character character) :bool "(#0)<=(#1)") + (def-inline cl:char>= :always (character character) :bool "(#0)>=(#1)") + + (def-inline cl:char-code :always (character) :fixnum "#0") + (def-inline cl:code-char :always (fixnum) :wchar "#0") + + (def-inline cl:char-upcase :always (base-char) :unsigned-char "ecl_char_upcase(#0)") + (def-inline cl:char-upcase :always (character) :wchar "ecl_char_upcase(#0)") + + (def-inline cl:char-downcase :always (base-char) :unsigned-char "ecl_char_downcase(#0)") + (def-inline cl:char-downcase :always (character) :wchar "ecl_char_downcase(#0)") + + (def-inline cl:char-int :always (character) :fixnum "#0") + + ;; file ffi.d + + (def-inline si:foreign-data-p :always (t) :bool "@0;ECL_FOREIGN_DATA_P(#0)") + + ;; file file.d + + (def-inline cl:input-stream-p :always (stream) :bool "ecl_input_stream_p(#0)") + (def-inline cl:output-stream-p :always (stream) :bool "ecl_output_stream_p(#0)") + + ;; file hash.d + + (def-inline cl:gethash :always (t t t) t "ecl_gethash_safe(#0,#1,#2)" :multiple-values nil) + (def-inline cl:gethash :always (t t) t "ecl_gethash_safe(#0,#1,ECL_NIL)" :multiple-values nil) + (def-inline cl:hash-table-count :unsafe (hash-table) ext:array-index "ecl_hash_table_count(#0)") + + ;; file list.d + + (def-inline cl:car :unsafe (cons) t "ECL_CONS_CAR(#0)") + (def-inline cl:car :unsafe (t) t "_ecl_car(#0)") + + (def-inline si:cons-car :always (t) t "_ecl_car(#0)") + (def-inline si:cons-car :unsafe (t) t "ECL_CONS_CAR(#0)") + + (def-inline cl:cdr :unsafe (cons) t "ECL_CONS_CDR(#0)") + (def-inline cl:cdr :unsafe (t) t "_ecl_cdr(#0)") + + (def-inline si:cons-cdr :always (t) t "_ecl_cdr(#0)") + (def-inline si:cons-cdr :unsafe (t) t "ECL_CONS_CDR(#0)") + + ;; BEGIN-GENERATED (gen-cons-sysfun) + + (def-inline cl:car :always (t) t "ecl_car(#0)") + (def-inline cl:car :unsafe (t) t "_ecl_car(#0)") + (def-inline cl:cdr :always (t) t "ecl_cdr(#0)") + (def-inline cl:cdr :unsafe (t) t "_ecl_cdr(#0)") + (def-inline cl:caar :always (t) t "ecl_caar(#0)") + (def-inline cl:caar :unsafe (t) t "_ecl_caar(#0)") + (def-inline cl:cdar :always (t) t "ecl_cdar(#0)") + (def-inline cl:cdar :unsafe (t) t "_ecl_cdar(#0)") + (def-inline cl:cadr :always (t) t "ecl_cadr(#0)") + (def-inline cl:cadr :unsafe (t) t "_ecl_cadr(#0)") + (def-inline cl:cddr :always (t) t "ecl_cddr(#0)") + (def-inline cl:cddr :unsafe (t) t "_ecl_cddr(#0)") + (def-inline cl:caaar :always (t) t "ecl_caaar(#0)") + (def-inline cl:caaar :unsafe (t) t "_ecl_caaar(#0)") + (def-inline cl:cdaar :always (t) t "ecl_cdaar(#0)") + (def-inline cl:cdaar :unsafe (t) t "_ecl_cdaar(#0)") + (def-inline cl:cadar :always (t) t "ecl_cadar(#0)") + (def-inline cl:cadar :unsafe (t) t "_ecl_cadar(#0)") + (def-inline cl:cddar :always (t) t "ecl_cddar(#0)") + (def-inline cl:cddar :unsafe (t) t "_ecl_cddar(#0)") + (def-inline cl:caadr :always (t) t "ecl_caadr(#0)") + (def-inline cl:caadr :unsafe (t) t "_ecl_caadr(#0)") + (def-inline cl:cdadr :always (t) t "ecl_cdadr(#0)") + (def-inline cl:cdadr :unsafe (t) t "_ecl_cdadr(#0)") + (def-inline cl:caddr :always (t) t "ecl_caddr(#0)") + (def-inline cl:caddr :unsafe (t) t "_ecl_caddr(#0)") + (def-inline cl:cdddr :always (t) t "ecl_cdddr(#0)") + (def-inline cl:cdddr :unsafe (t) t "_ecl_cdddr(#0)") + (def-inline cl:caaaar :always (t) t "ecl_caaaar(#0)") + (def-inline cl:caaaar :unsafe (t) t "_ecl_caaaar(#0)") + (def-inline cl:cdaaar :always (t) t "ecl_cdaaar(#0)") + (def-inline cl:cdaaar :unsafe (t) t "_ecl_cdaaar(#0)") + (def-inline cl:cadaar :always (t) t "ecl_cadaar(#0)") + (def-inline cl:cadaar :unsafe (t) t "_ecl_cadaar(#0)") + (def-inline cl:cddaar :always (t) t "ecl_cddaar(#0)") + (def-inline cl:cddaar :unsafe (t) t "_ecl_cddaar(#0)") + (def-inline cl:caadar :always (t) t "ecl_caadar(#0)") + (def-inline cl:caadar :unsafe (t) t "_ecl_caadar(#0)") + (def-inline cl:cdadar :always (t) t "ecl_cdadar(#0)") + (def-inline cl:cdadar :unsafe (t) t "_ecl_cdadar(#0)") + (def-inline cl:caddar :always (t) t "ecl_caddar(#0)") + (def-inline cl:caddar :unsafe (t) t "_ecl_caddar(#0)") + (def-inline cl:cdddar :always (t) t "ecl_cdddar(#0)") + (def-inline cl:cdddar :unsafe (t) t "_ecl_cdddar(#0)") + (def-inline cl:caaadr :always (t) t "ecl_caaadr(#0)") + (def-inline cl:caaadr :unsafe (t) t "_ecl_caaadr(#0)") + (def-inline cl:cdaadr :always (t) t "ecl_cdaadr(#0)") + (def-inline cl:cdaadr :unsafe (t) t "_ecl_cdaadr(#0)") + (def-inline cl:cadadr :always (t) t "ecl_cadadr(#0)") + (def-inline cl:cadadr :unsafe (t) t "_ecl_cadadr(#0)") + (def-inline cl:cddadr :always (t) t "ecl_cddadr(#0)") + (def-inline cl:cddadr :unsafe (t) t "_ecl_cddadr(#0)") + (def-inline cl:caaddr :always (t) t "ecl_caaddr(#0)") + (def-inline cl:caaddr :unsafe (t) t "_ecl_caaddr(#0)") + (def-inline cl:cdaddr :always (t) t "ecl_cdaddr(#0)") + (def-inline cl:cdaddr :unsafe (t) t "_ecl_cdaddr(#0)") + (def-inline cl:cadddr :always (t) t "ecl_cadddr(#0)") + (def-inline cl:cadddr :unsafe (t) t "_ecl_cadddr(#0)") + (def-inline cl:cddddr :always (t) t "ecl_cddddr(#0)") + (def-inline cl:cddddr :unsafe (t) t "_ecl_cddddr(#0)") + ;; END-GENERATED + + (def-inline cl:cons :always (t t) t "CONS(#0,#1)") + + (def-inline cl:endp :safe (t) :bool "ecl_endp(#0)") + (def-inline cl:endp :unsafe (t) :bool "#0==ECL_NIL") + + (def-inline cl:nth :always (t t) t "ecl_nth(ecl_to_size(#0),#1)") + (def-inline cl:nth :always (fixnum t) t "ecl_nth(#0,#1)") + (def-inline cl:nth :unsafe (t t) t "ecl_nth(ecl_fixnum(#0),#1)") + (def-inline cl:nth :unsafe (fixnum t) t "ecl_nth(#0,#1)") + + (def-inline cl:nthcdr :always (t t) t "ecl_nthcdr(ecl_to_size(#0),#1)") + (def-inline cl:nthcdr :always (fixnum t) t "ecl_nthcdr(#0,#1)") + (def-inline cl:nthcdr :unsafe (t t) t "ecl_nthcdr(ecl_fixnum(#0),#1)") + (def-inline cl:nthcdr :unsafe (fixnum t) t "ecl_nthcdr(#0,#1)") + + (def-inline cl:last :always (t) t "ecl_last(#0,1)") + + (def-inline cl:list :always nil t "ECL_NIL") + (def-inline cl:list :always (t) t "ecl_list1(#0)") + + (def-inline cl:list* :always (t) t "#0") + (def-inline cl:list* :always (t t) t "CONS(#0,#1)") + + (def-inline cl:append :always (t t) t "ecl_append(#0,#1)") + (def-inline cl:nconc :always (t t) t "ecl_nconc(#0,#1)") + (def-inline cl:butlast :always (t) t "ecl_butlast(#0,1)") + (def-inline cl:nbutlast :always (t) t "ecl_nbutlast(#0,1)") + + ;; file num_arith.d + + (def-inline cl:1+ :always (t) t "ecl_one_plus(#0)") + (def-inline cl:1+ :always (fixnum) t "ecl_make_integer((#0)+1)") + (def-inline cl:1+ :always (long-float) :long-double "(long double)(#0)+1") + (def-inline cl:1+ :always (double-float) :double "(double)(#0)+1") + (def-inline cl:1+ :always (single-float) :float "(float)(#0)+1") + (when (member :complex-float *features*) + (def-inline cl:1+ :always (si:complex-single-float) :csfloat "(_Complex float)(#0)+1") + (def-inline cl:1+ :always (si:complex-double-float) :cdfloat "(_Complex double)(#0)+1") + (def-inline cl:1+ :always (si:complex-long-float) :clfloat "(_Complex long double)(#0)+1")) + (def-inline cl:1+ :always (fixnum) :fixnum "(#0)+1" :exact-return-type t) + + (def-inline cl:1- :always (t) t "ecl_one_minus(#0)") + (def-inline cl:1- :always (fixnum) t "ecl_make_integer((#0)-1)") + (def-inline cl:1- :always (long-float) :long-double "(long double)(#0)-1") + (def-inline cl:1- :always (double-float) :double "(double)(#0)-1") + (def-inline cl:1- :always (single-float) :float "(float)(#0)-1") + (when (member :complex-float *features*) + (def-inline cl:1- :always (si:complex-single-float) :csfloat "(_Complex float)(#0)-1") + (def-inline cl:1- :always (si:complex-double-float) :cdfloat "(_Complex double)(#0)-1") + (def-inline cl:1- :always (si:complex-long-float) :clfloat "(_Complex long double)(#0)-1")) + (def-inline cl:1- :always (fixnum) :fixnum "(#0)-1" :exact-return-type t) + + ;; file num_co.d + + (def-inline cl:float :always (t single-float) :float "ecl_to_float(#0)") + (def-inline cl:float :always (t double-float) :double "ecl_to_double(#0)") + (def-inline cl:float :always (t long-float) :long-double "ecl_to_long_double(#0)") + (def-inline cl:float :always (fixnum-float) :long-double "((long double)(#0))" :exact-return-type t) + (def-inline cl:float :always (fixnum-float) :double "((double)(#0))" :exact-return-type t) + (def-inline cl:float :always (fixnum-float) :float "((float)(#0))" :exact-return-type t) + + (def-inline cl:numerator :unsafe (integer) integer "(#0)") + (def-inline cl:numerator :unsafe (ratio) integer "(#0)->ratio.num") + + (def-inline cl:denominator :unsafe (integer) integer "ecl_make_fixnum(1)") + (def-inline cl:denominator :unsafe (ratio) integer "(#0)->ratio.den") + + (def-inline cl:floor :always (t) (values &rest t) "ecl_floor1(#0)") + (def-inline cl:floor :always (t t) (values &rest t) "ecl_floor2(#0,#1)") + #+(or) ; does not work well, no multiple values + (def-inline cl:floor :always (fixnum fixnum) :fixnum "@01;(#0>=0&>0?(#0)/(#1):ecl_ifloor(#0,#1))") + + (def-inline cl:ceiling :always (t) (values &rest t) "ecl_ceiling1(#0)") + (def-inline cl:ceiling :always (t t) (values &rest t) "ecl_ceiling2(#0,#1)") + + (def-inline cl:truncate :always (t) (values &rest t) "ecl_truncate1(#0)") + (def-inline cl:truncate :always (t t) (values &rest t) "ecl_truncate2(#0,#1)") + #+(or) ; does not work well, no multiple values + (def-inline cl:truncate :always (fixnum-float) :fixnum "(cl_fixnum)(#0)") + + (def-inline cl:round :always (t) (values &rest t) "ecl_round1(#0)") + (def-inline cl:round :always (t t) (values &rest t) "ecl_round2(#0,#1)") + + (def-inline cl:mod :always (t t) t "(ecl_floor2(#0,#1),cl_env_copy->values[1])") + (def-inline cl:mod :always (fixnum fixnum) :fixnum "@01;(#0>=0&>0?(#0)%(#1):ecl_imod(#0,#1))") + + (def-inline cl:rem :always (t t) t "(ecl_truncate2(#0,#1),cl_env_copy->values[1])") + (def-inline cl:rem :always (fixnum fixnum) :fixnum "(#0)%(#1)") + + (def-inline cl:= :always (t t) :bool "ecl_number_equalp(#0,#1)") + (def-inline cl:= :always (fixnum-float fixnum-float) :bool "(#0)==(#1)") + + (def-inline cl:/= :always (t t) :bool "!ecl_number_equalp(#0,#1)") + (def-inline cl:/= :always (fixnum-float fixnum-float) :bool "(#0)!=(#1)") + + (def-inline cl:< :always (t t) :bool "ecl_lower(#0,#1)") + (def-inline cl:< :always (fixnum-float fixnum-float) :bool "(#0)<(#1)") + (def-inline cl:< :always (fixnum-float fixnum-float fixnum-float) :bool "@012;((#0)<(#1) && (#1)<(#2))") + + (def-inline cl:> :always (t t) :bool "ecl_greater(#0,#1)") + (def-inline cl:> :always (fixnum-float fixnum-float) :bool "(#0)>(#1)") + (def-inline cl:> :always (fixnum-float fixnum-float fixnum-float) :bool "@012;((#0)>(#1) && (#1)>(#2))") + + (def-inline cl:<= :always (t t) :bool "ecl_lowereq(#0,#1)") + (def-inline cl:<= :always (fixnum-float fixnum-float) :bool "(#0)<=(#1)") + (def-inline cl:<= :always (fixnum-float fixnum-float fixnum-float) :bool "@012;((#0)<=(#1) && (#1)<=(#2))") + + (def-inline cl:>= :always (t t) :bool "ecl_greatereq(#0,#1)") + (def-inline cl:>= :always (fixnum-float fixnum-float) :bool "(#0)>=(#1)") + (def-inline cl:>= :always (fixnum-float fixnum-float fixnum-float) :bool "@012;((#0)>=(#1) && (#1)>=(#2))") + + (def-inline cl:max :always (fixnum fixnum) :fixnum "@01;(#0)>=(#1)?#0:#1") + (def-inline cl:min :always (fixnum fixnum) :fixnum "@01;(#0)<=(#1)?#0:#1") + (if (member :ieee-floating-point *features*) + (progn + (def-inline cl:max :always (t t) t "@01;((ecl_float_nan_p(#1) || ecl_greatereq(#0,#1))?#0:#1)") + (def-inline cl:min :always (t t) t "@01;((ecl_float_nan_p(#1) || ecl_lowereq(#0,#1))?#0:#1)")) + (progn + (def-inline cl:max :always (t t) t "@01;(ecl_greatereq(#0,#1)?#0:#1)") + (def-inline cl:min :always (t t) t "@01;(ecl_lowereq(#0,#1)?#0:#1)"))) + + ;; file num_log.d + + (def-inline cl:logand :always nil t "ecl_make_fixnum(-1)") + (def-inline cl:logand :always nil :fixnum "-1") + (def-inline cl:logand :always (t t) t "ecl_boole(ECL_BOOLAND,(#0),(#1))") + (def-inline cl:logand :always (fixnum fixnum) :fixnum "((#0) & (#1))") + + (def-inline cl:logandc1 :always (t t) t "ecl_boole(ECL_BOOLANDC1,(#0),(#1))") + (def-inline cl:logandc1 :always (fixnum fixnum) :fixnum "(~(#0) & (#1))") + + (def-inline cl:logandc2 :always (t t) t "ecl_boole(ECL_BOOLANDC2,(#0),(#1))") + (def-inline cl:logandc2 :always (fixnum fixnum) :fixnum "((#0) & ~(#1))") + + (def-inline cl:logeqv :always nil t "ecl_make_fixnum(-1)") + (def-inline cl:logeqv :always nil :fixnum "-1") + (def-inline cl:logeqv :always (t t) t "ecl_boole(ECL_BOOLEQV,(#0),(#1))") + (def-inline cl:logeqv :always (fixnum fixnum) :fixnum "(~( (#0) ^ (#1) ))") + + (def-inline cl:logior :always nil t "ecl_make_fixnum(0)") + (def-inline cl:logior :always nil :fixnum "0") + (def-inline cl:logior :always (t t) t "ecl_boole(ECL_BOOLIOR,(#0),(#1))") + (def-inline cl:logior :always (fixnum fixnum) :fixnum "((#0) | (#1))") + + (def-inline cl:lognand :always (t t) t "ecl_boole(ECL_BOOLNAND,(#0),(#1))") + (def-inline cl:lognand :always (fixnum fixnum) :fixnum "(~( (#0) & (#1) ))") + + (def-inline cl:lognor :always (t t) t "ecl_boole(ECL_BOOLNOR,(#0),(#1))") + (def-inline cl:lognor :always (fixnum fixnum) :fixnum "(~( (#0) | (#1) ))") + + (def-inline cl:lognot :always (t) t "ecl_boole(ECL_BOOLXOR,(#0),ecl_make_fixnum(-1))") + (def-inline cl:lognot :always (fixnum) :fixnum "(~(#0))") + + (def-inline cl:logorc1 :always (t t) t "ecl_boole(ECL_BOOLORC1,(#0),(#1))") + (def-inline cl:logorc1 :always (fixnum fixnum) :fixnum "(~(#0) | (#1))") + + (def-inline cl:logorc2 :always (t t) t "ecl_boole(ECL_BOOLORC2,(#0),(#1))") + (def-inline cl:logorc2 :always (fixnum fixnum) :fixnum "((#0) | ~(#1))") + + (def-inline cl:logxor :always nil t "ecl_make_fixnum(0)") + (def-inline cl:logxor :always nil :fixnum "0") + (def-inline cl:logxor :always (t t) t "ecl_boole(ECL_BOOLXOR,(#0),(#1))") + (def-inline cl:logxor :always (fixnum fixnum) :fixnum "((#0) ^ (#1))") + + (def-inline cl:boole :always (fixnum t t) t "ecl_boole((#0),(#1),(#2))") + + (def-inline cl:logbitp :always ((integer -29 29) fixnum) :bool "(#1 >> #0) & 1") + + (def-inline cl:integer-length :always (t) :cl-index "ecl_integer_length(#0)") + + (def-inline cl:zerop :always (t) :bool "ecl_zerop(#0)") + (def-inline cl:zerop :always (fixnum-float) :bool "(#0)==0") + + (def-inline cl:plusp :always (t) :bool "ecl_plusp(#0)") + (def-inline cl:plusp :always (fixnum-float) :bool "(#0)>0") + + (def-inline cl:minusp :always (t) :bool "ecl_minusp(#0)") + (def-inline cl:minusp :always (fixnum-float) :bool "(#0)<0") + + (def-inline cl:oddp :always (t) :bool "ecl_oddp(#0)") + (def-inline cl:oddp :always (fixnum fixnum) :bool "(#0) & 1") + + (def-inline cl:evenp :always (t) :bool "ecl_evenp(#0)") + (def-inline cl:evenp :always (fixnum fixnum) :bool "~(#0) & 1") + + (def-inline cl:abs :always (t t) t "ecl_abs(#0,#1)") + (def-inline cl:exp :always (t) t "ecl_exp(#0)") + + (def-inline cl:expt :always (t t) t "ecl_expt(#0,#1)") + (def-inline cl:expt :always ((integer 2 2) (integer 0 29)) :fixnum "(1<<(#1))") + (def-inline cl:expt :always ((integer 0 0) t) :fixnum "0") + (def-inline cl:expt :always ((integer 1 1) t) :fixnum "1") + (def-inline cl:expt :always ((long-float 0.0l0 *) long-float) :long-double "powl((long double)#0,(long double)#1)") + (def-inline cl:expt :always ((double-float 0.0d0 *) double-float) :double "pow((double)#0,(double)#1)") + (def-inline cl:expt :always ((single-float 0.0f0 *) single-float) :float "powf((float)#0,(float)#1)") + (when (member :complex-float *features*) + (def-inline cl:expt :always (si:complex-single-float si:complex-single-float) :csfloat "cpowf(#0,#1)") + (def-inline cl:expt :always (si:complex-double-float si:complex-double-float) :cdfloat "cpow(#0,#1)") + (def-inline cl:expt :always (si:complex-long-float si:complex-long-float) :clfloat "cpowl(#0,#1)")) + + (def-inline cl:log :always (fixnum-float) :long-double "logl((long double)(#0))" :exact-return-type t) + (def-inline cl:log :always (fixnum-float) :double "log((double)(#0))" :exact-return-type t) + (def-inline cl:log :always (fixnum-float) :float "logf((float)(#0))" :exact-return-type t) + (when (member :complex-float *features*) + (def-inline cl:log :always (si:complex-single-float) :csfloat "clogf(#0)") + (def-inline cl:log :always (si:complex-double-float) :cdfloat "clog(#0)") + (def-inline cl:log :always (si:complex-long-float) :clfloat "clogl(#0)")) + + (def-inline cl:sqrt :always (number) number "ecl_sqrt(#0)") + (def-inline cl:sqrt :always ((long-float 0.0l0 *)) :long-double "sqrtl((long double)(#0))") + (def-inline cl:sqrt :always ((double-float 0.0d0 *)) :double "sqrt((double)(#0))") + (def-inline cl:sqrt :always ((single-float 0.0f0 *)) :float "sqrtf((float)(#0))") + (when (member :complex-float *features*) + (def-inline cl:sqrt :always (si:complex-single-float) :csfloat "csqrtf(#0)") + (def-inline cl:sqrt :always (si:complex-double-float) :cdfloat "csqrt(#0)") + (def-inline cl:sqrt :always (si:complex-long-float) :clfloat "csqrtl(#0)")) + + (def-inline cl:sin :always (number) number "ecl_sin(#0)") + (def-inline cl:sin :always (fixnum-float) :long-double "sinl((long double)(#0))" :exact-return-type t) + (def-inline cl:sin :always (fixnum-float) :double "sin((double)(#0))" :exact-return-type t) + (def-inline cl:sin :always (fixnum-float) :float "sinf((float)(#0))" :exact-return-type t) + (when (member :complex-float *features*) + (def-inline cl:sin :always (si:complex-single-float) :csfloat "csinf(#0)") + (def-inline cl:sin :always (si:complex-double-float) :cdfloat "csin(#0)") + (def-inline cl:sin :always (si:complex-long-float) :clfloat "csinl(#0)")) + + (def-inline cl:cos :always (t) number "ecl_cos(#0)") + (def-inline cl:cos :always (fixnum-float) :long-double "cosl((long double)(#0))" :exact-return-type t) + (def-inline cl:cos :always (fixnum-float) :double "cos((double)(#0))" :exact-return-type t) + (def-inline cl:cos :always (fixnum-float) :float "cosf((float)(#0))" :exact-return-type t) + (when (member :complex-float *features*) + (def-inline cl:cos :always (si:complex-single-float) :csfloat "ccosf(#0)") + (def-inline cl:cos :always (si:complex-double-float) :cdfloat "ccos(#0)") + (def-inline cl:cos :always (si:complex-long-float) :clfloat "ccosl(#0)")) + + (def-inline cl:tan :always (t) number "ecl_tan(#0)") + (def-inline cl:tan :always (fixnum-float) :long-double "tanl((long double)(#0))" :exact-return-type t) + (def-inline cl:tan :always (fixnum-float) :double "tan((double)(#0))" :exact-return-type t) + (def-inline cl:tan :always (fixnum-float) :float "tanf((float)(#0))" :exact-return-type t) + (when (member :complex-float *features*) + (def-inline cl:tan :always (si:complex-single-float) :csfloat "ctanf(#0)") + (def-inline cl:tan :always (si:complex-double-float) :cdfloat "ctan(#0)") + (def-inline cl:tan :always (si:complex-long-float) :clfloat "ctanl(#0)")) + + (def-inline cl:sinh :always (t) number "ecl_sinh(#0)") + (def-inline cl:sinh :always (fixnum-float) :long-double "sinhl((long double)(#0))" :exact-return-type t) + (def-inline cl:sinh :always (fixnum-float) :double "sinh((double)(#0))" :exact-return-type t) + (def-inline cl:sinh :always (fixnum-float) :float "sinhf((float)(#0))" :exact-return-type t) + (when (member :complex-float *features*) + (def-inline cl:sinh :always (si:complex-single-float) :csfloat "csinhf(#0)") + (def-inline cl:sinh :always (si:complex-double-float) :cdfloat "csinh(#0)") + (def-inline cl:sinh :always (si:complex-long-float) :clfloat "csinhl(#0)")) + + (def-inline cl:cosh :always (t) number "ecl_cosh(#0)") + (def-inline cl:cosh :always (fixnum-float) :long-double "coshl((long double)(#0))" :exact-return-type t) + (def-inline cl:cosh :always (fixnum-float) :double "cosh((double)(#0))" :exact-return-type t) + (def-inline cl:cosh :always (fixnum-float) :float "coshf((float)(#0))" :exact-return-type t) + (when (member :complex-float *features*) + (def-inline cl:cosh :always (si:complex-single-float) :csfloat "ccoshf(#0)") + (def-inline cl:cosh :always (si:complex-double-float) :cdfloat "ccosh(#0)") + (def-inline cl:cosh :always (si:complex-long-float) :clfloat "ccoshl(#0)")) + + (def-inline cl:tanh :always (t) number "ecl_tanh(#0)") + (def-inline cl:tanh :always (fixnum-float) :long-double "tanhl((long double)(#0))" :exact-return-type t) + (def-inline cl:tanh :always (fixnum-float) :double "tanh((double)(#0))" :exact-return-type t) + (def-inline cl:tanh :always (fixnum-float) :float "tanhf((float)(#0))" :exact-return-type t) + (when (member :complex-float *features*) + (def-inline cl:tanh :always (si:complex-single-float) :csfloat "ctanhf(#0)") + (def-inline cl:tanh :always (si:complex-double-float) :cdfloat "ctanh(#0)") + (def-inline cl:tanh :always (si:complex-long-float) :clfloat "ctanhl(#0)")) + + ;; file package.d + + ;; file pathname.d + + (def-inline cl:null :always (t) :bool "#0==ECL_NIL") + (def-inline cl:symbolp :always (t) :bool "@0;ECL_SYMBOLP(#0)") + (def-inline cl:atom :always (t) :bool "@0;ECL_ATOM(#0)") + (def-inline cl:consp :always (t) :bool "@0;ECL_CONSP(#0)") + (def-inline cl:listp :always (t) :bool "@0;ECL_LISTP(#0)") + (def-inline cl:numberp :always (t) :bool "ecl_numberp(#0)") + (def-inline cl:integerp :always (t) :bool "@0;ECL_FIXNUMP(#0)||ECL_BIGNUMP(#0)") + (def-inline cl:floatp :always (t) :bool "floatp(#0)") + (def-inline cl:characterp :always (t) :bool "ECL_CHARACTERP(#0)") + (def-inline si:base-char-p :always (character) :bool "ECL_BASE_CHAR_P(#0)") + (def-inline cl:stringp :always (t) :bool "@0;ECL_STRINGP(#0)") + (def-inline si:base-string-p :always (t) :bool "@0;ECL_BASE_STRING_P(#0)") + (def-inline cl:bit-vector-p :always (t) :bool "@0;ECL_BIT_VECTOR_P(#0)") + (def-inline cl:vectorp :always (t) :bool "@0;ECL_VECTORP(#0)") + (def-inline cl:arrayp :always (t) :bool "@0;ECL_ARRAYP(#0)") + + (def-inline cl:eq :always (t t) :bool "(#0)==(#1)") + (def-inline cl:eq :always (fixnum fixnum) :bool "(#0)==(#1)") + + (def-inline cl:eql :always (t t) :bool "ecl_eql(#0,#1)") + (def-inline cl:eql :always (character t) :bool "(ECL_CODE_CHAR(#0)==(#1))") + (def-inline cl:eql :always (t character) :bool "((#0)==ECL_CODE_CHAR(#1))") + (def-inline cl:eql :always (character character) :bool "(#0)==(#1)") + (def-inline cl:eql :always ((not (or complex bignum ratio float)) t) :bool "(#0)==(#1)") + (def-inline cl:eql :always (t (not (or complex bignum ratio float))) :bool "(#0)==(#1)") + (def-inline cl:eql :always (fixnum fixnum) :bool "(#0)==(#1)") + + (def-inline cl:equal :always (t t) :bool "ecl_equal(#0,#1)") + (def-inline cl:equal :always (fixnum fixnum) :bool "(#0)==(#1)") + + (def-inline cl:equalp :always (t t) :bool "ecl_equalp(#0,#1)") + (def-inline cl:equalp :always (fixnum fixnum) :bool "(#0)==(#1)") + + (def-inline cl:not :always (t) :bool "(#0)==ECL_NIL") + + ;; file print.d, read.d + + (def-inline cl:clear-output :always (stream) NULL "(ecl_clear_output(#0),ECL_NIL)") + (def-inline cl:finish-output :always (stream) NULL "(ecl_finish_output(#0),ECL_NIL)") + (def-inline cl:finish-output :always (stream) NULL "(ecl_force_output(#0),ECL_NIL)") + (def-inline cl:write-char :always (t) t "@0;(ecl_princ_char(ecl_char_code(#0),ECL_NIL),(#0))") + (def-inline cl:clear-input :always (stream) NULL "(ecl_clear_input(#0),ECL_NIL)") + (def-inline cl:copy-readtable :always (null null) t "standard_readtable") + + (def-inline cl:boundp :always (t) :bool "ecl_boundp(cl_env_copy,#0)") + (def-inline cl:boundp :unsafe ((and symbol (not null))) :bool "ECL_SYM_VAL(cl_env_copy,#0)!=OBJNULL") + + ;; file unixsys.d + + ;; file sequence.d + + (def-inline cl:elt :always (t t) t "ecl_elt(#0,ecl_to_size(#1))") + (def-inline cl:elt :always (t fixnum) t "ecl_elt(#0,#1)") + (def-inline cl:elt :unsafe (t t) t "ecl_elt(#0,ecl_fixnum(#1))") + (def-inline cl:elt :unsafe (t fixnum) t "ecl_elt(#0,#1)") + (def-inline cl:elt :unsafe (vector t) t "ecl_aref_unsafe(#0,ecl_fixnum(#1))") + (def-inline cl:elt :unsafe (vector fixnum) t "ecl_aref_unsafe(#0,#1)") + (def-inline cl:aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,ecl_fixnum(#1))") + (def-inline cl:aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") + (when (member :unicode *features*) + (def-inline cl:aref :unsafe ((array character) fixnum) :wchar "(#0)->string.self[#1]")) + (def-inline cl:aref :unsafe ((array base-char) fixnum) :unsigned-char "(#0)->base_string.self[#1]") + (def-inline cl:aref :unsafe ((array double-float) fixnum) :double "(#0)->array.self.df[#1]") + (def-inline cl:aref :unsafe ((array single-float) fixnum) :float "(#0)->array.self.sf[#1]") + (def-inline cl:aref :unsafe ((array fixnum) fixnum) :fixnum "(#0)->array.self.fix[#1]") + + (def-inline si:elt-set :always (t t t) t "ecl_elt_set(#0,ecl_to_size(#1),#2)") + (def-inline si:elt-set :always (t fixnum t) t "ecl_elt_set(#0,#1,#2)") + (def-inline si:elt-set :unsafe (t t t) t "ecl_elt_set(#0,ecl_fixnum(#1),#2)") + (def-inline si:elt-set :unsafe (vector t t) t "ecl_aset_unsafe(#0,ecl_to_size(#1),#2)") + (def-inline si:elt-set :unsafe (vector fixnum t) t "ecl_aset_unsafe(#0,#1,#2)") + + (def-inline cl:length :always (t) :fixnum "ecl_length(#0)") + (def-inline cl:length :unsafe (vector) :fixnum "(#0)->vector.fillp") + + (def-inline cl:copy-seq :always (t) t "ecl_copy_seq(#0)") + + ;; file character.d + + (def-inline cl:char :always (t fixnum) t "ecl_aref1(#0,#1)") + (def-inline cl:char :always (t fixnum) :wchar "ecl_char(#0,#1)") + (if (member :unicode *features*) + (def-inline cl:char :unsafe (ext:extended-string fixnum) :wchar "(#0)->string.self[#1]") + (progn + (def-inline cl:char :unsafe (t t) t "ECL_CODE_CHAR((#0)->base_string.self[ecl_fixnum(#1)])") + (def-inline cl:char :unsafe (t fixnum) :unsigned-char "(#0)->base_string.self[#1]"))) + (def-inline cl:char :unsafe (base-string fixnum) :unsigned-char "(#0)->base_string.self[#1]") + + (def-inline si:char-set :always (t t t) t "si_char_set(#0,#1,#2)") + (def-inline si:char-set :always (t fixnum t) t "ecl_aset1(#0,#1,#2)") + (def-inline si:char-set :always (t fixnum character) :wchar "ecl_char_set(#0,#1,#2)") + + (unless (member :unicode *features*) + (def-inline si:char-set :unsafe (t t t) t "@2;((#0)->base_string.self[ecl_fixnum(#1)]=ecl_char_code(#2),(#2))") + (def-inline si:char-set :unsafe (t fixnum character) :unsigned-char "(#0)->base_string.self[#1]= #2")) + (def-inline si:char-set :unsafe (base-string t t) t "@2;((#0)->base_string.self[ecl_fixnum(#1)]=ecl_char_code(#2),(#2))") + (def-inline si:char-set :unsafe (base-string fixnum base-char) :unsigned-char "(#0)->base_string.self[#1]= #2") + (def-inline si:char-set :unsafe (ext:extended-string t t) t "@2;((#0)->string.self[ecl_fixnum(#1)]=ecl_char_code(#2),(#2))") + (def-inline si:char-set :unsafe (ext:extended-string fixnum character) :unsigned-char "(#0)->string.self[#1]= #2") + + (def-inline cl:schar :always (t t) t "ecl_elt(#0,ecl_to_size(#1))") + (def-inline cl:schar :always (t fixnum) t "ecl_elt(#0,#1)") + (def-inline cl:schar :always (t fixnum) :wchar "ecl_char(#0,#1)") + (def-inline cl:schar :unsafe (base-string t) t "ECL_CODE_CHAR((#0)->base_string.self[ecl_fixnum(#1)])") + (def-inline cl:schar :unsafe (base-string fixnum) :unsigned-char "(#0)->base_string.self[#1]") + (if (member :unicode *features*) + (def-inline cl:schar :unsafe (ext:extended-string fixnum) :wchar "(#0)->string.self[#1]") + (def-inline cl:schar :unsafe (t fixnum) :unsigned-char "(#0)->base_string.self[#1]")) + (def-inline si:schar-set :always (t t t) t "ecl_elt_set(#0,ecl_to_size(#1),#2)") + (def-inline si:schar-set :always (t fixnum t) t "ecl_elt_set(#0,#1,#2)") + (def-inline si:schar-set :always (t fixnum character) :wchar "ecl_char_set(#0,#1,#2)") + (if (member :unicode *features*) + (progn + (def-inline si:schar-set :unsafe (ext:extended-string fixnum t) :wchar "@2;((#0)->string.self[#1]= ecl_char_code(#2),(#2))") + (def-inline si:schar-set :unsafe (ext:extended-string fixnum character) :wchar "(#0)->string.self[#1]= #2")) + (progn + (def-inline si:schar-set :unsafe (t t t) t "@2;((#0)->base_string.self[ecl_fixnum(#1)]=ecl_char_code(#2),(#2))") + (def-inline si:schar-set :unsafe (t fixnum base-char) :unsigned-char "(#0)->base_string.self[#1]= #2"))) + (def-inline si:schar-set :unsafe (base-string t t) t "@2;((#0)->base_string.self[ecl_fixnum(#1)]=ecl_char_code(#2),(#2))") + (def-inline si:schar-set :unsafe (base-string fixnum base-char) :unsigned-char "(#0)->base_string.self[#1]= #2") + + (def-inline cl:string= :always (string string) :bool "ecl_string_eq(#0,#1)") + + ;; file structure.d + + (def-inline si:structure-name :always (structure-object) symbol "ECL_STRUCT_NAME(#0)") + (def-inline si:structure-ref :always (t t fixnum) t "ecl_structure_ref(#0,#1,#2)") + (def-inline si:structure-set :always (t t fixnum t) t "ecl_structure_set(#0,#1,#2,#3)") + + ;; file symbol.d + + (def-inline cl:get :always (t t t) t "ecl_get(#0,#1,#2)") + (def-inline cl:get :always (t t) t "ecl_get(#0,#1,ECL_NIL)") + + (def-inline cl:symbol-name :always (t) string "ecl_symbol_name(#0)") + + ;; Additions used by the compiler. + ;; The following functions do not exist. They are always expanded into the + ;; given C code. References to these functions are generated in the C1 phase. + + (def-inline shift>> :always (fixnum fixnum) :fixnum "((#0) >> (- (#1)))") + (def-inline shift<< :always (fixnum fixnum) :fixnum "((#0) << (#1))") + + (def-inline si:short-float-p :always (t) :bool "@0;ECL_SINGLE_FLOAT_P(#0)") + (def-inline si:single-float-p :always (t) :bool "@0;ECL_SINGLE_FLOAT_P(#0)") + (def-inline si:double-float-p :always (t) :bool "@0;ECL_DOUBLE_FLOAT_P(#0)") + (def-inline si:long-float-p :always (t) :bool "@0;ECL_LONG_FLOAT_P(#0)") + + (when (member :complex-float *features*) + (def-inline si::complex-single-float-p :always (t) :bool "@0;ECL_COMPLEX_SINGLE_FLOAT_P(#0)") + (def-inline si::complex-double-float-p :always (t) :bool "@0;ECL_COMPLEX_DOUBLE_FLOAT_P(#0)") + (def-inline si::complex-long-float-p :always (t) :bool "@0;ECL_COMPLEX_LONG_FLOAT_P(#0)")) + + (def-inline ext:fixnump :always (t) :bool "ECL_FIXNUMP(#0)") + (def-inline ext:fixnump :always (fixnum) :bool "1") + + ;; Functions only available with threads + (when (member :threads *features*) + (def-inline mp:lock-count :unsafe (mp:lock) fixnum "((#0)->lock.counter)") + (def-inline mp:compare-and-swap-car :always (cons t t) t "ecl_compare_and_swap(&ECL_CONS_CAR(#0),(#1),(#2))") + (def-inline mp:atomic-incf-car :always (cons t) t "ecl_atomic_incf(&ECL_CONS_CAR(#0),(#1))") + (def-inline mp:atomic-incf-car :always (cons fixnum) t "ecl_atomic_incf_by_fixnum(&ECL_CONS_CAR(#0),(#1))") + + (def-inline mp:compare-and-swap-cdr :always (cons t t) t "ecl_compare_and_swap(&ECL_CONS_CDR(#0),(#1),(#2))") + (def-inline mp:atomic-incf-cdr :always (cons t) t "ecl_atomic_incf(&ECL_CONS_CDR(#0),(#1))") + (def-inline mp:atomic-incf-cdr :always (cons fixnum) t "ecl_atomic_incf_by_fixnum(&ECL_CONS_CDR(#0),(#1))") + + (def-inline mp:compare-and-swap-symbol-value :unsafe (symbol t t) t "ecl_compare_and_swap(ecl_bds_ref(ecl_process_env(),(#0)),(#1),(#2))") + (def-inline mp:atomic-incf-symbol-value :always (t fixnum) t "ecl_atomic_incf_by_fixnum(ecl_bds_ref(ecl_process_env(),(#0)),(#1))") + (def-inline mp:atomic-incf-symbol-value :unsafe (symbol t) t "ecl_atomic_incf(ecl_bds_ref(ecl_process_env(),(#0)),(#1))") + (def-inline mp:atomic-incf-symbol-value :unsafe (symbol fixnum) t "ecl_atomic_incf_by_fixnum(ecl_bds_ref(ecl_process_env(),(#0)),(#1))") + + (def-inline mp:compare-and-swap-svref :unsafe (t t t t) t "ecl_compare_and_swap((#0)->vector.self.t + ecl_fixnum(#1),(#2),(#3))") + (def-inline mp:compare-and-swap-svref :unsafe (t fixnum t t) t "ecl_compare_and_swap((#0)->vector.self.t + (#1),(#2),(#3))") + + ;; :threads are implicit + (when (member :clos *features*) + (def-inline mp:compare-and-swap-instance :always (t fixnum t t) t "ecl_compare_and_swap_instance((#0),(#1),(#2),(#3))") + (def-inline mp:compare-and-swap-instance :unsafe (standard-object fixnum t t) t "ecl_compare_and_swap((#0)->instance.slots+(#1),(#2),(#3))") + (def-inline mp:atomic-incf-instance :always (t fixnum t) t "ecl_atomic_incf_instance((#0),(#1),(#2))") + (def-inline mp:atomic-incf-instance :unsafe (standard-object fixnum t) t "ecl_atomic_incf((#0)->instance.slots+(#1),(#2))") + (def-inline mp:atomic-incf-instance :unsafe (standard-object fixnum fixnum) t "ecl_atomic_incf_by_fixnum((#0)->instance.slots+(#1),(#2))")) + + (def-inline mp:compare-and-swap-structure :unsafe (structure-object t fixnum t t) t "ecl_compare_and_swap(&(ECL_STRUCT_SLOT((#0),(#2))),(#3),(#4))")) + + ;; Functions only available with CLOS + (when (member :clos *features*) + (def-inline si:instance-ref :always (t fixnum) t "ecl_instance_ref((#0),(#1))") + (def-inline si:instance-ref :unsafe (standard-object fixnum) t "(#0)->instance.slots[#1]") + (def-inline si::instance-slotds :unsafe (standard-object) list "(#0)->instance.slotds") + + (def-inline si:instance-set :unsafe (t fixnum t) t "ecl_instance_set((#0),(#1),(#2))") + (def-inline si:instance-set :unsafe (standard-object fixnum t) t "(#0)->instance.slots[#1]=(#2)") + + (def-inline si:instance-class :always (standard-object) t "ECL_CLASS_OF(#0)") + (def-inline cl:class-of :unsafe (standard-object) t "ECL_CLASS_OF(#0)") + + (def-inline si:instancep :always (t) :bool "@0;ECL_INSTANCEP(#0)") + (def-inline si:unbound :always nil t "ECL_UNBOUND") + + (def-inline si:sl-boundp :always (t) :bool "(#0)!=ECL_UNBOUND") + + (def-inline clos:standard-instance-access :always (t fixnum) t "ecl_instance_ref((#0),(#1))") + (def-inline clos:standard-instance-access :unsafe (standard-object fixnum) t "(#0)->instance.slots[#1]") + + (def-inline clos:funcallable-standard-instance-access :always (t fixnum) t "ecl_instance_ref((#0),(#1))") + (def-inline clos:funcallable-standard-instance-access :unsafe (clos:funcallable-standard-object fixnum) t "(#0)->instance.slots[#1]")) + + *inline-information*)) diff --git a/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp b/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp index c08286b31..e35189339 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-inliner.lsp @@ -5,18 +5,18 @@ ;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. ;;;; Copyright (c) 1990, Giuseppe Attardi. ;;;; -;;;; This program is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. +;;;; See the file 'LICENSE' for the copyright details. ;;;; -;;;; See file '../Copyright' for full details. + ;;;; -;;;; CMPC-INLINER -- Open coding functions as C expressions +;;;; Open coding functions as C expressions. ;;;; (in-package "COMPILER") +(setf (machine-inline-information *default-machine*) + (make-inline-information *default-machine*)) + (defun inlined-arg-loc (arg) (second arg)) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp index 5bed4952f..9d828aa40 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp @@ -156,33 +156,29 @@ ;; either because it has been proclaimed so, or because it belongs ;; to the runtime. (multiple-value-bind (found fd minarg maxarg) - (si::mangle-name fname t) + (si:mangle-name fname t) (when found (return-from call-global-loc - (call-exported-function-loc fname args fd minarg maxarg t - return-type)))) + (call-exported-function-loc fname args fd minarg maxarg t return-type)))) (when (policy-use-direct-C-call) - (let ((fd (si:get-sysprop fname 'Lfun))) - (when fd - (multiple-value-bind (minarg maxarg found) (get-proclaimed-narg fname) + (ext:when-let ((fd (si:get-sysprop fname 'Lfun))) + (multiple-value-bind (minarg maxarg found) (get-proclaimed-narg fname) + (unless found + ;; Without knowing the number of arguments we cannot call the C + ;; function. When compiling ECL itself, we get this information + ;; through si::mangle-name from symbols_list.h for core functions + ;; defined in Lisp code. #+ecl-min + (let (ignored) + (multiple-value-setq (found ignored minarg maxarg) + (si:mangle-name fname))) (unless found - ;; Without knowing the number of arguments we cannot call - ;; the C function. When compiling ECL itself, we get this - ;; information through si::mangle-name from symbols_list.h - ;; for core functions defined in Lisp code. - (let (ignored) - (multiple-value-setq (found ignored minarg maxarg) - (si::mangle-name fname)))) - (unless found - (cmperr "Can not call the function ~A using its exported C name ~A because its function type has not been proclaimed" - fname fd)) - (return-from call-global-loc - (call-exported-function-loc - fname args fd minarg maxarg - (si::mangle-name fname) - return-type)))))) + (cmperr "Can not call the function ~A using its exported C name ~A because its function type has not been proclaimed." + fname fd))) + (return-from call-global-loc + (call-exported-function-loc fname args fd minarg maxarg + (si:mangle-name fname) return-type))))) (call-unknown-global-loc fname nil args)) diff --git a/src/cmp/cmpenv-proclaim.lsp b/src/cmp/cmpenv-proclaim.lsp index de0bcc6f4..77c60cebf 100644 --- a/src/cmp/cmpenv-proclaim.lsp +++ b/src/cmp/cmpenv-proclaim.lsp @@ -79,14 +79,14 @@ (dolist (x (cdr decl)) (cond ((symbolp x) (multiple-value-bind (found c-name) - (si::mangle-name x t) + (si:mangle-name x t) (if found - (warn "The function ~s is already in the runtime.~%C-EXPORT-FNAME declaration ignored." x) + (error "The function ~s is already in the runtime.~%C-EXPORT-FNAME declaration ignored." x) (si:put-sysprop x 'Lfun c-name)))) ((consp x) (destructuring-bind (c-name lisp-name) x - (if (si::mangle-name lisp-name) - (warn "The function ~s is already in the runtime.~%C-EXPORT-FNAME declaration ignored." lisp-name) + (if (si:mangle-name lisp-name) + (error "The function ~s is already in the runtime.~%C-EXPORT-FNAME declaration ignored." lisp-name) (si:put-sysprop lisp-name 'Lfun c-name)))) (t (error "Syntax error in proclamation ~s" decl))))) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 0d1e19050..c65412987 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -153,12 +153,6 @@ :format-control "The expansion of the compiler macro~%~T~A~%was aborted because of a serious condition~%~A" :format-arguments (list fname c)) (values nil nil)))) -(defun si::compiler-clear-compiler-properties (symbol) - (si:rem-sysprop symbol 't1) - (si:rem-sysprop symbol 't2) - (si:rem-sysprop symbol 't3) - (si:rem-sysprop symbol 'lfun)) - (defun lisp-to-c-name (obj) "Translate Lisp object prin1 representation to valid C identifier name" (and obj diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index a137936ea..e5cf4b1e6 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -48,6 +48,8 @@ "src:cmp;cmpbackend-cxx;cmpc-util.lsp" "src:cmp;cmpbackend-cxx;cmpc-mach.lsp" "src:cmp;cmpbackend-cxx;cmpc-wt.lsp" + "src:cmp;cmpbackend-cxx;cmpc-inl-sysfun.lsp" + "src:cmp;cmpbackend-cxx;cmpc-inl-lspfun.lsp" "src:cmp;cmpbackend-cxx;cmpc-inliner.lsp" "src:cmp;cmpbackend-cxx;cmpc-opt-inl.lsp" "src:cmp;cmpbackend-cxx;cmpc-opt-num.lsp" @@ -80,7 +82,6 @@ "src:cmp;cmpclos.lsp" ;unused "src:cmp;cmpstructures.lsp" ;unused "src:cmp;cmparray.lsp" - "src:cmp;sysfun.lsp" ;; Other "src:cmp;cmpos-run.lsp" "src:cmp;cmpos-features.lsp" diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp deleted file mode 100644 index 7204932c5..000000000 --- a/src/cmp/sysfun.lsp +++ /dev/null @@ -1,1123 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; -;;; CMPSYSFUN Database for system functions. -;;; -;;; Copyright (c) 2003, Juan Jose Garcia Ripoll -;;; Copyright (c) 1991, Giuseppe Attardi. All rights reserved. -;;; Copying of this file is authorized to users who have executed the true -;;; and proper "License Agreement for ECoLisp". -;;; -;;; DATABASE OF INLINE EXPANSIONS -;;; -;;; (DEF-INLINE function-name kind ([arg-type]*) return-rep-type -;;; expansion-string) -;;; -;;; Here, ARG-TYPE is the list of argument types belonging to the lisp family, -;;; while RETURN-REP-TYPE is a representation type, i.e. the C type of the -;;; output expression. EXPANSION-STRING is a C/C++ expression template, like the -;;; ones used by C-INLINE. Finally, KIND can be :ALWAYS, :SAFE or :UNSAFE, -;;; depending on whether the inline expression should be applied always, in safe -;;; or in unsafe compilation mode, respectively. -;;; - -(in-package "COMPILER") - -(eval-when (:compile-toplevel :execute) -(defparameter +inline-forms+ '( -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; ALL FUNCTION DECLARATIONS AND INLINE FORMS -;;; - -(def-inline cl:aref :unsafe (t t t) t "@0;ecl_aref_unsafe(#0,ecl_fixnum(#1)*(#0)->array.dims[1]+ecl_fixnum(#2))") -(def-inline cl:aref :unsafe ((array t) t t) t "@0;(#0)->array.self.t[ecl_fixnum(#1)*(#0)->array.dims[1]+ecl_fixnum(#2)]") -(def-inline cl:aref :unsafe ((array bit) t t) :fixnum "@0;ecl_aref_bv(#0,ecl_fixnum(#1)*(#0)->array.dims[1]+ecl_fixnum(#2))") -(def-inline cl:aref :unsafe ((array t) fixnum fixnum) t "@0;(#0)->array.self.t[#1*(#0)->array.dims[1]+#2]") -(def-inline cl:aref :unsafe ((array bit) fixnum fixnum) :fixnum "@0;ecl_aref_bv(#0,(#1)*(#0)->array.dims[1]+#2)") -(def-inline cl:aref :unsafe ((array base-char) fixnum fixnum) :unsigned-char "@0;(#0)->base_string.self[#1*(#0)->array.dims[1]+#2]") -(def-inline cl:aref :unsafe ((array double-float) fixnum fixnum) :double "@0;(#0)->array.self.df[#1*(#0)->array.dims[1]+#2]") -(def-inline cl:aref :unsafe ((array single-float) fixnum fixnum) :float "@0;(#0)->array.self.sf[#1*(#0)->array.dims[1]+#2]") -(def-inline cl:aref :unsafe ((array long-float) fixnum fixnum) :long-double "@0;(#0)->array.self.lf[#1*(#0)->array.dims[1]+#2]") -#+complex-float (def-inline cl:aref :unsafe ((array si:complex-single-float) fixnum fixnum) :csfloat "@0;(#0)->array.self.csf[#1*(#0)->array.dims[1]+#2]") -#+complex-float (def-inline cl:aref :unsafe ((array si:complex-double-float) fixnum fixnum) :cdfloat "@0;(#0)->array.self.cdf[#1*(#0)->array.dims[1]+#2]") -#+complex-float (def-inline cl:aref :unsafe ((array si:complex-long-float) fixnum fixnum) :clfloat "@0;(#0)->array.self.clf[#1*(#0)->array.dims[1]+#2]") - -(def-inline cl:aref :unsafe ((array fixnum) fixnum fixnum) :fixnum "@0;(#0)->array.self.fix[#1*(#0)->array.dims[1]+#2]") - -(def-inline cl:aref :always (t t) t "ecl_aref1(#0,ecl_to_size(#1))") -(def-inline cl:aref :always (t fixnum) t "ecl_aref1(#0,#1)") -(def-inline cl:aref :unsafe (t t) t "ecl_aref1(#0,ecl_fixnum(#1))") -(def-inline cl:aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,ecl_fixnum(#1))") -(def-inline cl:aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") -#+unicode -(def-inline cl:aref :unsafe ((array character) fixnum) :wchar "(#0)->string.self[#1]") -(def-inline cl:aref :unsafe ((array base-char) fixnum) :unsigned-char "(#0)->base_string.self[#1]") -(def-inline cl:aref :unsafe ((array double-float) fixnum) :double "(#0)->array.self.df[#1]") -(def-inline cl:aref :unsafe ((array single-float) fixnum) :float "(#0)->array.self.sf[#1]") -(def-inline cl:aref :unsafe ((array long-float) fixnum) :long-double "(#0)->array.self.lf[#1]") -#+complex-float (def-inline cl:aref :unsafe ((array si:complex-single-float) fixnum) :csfloat "(#0)->array.self.csf[#1]") -#+complex-float (def-inline cl:aref :unsafe ((array si:complex-double-float) fixnum) :cdfloat "(#0)->array.self.cdf[#1]") -#+complex-float (def-inline cl:aref :unsafe ((array si:complex-long-float) fixnum) :clfloat "(#0)->array.self.clf[#1]") -(def-inline cl:aref :unsafe ((array fixnum) fixnum) :fixnum "(#0)->array.self.fix[#1]") - -(def-inline cl:row-major-aref :always (t t) t "ecl_aref(#0,ecl_to_size(#1))") -(def-inline cl:row-major-aref :always (t fixnum) t "ecl_aref(#0,#1)") -(def-inline cl:row-major-aref :unsafe (t t) t "ecl_aref_unsafe(#0,ecl_fixnum(#1))") -(def-inline cl:row-major-aref :unsafe (t fixnum) t "ecl_aref_unsafe(#0,#1)") -(def-inline cl:row-major-aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,ecl_fixnum(#1))") -(def-inline cl:row-major-aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") -#+unicode -(def-inline cl:row-major-aref :unsafe ((array character) fixnum) :wchar "(#0)->string.self[#1]") -(def-inline cl:row-major-aref :unsafe ((array base-char) fixnum) :unsigned-char "(#0)->base_string.self[#1]") -(def-inline cl:row-major-aref :unsafe ((array ext:byte8) fixnum) :uint8-t "(#0)->vector.self.b8[#1]") -(def-inline cl:row-major-aref :unsafe ((array ext:integer8) fixnum) :int8-t "(#0)->vector.self.i8[#1]") -(def-inline cl:row-major-aref :unsafe ((array ext:byte16) fixnum) :uint16-t "(#0)->vector.self.b16[#1]") -(def-inline cl:row-major-aref :unsafe ((array ext:integer16) fixnum) :int16-t "(#0)->vector.self.i16[#1]") -(def-inline cl:row-major-aref :unsafe ((array ext:byte32) fixnum) :uint32-t "(#0)->vector.self.b32[#1]") -(def-inline cl:row-major-aref :unsafe ((array ext:integer32) fixnum) :int32-t "(#0)->vector.self.i32[#1]") -(def-inline cl:row-major-aref :unsafe ((array ext:byte64) fixnum) :uint64-t "(#0)->vector.self.b64[#1]") -(def-inline cl:row-major-aref :unsafe ((array ext:integer64) fixnum) :int64-t "(#0)->vector.self.i64[#1]") -(def-inline cl:row-major-aref :unsafe ((array long-float) fixnum) :long-double "(#0)->array.self.lf[#1]") -(def-inline cl:row-major-aref :unsafe ((array double-float) fixnum) :double "(#0)->array.self.df[#1]") -(def-inline cl:row-major-aref :unsafe ((array single-float) fixnum) :float "(#0)->array.self.sf[#1]") -#+complex-float (def-inline cl:row-major-aref :unsafe ((array si:complex-single-float) fixnum) :csfloat "(#0)->array.self.csf[#1]") -#+complex-float (def-inline cl:row-major-aref :unsafe ((array si:complex-double-float) fixnum) :cdfloat "(#0)->array.self.cdf[#1]") -#+complex-float (def-inline cl:row-major-aref :unsafe ((array si:complex-long-float) fixnum) :clfloat "(#0)->array.self.clf[#1]") -(def-inline cl:row-major-aref :unsafe ((array fixnum) fixnum) :fixnum "(#0)->array.self.fix[#1]") - -(def-inline si:row-major-aset :always (t t t) t "ecl_aset(#0,ecl_to_size(#1),#2)") -(def-inline si:row-major-aset :always (t fixnum t) t "ecl_aset(#0,#1,#2)") -(def-inline si:row-major-aset :unsafe (t t t) t "ecl_aset_unsafe(#0,ecl_fixnum(#1),#2)") -(def-inline si:row-major-aset :unsafe (t fixnum t) t "ecl_aset_unsafe(#0,#1,#2)") -(def-inline si:row-major-aset :unsafe ((array t) fixnum t) t "(#0)->vector.self.t[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array bit) fixnum t) :fixnum "ecl_aset_bv(#0,#1,ecl_fixnum(#2))") -(def-inline si:row-major-aset :unsafe ((array bit) fixnum fixnum) :fixnum "ecl_aset_bv(#0,#1,#2)") -(def-inline si:row-major-aset :unsafe ((array base-char) fixnum base-char) :unsigned-char "(#0)->base_string.self[#1]= #2") -#+unicode -(def-inline si:row-major-aset :unsafe ((array character) fixnum character) :wchar "(#0)->string.self[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array ext:byte8) fixnum ext:byte8) :uint8-t "(#0)->vector.self.b8[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array ext:integer8) fixnum ext:integer8) :int8-t "(#0)->vector.self.i8[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array ext:byte16) fixnum ext:byte16) :uint16-t "(#0)->vector.self.b16[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array ext:integer16) fixnum ext:integer16) :int16-t "(#0)->vector.self.i16[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array ext:byte32) fixnum ext:byte32) :uint32-t "(#0)->vector.self.b32[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array ext:integer32) fixnum ext:integer32) :int32-t "(#0)->vector.self.i32[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array ext:byte64) fixnum ext:byte64) :uint64-t "(#0)->vector.self.b64[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array ext:integer64) fixnum ext:integer64) :int64-t "(#0)->vector.self.i64[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array long-float) fixnum long-float) :long-double "(#0)->array.self.lf[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array double-float) fixnum double-float) :double "(#0)->array.self.df[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array single-float) fixnum single-float) :float "(#0)->array.self.sf[#1]= #2") -#+complex-float (def-inline si:row-major-aset :unsafe ((array si:complex-single-float) fixnum si:complex-single-float) :csfloat "(#0)->array.self.csf[#1]= #2") -#+complex-float (def-inline si:row-major-aset :unsafe ((array si:complex-double-float) fixnum si:complex-double-float) :cdfloat "(#0)->array.self.cdf[#1]= #2") -#+complex-float (def-inline si:row-major-aset :unsafe ((array si:complex-long-float) fixnum si:complex-long-float) :clfloat "(#0)->array.self.clf[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array fixnum) fixnum fixnum) :fixnum "(#0)->array.self.fix[#1]= #2") - -(def-inline si:copy-subarray :always (array ext:array-index array ext:array-index - ext:array-index) array - "@0;(ecl_copy_subarray(#0,#1,#2,#3,#4),#0)") - -(def-inline cl:array-rank :unsafe (array) :fixnum - "@0;(((#0)->d.t == t_array)?(#0)->array.rank:1)") -(def-inline cl:array-rank :always (array) :fixnum - "ecl_array_rank(#0)") - -(def-inline cl:array-dimension :always (t t) fixnum - "ecl_array_dimension(#0,ecl_to_size(#1))") -(def-inline cl:array-dimension :always (t fixnum) fixnum - "ecl_array_dimension(#0,#1)") - -(def-inline cl:array-total-size :unsafe (t) :fixnum "((#0)->array.dim)") - -(def-inline cl:adjustable-array-p :always (t) :bool "@0;(ECL_ARRAYP(#0)? (void)0: FEtype_error_array(#0),ECL_ADJUSTABLE_ARRAY_P(#0))") -(def-inline cl:adjustable-array-p :unsafe (array) :bool "ECL_ADJUSTABLE_ARRAY_P(#0)") - -(def-inline cl:svref :always (t t) t "ecl_aref1(#0,ecl_to_size(#1))") -(def-inline cl:svref :always (t fixnum) t "ecl_aref1(#0,#1)") -(def-inline cl:svref :unsafe (t t) t "(#0)->vector.self.t[ecl_fixnum(#1)]") -(def-inline cl:svref :unsafe (t fixnum) t "(#0)->vector.self.t[#1]") - -(def-inline si:svset :always (t t t) t "ecl_aset1(#0,ecl_to_size(#1),#2)") -(def-inline si:svset :always (t fixnum t) t "ecl_aset1(#0,#1,#2)") -(def-inline si:svset :unsafe (t t t) t "((#0)->vector.self.t[ecl_fixnum(#1)]=(#2))") -(def-inline si:svset :unsafe (t fixnum t) t "(#0)->vector.self.t[#1]= #2") - -(def-inline cl:array-has-fill-pointer-p :always (t) :bool "@0;(ECL_ARRAYP(#0)?(void)0:FEtype_error_array(#0),ECL_ARRAY_HAS_FILL_POINTER_P(#0))") -(def-inline cl:array-has-fill-pointer-p :unsafe (array) :bool "ECL_ARRAY_HAS_FILL_POINTER_P(#0)") - -(def-inline cl:fill-pointer :unsafe (t) :fixnum "((#0)->vector.fillp)") - - -(def-inline si:fill-pointer-set :unsafe (t fixnum) :fixnum - "((#0)->vector.fillp)=(#1)") - -;; file character.d - -(def-inline cl:standard-char-p :always (character) :bool "ecl_standard_char_p(#0)") - -(def-inline cl:graphic-char-p :always (character) :bool "ecl_graphic_char_p(#0)") - -(def-inline cl:alpha-char-p :always (character) :bool "ecl_alpha_char_p(#0)") - -(def-inline cl:upper-case-p :always (character) :bool "ecl_upper_case_p(#0)") - -(def-inline cl:lower-case-p :always (character) :bool "ecl_lower_case_p(#0)") - -(def-inline cl:both-case-p :always (character) :bool "ecl_both_case_p(#0)") - -(def-inline cl:alphanumericp :always (character) :bool "ecl_alphanumericp(#0)") - -(def-inline cl:char= :always (t t) :bool "ecl_char_code(#0)==ecl_char_code(#1)") -(def-inline cl:char= :always (character character) :bool "(#0)==(#1)") - -(def-inline cl:char/= :always (t t) :bool "ecl_char_code(#0)!=ecl_char_code(#1)") -(def-inline cl:char/= :always (character character) :bool "(#0)!=(#1)") - -(def-inline cl:char< :always (character character) :bool "(#0)<(#1)") - -(def-inline cl:char> :always (character character) :bool "(#0)>(#1)") - -(def-inline cl:char<= :always (character character) :bool "(#0)<=(#1)") - -(def-inline cl:char>= :always (character character) :bool "(#0)>=(#1)") - -(def-inline cl:char-code :always (character) :fixnum "#0") - -(def-inline cl:code-char :always (fixnum) :wchar "#0") - -(def-inline cl:char-upcase :always (base-char) :unsigned-char "ecl_char_upcase(#0)") -(def-inline cl:char-upcase :always (character) :wchar "ecl_char_upcase(#0)") - -(def-inline cl:char-downcase :always (base-char) :unsigned-char "ecl_char_downcase(#0)") -(def-inline cl:char-downcase :always (character) :wchar "ecl_char_downcase(#0)") - -(def-inline cl:char-int :always (character) :fixnum "#0") - -;; file ffi.d - -(def-inline si:foreign-data-p :always (t) :bool "@0;ECL_FOREIGN_DATA_P(#0)") - -;; file file.d - -(def-inline cl:input-stream-p :always (stream) :bool "ecl_input_stream_p(#0)") - -(def-inline cl:output-stream-p :always (stream) :bool "ecl_output_stream_p(#0)") - -;; file hash.d - -(def-inline cl:gethash :always (t t t) t "ecl_gethash_safe(#0,#1,#2)" :multiple-values nil) -(def-inline cl:gethash :always (t t) t "ecl_gethash_safe(#0,#1,ECL_NIL)" :multiple-values nil) -(def-inline cl:hash-table-count :unsafe (hash-table) ext:array-index "ecl_hash_table_count(#0)") - -;; file list.d - -(def-inline cl:car :unsafe (cons) t "ECL_CONS_CAR(#0)") -(def-inline cl:car :unsafe (t) t "_ecl_car(#0)") - -(def-inline si:cons-car :always (t) t "_ecl_car(#0)") -(def-inline si:cons-car :unsafe (t) t "ECL_CONS_CAR(#0)") - -(def-inline cl:cdr :unsafe (cons) t "ECL_CONS_CDR(#0)") -(def-inline cl:cdr :unsafe (t) t "_ecl_cdr(#0)") - -(def-inline si:cons-cdr :always (t) t "_ecl_cdr(#0)") -(def-inline si:cons-cdr :unsafe (t) t "ECL_CONS_CDR(#0)") - -;; BEGIN-GENERATED (gen-cons-sysfun) - -(def-inline cl:car :always (t) t "ecl_car(#0)") -(def-inline cl:car :unsafe (t) t "_ecl_car(#0)") -(def-inline cl:cdr :always (t) t "ecl_cdr(#0)") -(def-inline cl:cdr :unsafe (t) t "_ecl_cdr(#0)") -(def-inline cl:caar :always (t) t "ecl_caar(#0)") -(def-inline cl:caar :unsafe (t) t "_ecl_caar(#0)") -(def-inline cl:cdar :always (t) t "ecl_cdar(#0)") -(def-inline cl:cdar :unsafe (t) t "_ecl_cdar(#0)") -(def-inline cl:cadr :always (t) t "ecl_cadr(#0)") -(def-inline cl:cadr :unsafe (t) t "_ecl_cadr(#0)") -(def-inline cl:cddr :always (t) t "ecl_cddr(#0)") -(def-inline cl:cddr :unsafe (t) t "_ecl_cddr(#0)") -(def-inline cl:caaar :always (t) t "ecl_caaar(#0)") -(def-inline cl:caaar :unsafe (t) t "_ecl_caaar(#0)") -(def-inline cl:cdaar :always (t) t "ecl_cdaar(#0)") -(def-inline cl:cdaar :unsafe (t) t "_ecl_cdaar(#0)") -(def-inline cl:cadar :always (t) t "ecl_cadar(#0)") -(def-inline cl:cadar :unsafe (t) t "_ecl_cadar(#0)") -(def-inline cl:cddar :always (t) t "ecl_cddar(#0)") -(def-inline cl:cddar :unsafe (t) t "_ecl_cddar(#0)") -(def-inline cl:caadr :always (t) t "ecl_caadr(#0)") -(def-inline cl:caadr :unsafe (t) t "_ecl_caadr(#0)") -(def-inline cl:cdadr :always (t) t "ecl_cdadr(#0)") -(def-inline cl:cdadr :unsafe (t) t "_ecl_cdadr(#0)") -(def-inline cl:caddr :always (t) t "ecl_caddr(#0)") -(def-inline cl:caddr :unsafe (t) t "_ecl_caddr(#0)") -(def-inline cl:cdddr :always (t) t "ecl_cdddr(#0)") -(def-inline cl:cdddr :unsafe (t) t "_ecl_cdddr(#0)") -(def-inline cl:caaaar :always (t) t "ecl_caaaar(#0)") -(def-inline cl:caaaar :unsafe (t) t "_ecl_caaaar(#0)") -(def-inline cl:cdaaar :always (t) t "ecl_cdaaar(#0)") -(def-inline cl:cdaaar :unsafe (t) t "_ecl_cdaaar(#0)") -(def-inline cl:cadaar :always (t) t "ecl_cadaar(#0)") -(def-inline cl:cadaar :unsafe (t) t "_ecl_cadaar(#0)") -(def-inline cl:cddaar :always (t) t "ecl_cddaar(#0)") -(def-inline cl:cddaar :unsafe (t) t "_ecl_cddaar(#0)") -(def-inline cl:caadar :always (t) t "ecl_caadar(#0)") -(def-inline cl:caadar :unsafe (t) t "_ecl_caadar(#0)") -(def-inline cl:cdadar :always (t) t "ecl_cdadar(#0)") -(def-inline cl:cdadar :unsafe (t) t "_ecl_cdadar(#0)") -(def-inline cl:caddar :always (t) t "ecl_caddar(#0)") -(def-inline cl:caddar :unsafe (t) t "_ecl_caddar(#0)") -(def-inline cl:cdddar :always (t) t "ecl_cdddar(#0)") -(def-inline cl:cdddar :unsafe (t) t "_ecl_cdddar(#0)") -(def-inline cl:caaadr :always (t) t "ecl_caaadr(#0)") -(def-inline cl:caaadr :unsafe (t) t "_ecl_caaadr(#0)") -(def-inline cl:cdaadr :always (t) t "ecl_cdaadr(#0)") -(def-inline cl:cdaadr :unsafe (t) t "_ecl_cdaadr(#0)") -(def-inline cl:cadadr :always (t) t "ecl_cadadr(#0)") -(def-inline cl:cadadr :unsafe (t) t "_ecl_cadadr(#0)") -(def-inline cl:cddadr :always (t) t "ecl_cddadr(#0)") -(def-inline cl:cddadr :unsafe (t) t "_ecl_cddadr(#0)") -(def-inline cl:caaddr :always (t) t "ecl_caaddr(#0)") -(def-inline cl:caaddr :unsafe (t) t "_ecl_caaddr(#0)") -(def-inline cl:cdaddr :always (t) t "ecl_cdaddr(#0)") -(def-inline cl:cdaddr :unsafe (t) t "_ecl_cdaddr(#0)") -(def-inline cl:cadddr :always (t) t "ecl_cadddr(#0)") -(def-inline cl:cadddr :unsafe (t) t "_ecl_cadddr(#0)") -(def-inline cl:cddddr :always (t) t "ecl_cddddr(#0)") -(def-inline cl:cddddr :unsafe (t) t "_ecl_cddddr(#0)") -;; END-GENERATED - -(def-inline cl:cons :always (t t) t "CONS(#0,#1)") - -(def-inline cl:endp :safe (t) :bool "ecl_endp(#0)") -(def-inline cl:endp :unsafe (t) :bool "#0==ECL_NIL") - -(def-inline cl:nth :always (t t) t "ecl_nth(ecl_to_size(#0),#1)") -(def-inline cl:nth :always (fixnum t) t "ecl_nth(#0,#1)") -(def-inline cl:nth :unsafe (t t) t "ecl_nth(ecl_fixnum(#0),#1)") -(def-inline cl:nth :unsafe (fixnum t) t "ecl_nth(#0,#1)") - -(def-inline cl:nthcdr :always (t t) t "ecl_nthcdr(ecl_to_size(#0),#1)") -(def-inline cl:nthcdr :always (fixnum t) t "ecl_nthcdr(#0,#1)") -(def-inline cl:nthcdr :unsafe (t t) t "ecl_nthcdr(ecl_fixnum(#0),#1)") -(def-inline cl:nthcdr :unsafe (fixnum t) t "ecl_nthcdr(#0,#1)") - -(def-inline cl:last :always (t) t "ecl_last(#0,1)") - -(def-inline cl:list :always nil t "ECL_NIL") -(def-inline cl:list :always (t) t "ecl_list1(#0)") - -(def-inline cl:list* :always (t) t "#0") -(def-inline cl:list* :always (t t) t "CONS(#0,#1)") - -(def-inline cl:append :always (t t) t "ecl_append(#0,#1)") - -(def-inline cl:nconc :always (t t) t "ecl_nconc(#0,#1)") - -(def-inline cl:butlast :always (t) t "ecl_butlast(#0,1)") - -(def-inline cl:nbutlast :always (t) t "ecl_nbutlast(#0,1)") - -;; file num_arith.d - -(def-inline cl:1+ :always (t) t "ecl_one_plus(#0)") -(def-inline cl:1+ :always (fixnum) t "ecl_make_integer((#0)+1)") -(def-inline cl:1+ :always (long-float) :long-double "(long double)(#0)+1") -(def-inline cl:1+ :always (double-float) :double "(double)(#0)+1") -(def-inline cl:1+ :always (single-float) :float "(float)(#0)+1") -#+complex-float (def-inline cl:1+ :always (si:complex-single-float) :csfloat "(_Complex float)(#0)+1") -#+complex-float (def-inline cl:1+ :always (si:complex-double-float) :cdfloat "(_Complex double)(#0)+1") -#+complex-float (def-inline cl:1+ :always (si:complex-long-float) :clfloat "(_Complex long double)(#0)+1") -(def-inline cl:1+ :always (fixnum) :fixnum "(#0)+1" :exact-return-type t) - -(def-inline cl:1- :always (t) t "ecl_one_minus(#0)") -(def-inline cl:1- :always (fixnum) t "ecl_make_integer((#0)-1)") -(def-inline cl:1- :always (long-float) :long-double "(long double)(#0)-1") -(def-inline cl:1- :always (double-float) :double "(double)(#0)-1") -(def-inline cl:1- :always (single-float) :float "(float)(#0)-1") -#+complex-float (def-inline cl:1- :always (si:complex-single-float) :csfloat "(_Complex float)(#0)-1") -#+complex-float (def-inline cl:1- :always (si:complex-double-float) :cdfloat "(_Complex double)(#0)-1") -#+complex-float (def-inline cl:1- :always (si:complex-long-float) :clfloat "(_Complex long double)(#0)-1") -(def-inline cl:1- :always (fixnum) :fixnum "(#0)-1" :exact-return-type t) - -;; file num_co.d - -(def-inline cl:float :always (t single-float) :float "ecl_to_float(#0)") -(def-inline cl:float :always (t double-float) :double "ecl_to_double(#0)") -(def-inline cl:float :always (t long-float) :long-double "ecl_to_long_double(#0)") -(def-inline cl:float :always (fixnum-float) :long-double "((long double)(#0))" :exact-return-type t) -(def-inline cl:float :always (fixnum-float) :double "((double)(#0))" :exact-return-type t) -(def-inline cl:float :always (fixnum-float) :float "((float)(#0))" :exact-return-type t) - -(def-inline cl:numerator :unsafe (integer) integer "(#0)") -(def-inline cl:numerator :unsafe (ratio) integer "(#0)->ratio.num") - -(def-inline cl:denominator :unsafe (integer) integer "ecl_make_fixnum(1)") -(def-inline cl:denominator :unsafe (ratio) integer "(#0)->ratio.den") - -(def-inline cl:floor :always (t) (values &rest t) "ecl_floor1(#0)") -(def-inline cl:floor :always (t t) (values &rest t) "ecl_floor2(#0,#1)") -#+(or) ; does not work well, no multiple values -(def-inline cl:floor :always (fixnum fixnum) :fixnum - "@01;(#0>=0&>0?(#0)/(#1):ecl_ifloor(#0,#1))") - -(def-inline cl:ceiling :always (t) (values &rest t) "ecl_ceiling1(#0)") -(def-inline cl:ceiling :always (t t) (values &rest t) "ecl_ceiling2(#0,#1)") - -(def-inline cl:truncate :always (t) (values &rest t) "ecl_truncate1(#0)") -(def-inline cl:truncate :always (t t) (values &rest t) "ecl_truncate2(#0,#1)") -#+(or) ; does not work well, no multiple values -(def-inline cl:truncate :always (fixnum-float) :fixnum "(cl_fixnum)(#0)") - -(def-inline cl:round :always (t) (values &rest t) "ecl_round1(#0)") -(def-inline cl:round :always (t t) (values &rest t) "ecl_round2(#0,#1)") - -(def-inline cl:mod :always (t t) t "(ecl_floor2(#0,#1),cl_env_copy->values[1])") -(def-inline cl:mod :always (fixnum fixnum) :fixnum - "@01;(#0>=0&>0?(#0)%(#1):ecl_imod(#0,#1))") - -(def-inline cl:rem :always (t t) t "(ecl_truncate2(#0,#1),cl_env_copy->values[1])") -(def-inline cl:rem :always (fixnum fixnum) :fixnum "(#0)%(#1)") - -(def-inline cl:= :always (t t) :bool "ecl_number_equalp(#0,#1)") -(def-inline cl:= :always (fixnum-float fixnum-float) :bool "(#0)==(#1)") - -(def-inline cl:/= :always (t t) :bool "!ecl_number_equalp(#0,#1)") -(def-inline cl:/= :always (fixnum-float fixnum-float) :bool "(#0)!=(#1)") - -(def-inline cl:< :always (t t) :bool "ecl_lower(#0,#1)") -(def-inline cl:< :always (fixnum-float fixnum-float) :bool "(#0)<(#1)") -(def-inline cl:< :always (fixnum-float fixnum-float fixnum-float) :bool - "@012;((#0)<(#1) && (#1)<(#2))") - -(def-inline cl:> :always (t t) :bool "ecl_greater(#0,#1)") -(def-inline cl:> :always (fixnum-float fixnum-float) :bool "(#0)>(#1)") -(def-inline cl:> :always (fixnum-float fixnum-float fixnum-float) :bool - "@012;((#0)>(#1) && (#1)>(#2))") - -(def-inline cl:<= :always (t t) :bool "ecl_lowereq(#0,#1)") -(def-inline cl:<= :always (fixnum-float fixnum-float) :bool "(#0)<=(#1)") -(def-inline cl:<= :always (fixnum-float fixnum-float fixnum-float) :bool - "@012;((#0)<=(#1) && (#1)<=(#2))") - -(def-inline cl:>= :always (t t) :bool "ecl_greatereq(#0,#1)") -(def-inline cl:>= :always (fixnum-float fixnum-float) :bool "(#0)>=(#1)") -(def-inline cl:>= :always (fixnum-float fixnum-float fixnum-float) :bool - "@012;((#0)>=(#1) && (#1)>=(#2))") - -#+ieee-floating-point (def-inline cl:max :always (t t) t "@01;((ecl_float_nan_p(#1) || ecl_greatereq(#0,#1))?#0:#1)") -#-ieee-floating-point (def-inline cl:max :always (t t) t "@01;(ecl_greatereq(#0,#1)?#0:#1)") -(def-inline cl:max :always (fixnum fixnum) :fixnum "@01;(#0)>=(#1)?#0:#1") - -#+ieee-floating-point (def-inline cl:min :always (t t) t "@01;((ecl_float_nan_p(#1) || ecl_lowereq(#0,#1))?#0:#1)") -#-ieee-floating-point (def-inline cl:min :always (t t) t "@01;(ecl_lowereq(#0,#1)?#0:#1)") -(def-inline cl:min :always (fixnum fixnum) :fixnum "@01;(#0)<=(#1)?#0:#1") - -;; file num_log.d - -(def-inline cl:logand :always nil t "ecl_make_fixnum(-1)") -(def-inline cl:logand :always nil :fixnum "-1") -(def-inline cl:logand :always (t t) t "ecl_boole(ECL_BOOLAND,(#0),(#1))") -(def-inline cl:logand :always (fixnum fixnum) :fixnum "((#0) & (#1))") - -(def-inline cl:logandc1 :always (t t) t "ecl_boole(ECL_BOOLANDC1,(#0),(#1))") -(def-inline cl:logandc1 :always (fixnum fixnum) :fixnum "(~(#0) & (#1))") - -(def-inline cl:logandc2 :always (t t) t "ecl_boole(ECL_BOOLANDC2,(#0),(#1))") -(def-inline cl:logandc2 :always (fixnum fixnum) :fixnum "((#0) & ~(#1))") - -(def-inline cl:logeqv :always nil t "ecl_make_fixnum(-1)") -(def-inline cl:logeqv :always nil :fixnum "-1") -(def-inline cl:logeqv :always (t t) t "ecl_boole(ECL_BOOLEQV,(#0),(#1))") -(def-inline cl:logeqv :always (fixnum fixnum) :fixnum "(~( (#0) ^ (#1) ))") - -(def-inline cl:logior :always nil t "ecl_make_fixnum(0)") -(def-inline cl:logior :always nil :fixnum "0") -(def-inline cl:logior :always (t t) t "ecl_boole(ECL_BOOLIOR,(#0),(#1))") -(def-inline cl:logior :always (fixnum fixnum) :fixnum "((#0) | (#1))") - -(def-inline cl:lognand :always (t t) t "ecl_boole(ECL_BOOLNAND,(#0),(#1))") -(def-inline cl:lognand :always (fixnum fixnum) :fixnum "(~( (#0) & (#1) ))") - -(def-inline cl:lognor :always (t t) t "ecl_boole(ECL_BOOLNOR,(#0),(#1))") -(def-inline cl:lognor :always (fixnum fixnum) :fixnum "(~( (#0) | (#1) ))") - -(def-inline cl:lognot :always (t) t "ecl_boole(ECL_BOOLXOR,(#0),ecl_make_fixnum(-1))") -(def-inline cl:lognot :always (fixnum) :fixnum "(~(#0))") - -(def-inline cl:logorc1 :always (t t) t "ecl_boole(ECL_BOOLORC1,(#0),(#1))") -(def-inline cl:logorc1 :always (fixnum fixnum) :fixnum "(~(#0) | (#1))") - -(def-inline cl:logorc2 :always (t t) t "ecl_boole(ECL_BOOLORC2,(#0),(#1))") -(def-inline cl:logorc2 :always (fixnum fixnum) :fixnum "((#0) | ~(#1))") - -(def-inline cl:logxor :always nil t "ecl_make_fixnum(0)") -(def-inline cl:logxor :always nil :fixnum "0") -(def-inline cl:logxor :always (t t) t "ecl_boole(ECL_BOOLXOR,(#0),(#1))") -(def-inline cl:logxor :always (fixnum fixnum) :fixnum "((#0) ^ (#1))") - -(def-inline cl:boole :always (fixnum t t) t "ecl_boole((#0),(#1),(#2))") - -(def-inline cl:logbitp :always ((integer -29 29) fixnum) :bool "(#1 >> #0) & 1") - -(def-inline cl:integer-length :always (t) :cl-index "ecl_integer_length(#0)") - -(def-inline cl:zerop :always (t) :bool "ecl_zerop(#0)") -(def-inline cl:zerop :always (fixnum-float) :bool "(#0)==0") - -(def-inline cl:plusp :always (t) :bool "ecl_plusp(#0)") -(def-inline cl:plusp :always (fixnum-float) :bool "(#0)>0") - -(def-inline cl:minusp :always (t) :bool "ecl_minusp(#0)") -(def-inline cl:minusp :always (fixnum-float) :bool "(#0)<0") - -(def-inline cl:oddp :always (t) :bool "ecl_oddp(#0)") -(def-inline cl:oddp :always (fixnum fixnum) :bool "(#0) & 1") - -(def-inline cl:evenp :always (t) :bool "ecl_evenp(#0)") -(def-inline cl:evenp :always (fixnum fixnum) :bool "~(#0) & 1") - -(def-inline cl:abs :always (t t) t "ecl_abs(#0,#1)") - -(def-inline cl:exp :always (t) t "ecl_exp(#0)") - -(def-inline cl:expt :always (t t) t "ecl_expt(#0,#1)") -(def-inline cl:expt :always ((integer 2 2) (integer 0 29)) :fixnum "(1<<(#1))") -(def-inline cl:expt :always ((integer 0 0) t) :fixnum "0") -(def-inline cl:expt :always ((integer 1 1) t) :fixnum "1") -(def-inline cl:expt :always ((long-float 0.0l0 *) long-float) :long-double "powl((long double)#0,(long double)#1)") -(def-inline cl:expt :always ((double-float 0.0d0 *) double-float) :double "pow((double)#0,(double)#1)") -(def-inline cl:expt :always ((single-float 0.0f0 *) single-float) :float "powf((float)#0,(float)#1)") -#+complex-float (def-inline cl:expt :always (si:complex-single-float si:complex-single-float) :csfloat "cpowf(#0,#1)") -#+complex-float (def-inline cl:expt :always (si:complex-double-float si:complex-double-float) :cdfloat "cpow(#0,#1)") -#+complex-float (def-inline cl:expt :always (si:complex-long-float si:complex-long-float) :clfloat "cpowl(#0,#1)") - -(def-inline cl:log :always (fixnum-float) :long-double "logl((long double)(#0))" :exact-return-type t) -(def-inline cl:log :always (fixnum-float) :double "log((double)(#0))" :exact-return-type t) -(def-inline cl:log :always (fixnum-float) :float "logf((float)(#0))" :exact-return-type t) -#+complex-float (def-inline cl:log :always (si:complex-single-float) :csfloat "clogf(#0)") -#+complex-float (def-inline cl:log :always (si:complex-double-float) :cdfloat "clog(#0)") -#+complex-float (def-inline cl:log :always (si:complex-long-float) :clfloat "clogl(#0)") - -(def-inline cl:sqrt :always (number) number "ecl_sqrt(#0)") -(def-inline cl:sqrt :always ((long-float 0.0l0 *)) :long-double "sqrtl((long double)(#0))") -(def-inline cl:sqrt :always ((double-float 0.0d0 *)) :double "sqrt((double)(#0))") -(def-inline cl:sqrt :always ((single-float 0.0f0 *)) :float "sqrtf((float)(#0))") -#+complex-float (def-inline cl:sqrt :always (si:complex-single-float) :csfloat "csqrtf(#0)") -#+complex-float (def-inline cl:sqrt :always (si:complex-double-float) :cdfloat "csqrt(#0)") -#+complex-float (def-inline cl:sqrt :always (si:complex-long-float) :clfloat "csqrtl(#0)") - -(def-inline cl:sin :always (number) number "ecl_sin(#0)") -(def-inline cl:sin :always (fixnum-float) :long-double "sinl((long double)(#0))" :exact-return-type t) -(def-inline cl:sin :always (fixnum-float) :double "sin((double)(#0))" :exact-return-type t) -(def-inline cl:sin :always (fixnum-float) :float "sinf((float)(#0))" :exact-return-type t) -#+complex-float (def-inline cl:sin :always (si:complex-single-float) :csfloat "csinf(#0)") -#+complex-float (def-inline cl:sin :always (si:complex-double-float) :cdfloat "csin(#0)") -#+complex-float (def-inline cl:sin :always (si:complex-long-float) :clfloat "csinl(#0)") - -(def-inline cl:cos :always (t) number "ecl_cos(#0)") -(def-inline cl:cos :always (fixnum-float) :long-double "cosl((long double)(#0))" :exact-return-type t) -(def-inline cl:cos :always (fixnum-float) :double "cos((double)(#0))" :exact-return-type t) -(def-inline cl:cos :always (fixnum-float) :float "cosf((float)(#0))" :exact-return-type t) -#+complex-float (def-inline cl:cos :always (si:complex-single-float) :csfloat "ccosf(#0)") -#+complex-float (def-inline cl:cos :always (si:complex-double-float) :cdfloat "ccos(#0)") -#+complex-float (def-inline cl:cos :always (si:complex-long-float) :clfloat "ccosl(#0)") - -(def-inline cl:tan :always (t) number "ecl_tan(#0)") -(def-inline cl:tan :always (fixnum-float) :long-double "tanl((long double)(#0))" :exact-return-type t) -(def-inline cl:tan :always (fixnum-float) :double "tan((double)(#0))" :exact-return-type t) -(def-inline cl:tan :always (fixnum-float) :float "tanf((float)(#0))" :exact-return-type t) -#+complex-float (def-inline cl:tan :always (si:complex-single-float) :csfloat "ctanf(#0)") -#+complex-float (def-inline cl:tan :always (si:complex-double-float) :cdfloat "ctan(#0)") -#+complex-float (def-inline cl:tan :always (si:complex-long-float) :clfloat "ctanl(#0)") - -(def-inline cl:sinh :always (t) number "ecl_sinh(#0)") -(def-inline cl:sinh :always (fixnum-float) :long-double "sinhl((long double)(#0))" :exact-return-type t) -(def-inline cl:sinh :always (fixnum-float) :double "sinh((double)(#0))" :exact-return-type t) -(def-inline cl:sinh :always (fixnum-float) :float "sinhf((float)(#0))" :exact-return-type t) -#+complex-float (def-inline cl:sinh :always (si:complex-single-float) :csfloat "csinhf(#0)") -#+complex-float (def-inline cl:sinh :always (si:complex-double-float) :cdfloat "csinh(#0)") -#+complex-float (def-inline cl:sinh :always (si:complex-long-float) :clfloat "csinhl(#0)") - -(def-inline cl:cosh :always (t) number "ecl_cosh(#0)") -(def-inline cl:cosh :always (fixnum-float) :long-double "coshl((long double)(#0))" :exact-return-type t) -(def-inline cl:cosh :always (fixnum-float) :double "cosh((double)(#0))" :exact-return-type t) -(def-inline cl:cosh :always (fixnum-float) :float "coshf((float)(#0))" :exact-return-type t) -#+complex-float (def-inline cl:cosh :always (si:complex-single-float) :csfloat "ccoshf(#0)") -#+complex-float (def-inline cl:cosh :always (si:complex-double-float) :cdfloat "ccosh(#0)") -#+complex-float (def-inline cl:cosh :always (si:complex-long-float) :clfloat "ccoshl(#0)") - -(def-inline cl:tanh :always (t) number "ecl_tanh(#0)") -(def-inline cl:tanh :always (fixnum-float) :long-double "tanhl((long double)(#0))" :exact-return-type t) -(def-inline cl:tanh :always (fixnum-float) :double "tanh((double)(#0))" :exact-return-type t) -(def-inline cl:tanh :always (fixnum-float) :float "tanhf((float)(#0))" :exact-return-type t) -#+complex-float (def-inline cl:tanh :always (si:complex-single-float) :csfloat "ctanhf(#0)") -#+complex-float (def-inline cl:tanh :always (si:complex-double-float) :cdfloat "ctanh(#0)") -#+complex-float (def-inline cl:tanh :always (si:complex-long-float) :clfloat "ctanhl(#0)") - -;; file package.d - -;; file pathname.d - -(def-inline cl:null :always (t) :bool "#0==ECL_NIL") - -(def-inline cl:symbolp :always (t) :bool "@0;ECL_SYMBOLP(#0)") - -(def-inline cl:atom :always (t) :bool "@0;ECL_ATOM(#0)") - -(def-inline cl:consp :always (t) :bool "@0;ECL_CONSP(#0)") - -(def-inline cl:listp :always (t) :bool "@0;ECL_LISTP(#0)") - -(def-inline cl:numberp :always (t) :bool "ecl_numberp(#0)") - -(def-inline cl:integerp :always (t) :bool "@0;ECL_FIXNUMP(#0)||ECL_BIGNUMP(#0)") - -(def-inline cl:floatp :always (t) :bool "floatp(#0)") - -(def-inline cl:characterp :always (t) :bool "ECL_CHARACTERP(#0)") - -(def-inline si:base-char-p :always (character) :bool "ECL_BASE_CHAR_P(#0)") - -(def-inline cl:stringp :always (t) :bool "@0;ECL_STRINGP(#0)") - -(def-inline si:base-string-p :always (t) :bool "@0;ECL_BASE_STRING_P(#0)") - -(def-inline cl:bit-vector-p :always (t) :bool "@0;ECL_BIT_VECTOR_P(#0)") - -(def-inline cl:vectorp :always (t) :bool "@0;ECL_VECTORP(#0)") - -(def-inline cl:arrayp :always (t) :bool "@0;ECL_ARRAYP(#0)") - -(def-inline cl:eq :always (t t) :bool "(#0)==(#1)") -(def-inline cl:eq :always (fixnum fixnum) :bool "(#0)==(#1)") - -(def-inline cl:eql :always (t t) :bool "ecl_eql(#0,#1)") -(def-inline cl:eql :always (character t) :bool "(ECL_CODE_CHAR(#0)==(#1))") -(def-inline cl:eql :always (t character) :bool "((#0)==ECL_CODE_CHAR(#1))") -(def-inline cl:eql :always (character character) :bool "(#0)==(#1)") -(def-inline cl:eql :always ((not (or complex bignum ratio float)) t) :bool - "(#0)==(#1)") -(def-inline cl:eql :always (t (not (or complex bignum ratio float))) :bool - "(#0)==(#1)") -(def-inline cl:eql :always (fixnum fixnum) :bool "(#0)==(#1)") - -(def-inline cl:equal :always (t t) :bool "ecl_equal(#0,#1)") -(def-inline cl:equal :always (fixnum fixnum) :bool "(#0)==(#1)") - -(def-inline cl:equalp :always (t t) :bool "ecl_equalp(#0,#1)") -(def-inline cl:equalp :always (fixnum fixnum) :bool "(#0)==(#1)") - -(def-inline cl:not :always (t) :bool "(#0)==ECL_NIL") - -;; file print.d, read.d - -(def-inline cl:clear-output :always (stream) NULL "(ecl_clear_output(#0),ECL_NIL)") - -(def-inline cl:finish-output :always (stream) NULL "(ecl_finish_output(#0),ECL_NIL)") - -(def-inline cl:finish-output :always (stream) NULL "(ecl_force_output(#0),ECL_NIL)") - -(def-inline cl:write-char :always (t) t "@0;(ecl_princ_char(ecl_char_code(#0),ECL_NIL),(#0))") - -(def-inline cl:clear-input :always (stream) NULL "(ecl_clear_input(#0),ECL_NIL)") - -(def-inline cl:copy-readtable :always (null null) t "standard_readtable") - -(def-inline cl:boundp :always (t) :bool "ecl_boundp(cl_env_copy,#0)") -(def-inline cl:boundp :unsafe ((and symbol (not null))) :bool "ECL_SYM_VAL(cl_env_copy,#0)!=OBJNULL") - -;; file unixsys.d - -;; file sequence.d - -(def-inline cl:elt :always (t t) t "ecl_elt(#0,ecl_to_size(#1))") -(def-inline cl:elt :always (t fixnum) t "ecl_elt(#0,#1)") - -(def-inline cl:elt :unsafe (t t) t "ecl_elt(#0,ecl_fixnum(#1))") -(def-inline cl:elt :unsafe (t fixnum) t "ecl_elt(#0,#1)") -(def-inline cl:elt :unsafe (vector t) t "ecl_aref_unsafe(#0,ecl_fixnum(#1))") -(def-inline cl:elt :unsafe (vector fixnum) t "ecl_aref_unsafe(#0,#1)") -(def-inline cl:aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,ecl_fixnum(#1))") -(def-inline cl:aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") -#+unicode -(def-inline cl:aref :unsafe ((array character) fixnum) :wchar - "(#0)->string.self[#1]") -(def-inline cl:aref :unsafe ((array base-char) fixnum) :unsigned-char - "(#0)->base_string.self[#1]") -(def-inline cl:aref :unsafe ((array double-float) fixnum) :double - "(#0)->array.self.df[#1]") -(def-inline cl:aref :unsafe ((array single-float) fixnum) :float - "(#0)->array.self.sf[#1]") -(def-inline cl:aref :unsafe ((array fixnum) fixnum) :fixnum - "(#0)->array.self.fix[#1]") - -(def-inline si:elt-set :always (t t t) t "ecl_elt_set(#0,ecl_to_size(#1),#2)") -(def-inline si:elt-set :always (t fixnum t) t "ecl_elt_set(#0,#1,#2)") - -(def-inline si:elt-set :unsafe (t t t) t "ecl_elt_set(#0,ecl_fixnum(#1),#2)") -(def-inline si:elt-set :unsafe (vector t t) t "ecl_aset_unsafe(#0,ecl_to_size(#1),#2)") -(def-inline si:elt-set :unsafe (vector fixnum t) t "ecl_aset_unsafe(#0,#1,#2)") - -(def-inline cl:length :always (t) :fixnum "ecl_length(#0)") -(def-inline cl:length :unsafe (vector) :fixnum "(#0)->vector.fillp") - -(def-inline cl:copy-seq :always (t) t "ecl_copy_seq(#0)") - -;; file character.d - -(def-inline cl:char :always (t fixnum) t "ecl_aref1(#0,#1)") -(def-inline cl:char :always (t fixnum) :wchar "ecl_char(#0,#1)") -#-unicode -(def-inline cl:char :unsafe (t t) t "ECL_CODE_CHAR((#0)->base_string.self[ecl_fixnum(#1)])") -#-unicode -(def-inline cl:char :unsafe (t fixnum) :unsigned-char "(#0)->base_string.self[#1]") -(def-inline cl:char :unsafe (base-string fixnum) :unsigned-char "(#0)->base_string.self[#1]") -#+unicode -(def-inline cl:char :unsafe (ext:extended-string fixnum) :wchar "(#0)->string.self[#1]") - -(def-inline si:char-set :always (t t t) t "si_char_set(#0,#1,#2)") -(def-inline si:char-set :always (t fixnum t) t "ecl_aset1(#0,#1,#2)") -(def-inline si:char-set :always (t fixnum character) :wchar "ecl_char_set(#0,#1,#2)") -#-unicode -(def-inline si:char-set :unsafe (t t t) t - "@2;((#0)->base_string.self[ecl_fixnum(#1)]=ecl_char_code(#2),(#2))") -#-unicode -(def-inline si:char-set :unsafe (t fixnum character) :unsigned-char - "(#0)->base_string.self[#1]= #2") -(def-inline si:char-set :unsafe (base-string t t) t - "@2;((#0)->base_string.self[ecl_fixnum(#1)]=ecl_char_code(#2),(#2))") -(def-inline si:char-set :unsafe (base-string fixnum base-char) :unsigned-char - "(#0)->base_string.self[#1]= #2") -(def-inline si:char-set :unsafe (ext:extended-string t t) t - "@2;((#0)->string.self[ecl_fixnum(#1)]=ecl_char_code(#2),(#2))") -(def-inline si:char-set :unsafe (ext:extended-string fixnum character) :unsigned-char - "(#0)->string.self[#1]= #2") - -(def-inline cl:schar :always (t t) t "ecl_elt(#0,ecl_to_size(#1))") -(def-inline cl:schar :always (t fixnum) t "ecl_elt(#0,#1)") -(def-inline cl:schar :always (t fixnum) :wchar "ecl_char(#0,#1)") -(def-inline cl:schar :unsafe (base-string t) t "ECL_CODE_CHAR((#0)->base_string.self[ecl_fixnum(#1)])") -#-unicode -(def-inline cl:schar :unsafe (t fixnum) :unsigned-char "(#0)->base_string.self[#1]") -(def-inline cl:schar :unsafe (base-string fixnum) :unsigned-char "(#0)->base_string.self[#1]") -#+unicode -(def-inline cl:schar :unsafe (ext:extended-string fixnum) :wchar "(#0)->string.self[#1]") - -(def-inline si:schar-set :always (t t t) t "ecl_elt_set(#0,ecl_to_size(#1),#2)") -(def-inline si:schar-set :always (t fixnum t) t "ecl_elt_set(#0,#1,#2)") -(def-inline si:schar-set :always (t fixnum character) :wchar "ecl_char_set(#0,#1,#2)") -#-unicode -(def-inline si:schar-set :unsafe (t t t) t - "@2;((#0)->base_string.self[ecl_fixnum(#1)]=ecl_char_code(#2),(#2))") -#-unicode -(def-inline si:schar-set :unsafe (t fixnum base-char) :unsigned-char - "(#0)->base_string.self[#1]= #2") -(def-inline si:schar-set :unsafe (base-string t t) t - "@2;((#0)->base_string.self[ecl_fixnum(#1)]=ecl_char_code(#2),(#2))") -(def-inline si:schar-set :unsafe (base-string fixnum base-char) :unsigned-char - "(#0)->base_string.self[#1]= #2") -#+unicode -(def-inline si:schar-set :unsafe (ext:extended-string fixnum t) :wchar - "@2;((#0)->string.self[#1]= ecl_char_code(#2),(#2))") -#+unicode -(def-inline si:schar-set :unsafe (ext:extended-string fixnum character) :wchar - "(#0)->string.self[#1]= #2") - -(def-inline cl:string= :always (string string) :bool "ecl_string_eq(#0,#1)") - -;; file structure.d - -(def-inline si:structure-name :always (structure-object) symbol "ECL_STRUCT_NAME(#0)") - -(def-inline si:structure-ref :always (t t fixnum) t "ecl_structure_ref(#0,#1,#2)") - -(def-inline si:structure-set :always (t t fixnum t) t - "ecl_structure_set(#0,#1,#2,#3)") - -;; file symbol.d - -(def-inline cl:get :always (t t t) t "ecl_get(#0,#1,#2)") -(def-inline cl:get :always (t t) t "ecl_get(#0,#1,ECL_NIL)") - -(def-inline cl:symbol-name :always (t) string "ecl_symbol_name(#0)") - -;; Additions used by the compiler. -;; The following functions do not exist. They are always expanded into the -;; given C code. References to these functions are generated in the C1 phase. - -(def-inline shift>> :always (fixnum fixnum) :fixnum "((#0) >> (- (#1)))") - -(def-inline shift<< :always (fixnum fixnum) :fixnum "((#0) << (#1))") - -(def-inline si:short-float-p :always (t) :bool "@0;ECL_SINGLE_FLOAT_P(#0)") - -(def-inline si:single-float-p :always (t) :bool "@0;ECL_SINGLE_FLOAT_P(#0)") - -(def-inline si:double-float-p :always (t) :bool "@0;ECL_DOUBLE_FLOAT_P(#0)") - -(def-inline si:long-float-p :always (t) :bool "@0;ECL_LONG_FLOAT_P(#0)") - -#+complex-float -(def-inline si::complex-single-float-p :always (t) :bool "@0;ECL_COMPLEX_SINGLE_FLOAT_P(#0)") -#+complex-float -(def-inline si::complex-double-float-p :always (t) :bool "@0;ECL_COMPLEX_DOUBLE_FLOAT_P(#0)") -#+complex-float -(def-inline si::complex-long-float-p :always (t) :bool "@0;ECL_COMPLEX_LONG_FLOAT_P(#0)") - -(def-inline ext:fixnump :always (t) :bool "ECL_FIXNUMP(#0)") -(def-inline ext:fixnump :always (fixnum) :bool "1") - -;; Functions only available with threads -#+threads -(def-inline mp:lock-count :unsafe (mp:lock) fixnum "((#0)->lock.counter)") - -#+threads -(def-inline mp:compare-and-swap-car :always (cons t t) t "ecl_compare_and_swap(&ECL_CONS_CAR(#0),(#1),(#2))") -#+threads -(def-inline mp:atomic-incf-car :always (cons t) t "ecl_atomic_incf(&ECL_CONS_CAR(#0),(#1))") -#+threads -(def-inline mp:atomic-incf-car :always (cons fixnum) t "ecl_atomic_incf_by_fixnum(&ECL_CONS_CAR(#0),(#1))") - -#+threads -(def-inline mp:compare-and-swap-cdr :always (cons t t) t "ecl_compare_and_swap(&ECL_CONS_CDR(#0),(#1),(#2))") -#+threads -(def-inline mp:atomic-incf-cdr :always (cons t) t "ecl_atomic_incf(&ECL_CONS_CDR(#0),(#1))") -#+threads -(def-inline mp:atomic-incf-cdr :always (cons fixnum) t "ecl_atomic_incf_by_fixnum(&ECL_CONS_CDR(#0),(#1))") - -#+threads -(def-inline mp:compare-and-swap-symbol-value :unsafe (symbol t t) t "ecl_compare_and_swap(ecl_bds_ref(ecl_process_env(),(#0)),(#1),(#2))") -#+threads -(def-inline mp:atomic-incf-symbol-value :always (t fixnum) t "ecl_atomic_incf_by_fixnum(ecl_bds_ref(ecl_process_env(),(#0)),(#1))") -#+threads -(def-inline mp:atomic-incf-symbol-value :unsafe (symbol t) t "ecl_atomic_incf(ecl_bds_ref(ecl_process_env(),(#0)),(#1))") -#+threads -(def-inline mp:atomic-incf-symbol-value :unsafe (symbol fixnum) t "ecl_atomic_incf_by_fixnum(ecl_bds_ref(ecl_process_env(),(#0)),(#1))") - -#+threads -(def-inline mp:compare-and-swap-svref :unsafe (t t t t) t "ecl_compare_and_swap((#0)->vector.self.t + ecl_fixnum(#1),(#2),(#3))") -#+threads -(def-inline mp:compare-and-swap-svref :unsafe (t fixnum t t) t "ecl_compare_and_swap((#0)->vector.self.t + (#1),(#2),(#3))") - -#+(and threads clos) -(def-inline mp:compare-and-swap-instance :always (t fixnum t t) t "ecl_compare_and_swap_instance((#0),(#1),(#2),(#3))") -#+(and threads clos) -(def-inline mp:compare-and-swap-instance :unsafe (standard-object fixnum t t) t "ecl_compare_and_swap((#0)->instance.slots+(#1),(#2),(#3))") -#+(and threads clos) -(def-inline mp:atomic-incf-instance :always (t fixnum t) t "ecl_atomic_incf_instance((#0),(#1),(#2))") -#+(and threads clos) -(def-inline mp:atomic-incf-instance :unsafe (standard-object fixnum t) t "ecl_atomic_incf((#0)->instance.slots+(#1),(#2))") -#+(and threads clos) -(def-inline mp:atomic-incf-instance :unsafe (standard-object fixnum fixnum) t "ecl_atomic_incf_by_fixnum((#0)->instance.slots+(#1),(#2))") - -#+threads -(def-inline mp:compare-and-swap-structure :unsafe (structure-object t fixnum t t) t "ecl_compare_and_swap(&(ECL_STRUCT_SLOT((#0),(#2))),(#3),(#4))") - -;; Functions only available with CLOS - -#+clos -(def-inline si:instance-ref :always (t fixnum) t "ecl_instance_ref((#0),(#1))") -#+clos -(def-inline si:instance-ref :unsafe (standard-object fixnum) t - "(#0)->instance.slots[#1]") - -#+clos -(def-inline si::instance-slotds :unsafe (standard-object) list - "(#0)->instance.slotds") - -#+clos -(def-inline si:instance-set :unsafe (t fixnum t) t - "ecl_instance_set((#0),(#1),(#2))") -#+clos -(def-inline si:instance-set :unsafe (standard-object fixnum t) t - "(#0)->instance.slots[#1]=(#2)") - -#+clos -(def-inline si:instance-class :always (standard-object) t "ECL_CLASS_OF(#0)") -#+clos -(def-inline cl:class-of :unsafe (standard-object) t "ECL_CLASS_OF(#0)") - -#+clos -(def-inline si:instancep :always (t) :bool "@0;ECL_INSTANCEP(#0)") -#+clos -(def-inline si:unbound :always nil t "ECL_UNBOUND") - -#+clos -(def-inline si:sl-boundp :always (t) :bool "(#0)!=ECL_UNBOUND") - -#+clos -(def-inline clos:standard-instance-access :always (t fixnum) t "ecl_instance_ref((#0),(#1))") -#+clos -(def-inline clos:standard-instance-access :unsafe (standard-object fixnum) t - "(#0)->instance.slots[#1]") - -#+clos -(def-inline clos:funcallable-standard-instance-access :always (t fixnum) t "ecl_instance_ref((#0),(#1))") -#+clos -(def-inline clos:funcallable-standard-instance-access :unsafe (clos:funcallable-standard-object fixnum) t - "(#0)->instance.slots[#1]") - -))) ; eval-when - -(defun make-inline-information (*machine*) - (let ((*inline-information* (make-hash-table :size 512 :test 'equal))) - (loop for i in '#.(mapcar #'rest +inline-forms+) - do (apply #'def-inline i)) - *inline-information*)) - -(defun inline-information (name safety) - (gethash (list name safety) *inline-information*)) - -(defun (setf inline-information) (value name safety) - (setf (gethash (list name safety) *inline-information*) value)) - -(defun def-inline (name safety arg-types return-rep-type expansion - &key (one-liner t) (exact-return-type nil) (inline-or-warn nil) - (multiple-values t) - &aux arg-rep-types) - (setf safety - (case safety - (:unsafe :inline-unsafe) - (:safe :inline-safe) - (:always :inline-always) - (t (error "In DEF-INLINE, wrong value of SAFETY")))) - ;; Ensure we can inline this form. We only inline when the features are - ;; there (checked above) and when the C types are part of this machine - ;; (checked here). - (loop for type in (list* return-rep-type arg-types) - unless (or (eq type 'fixnum-float) - (and (consp type) (eq (car type) 'values)) - (lisp-type-p type) - (machine-c-type-p type)) - do (warn "Dropping inline form for ~A because of missing type ~A" name type) - (return-from def-inline)) - (setf arg-rep-types - (mapcar #'(lambda (x) (if (eq x '*) x (lisp-type->rep-type x))) - arg-types)) - (when (eq return-rep-type t) - (setf return-rep-type :object)) - (when inline-or-warn - (setf (inline-information name 'should-be-inlined) t)) - (let* ((return-type (if (and (consp return-rep-type) - (eq (first return-rep-type) 'values)) - t - (rep-type->lisp-type return-rep-type))) - (inline-info - (make-inline-info :name name - :arg-rep-types arg-rep-types - :return-rep-type return-rep-type - :return-type return-type - :arg-types arg-types - :exact-return-type exact-return-type - :multiple-values multiple-values - ;; :side-effects (not (si:get-sysprop name 'no-side-effects)) - :one-liner one-liner - :expansion expansion))) - #+(or) - (loop for i in (inline-information name safety) - when (and (equalp (inline-info-arg-types i) arg-types) - (not (equalp return-type (inline-info-return-type i)))) - do (format t "~&;;; Redundand inline definition for ~A~&;;; ~<~A~>~&;;; ~<~A~>" - name i inline-info)) - (push inline-info (gethash (list name safety) *inline-information*)))) - -(setf (machine-inline-information *default-machine*) - (make-inline-information *default-machine*)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; FUNCTIONS WHICH CAN BE CALLED FROM C -;;; -;;; The following two lists contain all functions in the core library which do -;;; not belong to the C part of the library, but which should have an exported C -;;; name that users (and compiled code) can refer to. This means, for instance, that -;;; MAKE-ARRAY will be compiled to a function called cl_make_array, etc. -;;; -;;; Note that if the created C function should take only fixed -;;; arguments, a proclamation for the function type must exist so that -;;; the compiler can produce the correct function signature! -;;; - -(in-package "SI") - -#+ecl-min -(defvar c::*in-all-symbols-functions* - ;; These functions are visible from external.h and their function - ;; objects are created in init_all_symbols from the data in - ;; symbols_list.h - `(;; arraylib.lsp - make-array vector array-dimensions array-in-bounds-p array-row-major-index - bit sbit bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 - bit-andc2 bit-orc1 bit-orc2 bit-not - vector-pop adjust-array - ;; assert.lsp - si::do-check-type si::ecase-error si::etypecase-error - si::wrong-type-argument si::ccase-error si::ctypecase-error - ;; config.lsp - short-site-name long-site-name machine-type machine-instance machine-version - software-type software-version lisp-implementation-type lisp-implementation-version - si::lisp-implementation-vcs-id - ;; assignment.lsp - si::setf-definition - ;; conditions.lsp - si::safe-eval abort continue muffle-warning store-value use-value - si::bind-simple-restarts si::bind-simple-handlers - si::assert-failure compute-restarts find-restart invoke-restart - invoke-restart-interactively make-condition - ;; describe.lsp - describe inspect - ;; iolib.lsp - read-from-string write-to-string prin1-to-string princ-to-string - y-or-n-p yes-or-no-p string-to-object dribble - ext:make-encoding ext:load-encoding - ;; listlib.lsp - union nunion intersection nintersection set-difference nset-difference - set-exclusive-or nset-exclusive-or subsetp rassoc-if rassoc-if-not - assoc-if assoc-if-not member-if member-if-not subst-if subst-if-not - nsubst-if nsubst-if-not - ;; mislib.lsp - logical-pathname-translations load-logical-pathname-translations decode-universal-time - encode-universal-time get-decoded-time - ensure-directories-exist si::simple-program-error si::signal-simple-error - ;; module.lsp - provide require - ;; numlib.lsp - isqrt phase signum cis - asin acos asinh acosh atanh ffloor fceiling ftruncate fround - logtest byte byte-size byte-position ldb ldb-test mask-field dpb - deposit-field - ;; packlib.lsp - find-all-symbols apropos apropos-list - ;; pprint.lsp - pprint-fill copy-pprint-dispatch pprint-dispatch - pprint-linear pprint-newline pprint-tab pprint-tabular - set-pprint-dispatch pprint-indent - ;; predlib.lsp - upgraded-array-element-type upgraded-complex-part-type typep subtypep coerce - si::do-deftype si::ratiop si::single-float-p si::short-float-p si::double-float-p - si::long-float-p - ;; process.lsp - ext:run-program - ext:terminate-process - ;; seq.lsp - make-sequence concatenate map some every notany notevery map-into complement - ;; seqlib.lsp - reduce fill replace - remove remove-if remove-if-not delete delete-if delete-if-not - count count-if count-if-not substitute substitute-if substitute-if-not - nsubstitute nsubstitute-if nsubstitute-if-not find find-if find-if-not - position position-if position-if-not remove-duplicates - delete-duplicates mismatch search sort stable-sort merge constantly - si::sequence-count - ;; setf.lsp - si::do-defsetf si::do-define-setf-method - ;; trace.lsp - si::traced-old-definition - - #+clos - ,@'(;; combin.lsp - invalid-method-error - method-combination-error - clos:compute-effective-method-function - clos:std-compute-effective-method - ;; defclass.lsp - clos::ensure-class - clos:load-defclass - ;; kernel.lsp - clos:std-compute-applicable-methods - ;; method.lsp - clos:extract-lambda-list - clos:extract-specializer-names - ;; predlib.lsp - si::subclassp si::of-class-p - ;; slotvalue.lsp - slot-makunbound - ;; std-slot-value.lsp - slot-boundp - slot-exists-p - slot-value - clos::slot-value-set - clos::standard-instance-access ;; alias clos:funcallable-standard-instance-access - clos::standard-instance-set - ) - - ;; cdr-5 - ext:array-index-p - ext:negative-fixnum-p ext:non-negative-fixnum-p - ext:non-positive-fixnum-p ext:positive-fixnum-p - ext:negative-integer-p ext:non-negative-integer-p - ext:non-positive-integer-p ext:positive-integer-p - ext:negative-rational-p ext:non-negative-rational-p - ext:non-positive-rational-p ext:positive-rational-p - ext:negative-ratio-p ext:non-negative-ratio-p - ext:non-positive-ratio-p ext:positive-ratio-p - ext:negative-real-p ext:non-negative-real-p - ext:non-positive-real-p ext:positive-real-p - ext:negative-float-p ext:non-negative-float-p - ext:non-positive-float-p ext:positive-float-p - ext:negative-short-float-p ext:non-negative-short-float-p - ext:non-positive-short-float-p ext:positive-short-float-p - ext:negative-single-float-p ext:non-negative-single-float-p - ext:non-positive-single-float-p ext:positive-single-float-p - ext:negative-double-float-p ext:non-negative-double-float-p - ext:non-positive-double-float-p ext:positive-double-float-p - ext:negative-long-float-p ext:non-negative-long-float-p - ext:non-positive-long-float-p ext:positive-long-float-p -)) - -(proclaim - ;; These functions are not visible in external.h and have no entry in - ;; symbols_list.h - `(si::c-export-fname #+ecl-min ,@c::*in-all-symbols-functions* - ;; defmacro.lsp - find-documentation find-declarations - si::search-keyword si::check-keyword - si::dm-too-many-arguments si::dm-too-few-arguments - remove-documentation - ;; defstruct.lsp - si::structure-type-error si::define-structure - ;; helpfile.lsp - si::get-documentation si::set-documentation - si::expand-set-documentation - ;; packlib.lsp - si::packages-iterator - ;; pprint.lsp - si::pprint-logical-block-helper si::pprint-pop-helper - ;; seq.lsp - si::make-seq-iterator si::seq-iterator-ref - si::seq-iterator-set si::seq-iterator-next - si::coerce-to-list si::coerce-to-vector - - #+formatter - ,@'( - format-princ format-prin1 format-print-named-character - format-print-integer - format-print-cardinal format-print-ordinal format-print-old-roman - format-print-roman format-fixed format-exponential - format-general format-dollars - format-relative-tab format-absolute-tab - format-justification - ) - - #+clos - ,@'(;; generic.lsp - clos::associate-methods-to-gfun - ;; kernel.lsp - clos::install-method - ;; std-slot-value.lsp - clos::find-slot-definition - ;; clos::generic-function-lambda-list - ;; clos::generic-function-argument-precedence-order - ;; clos::generic-function-method-combination - ;; clos::generic-function-method-class - ;; clos::generic-function-methods - ;; clos::method-generic-function - ;; clos::method-lambda-list - ;; clos::method-specializers - ;; clos::method-qualifiers - ;; clos::method-function - ;; clos::method-plist - ) - )) - From 95e7bdd7d7721332d888f5595371819fcaa08577 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 7 Jun 2023 15:52:56 +0200 Subject: [PATCH 22/23] cmpc: change compiler-macro cl:float to c-inliner macro The compiler macro expanded float to c-inline. --- src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp | 15 +++++++++++++++ src/cmp/cmpopt.lsp | 23 ----------------------- 2 files changed, 15 insertions(+), 23 deletions(-) diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp index 08656d56a..699d01bf1 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp @@ -135,3 +135,18 @@ do (if arguments (setf arg1 (save-inline-loc result)) (return result)))) + +(define-c-inliner float (return-type arg &optional float) + (let ((arg-c-type (lisp-type->rep-type (inlined-arg-type arg))) + (flt-c-type (lisp-type->rep-type (inlined-arg-type float)))) + (when (member flt-c-type '(:float :double :long-double)) + (if (eq arg-c-type flt-c-type) + (inlined-arg-loc arg) + (produce-inline-loc (list arg) + (list :object) + (list flt-c-type) + (ecase flt-c-type + (:float "ecl_to_float(#0)") + (:double "ecl_to_double(#0)") + (:long-double "ecl_to_long_double(#0)")) + nil t))))) diff --git a/src/cmp/cmpopt.lsp b/src/cmp/cmpopt.lsp index 08b7c4a9d..545fce8d4 100644 --- a/src/cmp/cmpopt.lsp +++ b/src/cmp/cmpopt.lsp @@ -339,29 +339,6 @@ (define-compiler-macro coerce (&whole form value type &environment env) (expand-coerce form value type env)) -(define-compiler-macro float (&whole form value &optional float &environment env) - (or - (and - float - (policy-inline-type-checks env) - (multiple-value-bind (constant-p float) - (constant-value-p float env) - (when (and constant-p (floatp float)) - (let* ((float (type-of float)) - (c-type (lisp-type->rep-type float))) - `(let ((value ,value)) - (declare (:read-only value)) - (ext:compiler-typecase value - (,float value) - (t - (ffi:c-inline (value) (:object) ,c-type - ,(ecase c-type - (:double "ecl_to_double(#0)") - (:float "ecl_to_float(#0)") - (:long-double "ecl_to_long_double(#0)")) - :one-liner t :side-effects nil)))))))) - form)) - (define-compiler-macro princ (&whole whole expression &optional stream &environment env) (if (constantp expression env) (let ((value (ext:constant-form-value expression env))) From e10c2010d4c50cdcf06b68bd81d28b7b277a96b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 8 Jun 2023 22:50:45 +0200 Subject: [PATCH 23/23] cosmetic: update headers --- src/cmp/cmppass1-call.lsp | 7 +------ src/cmp/cmptables.lsp | 6 +----- 2 files changed, 2 insertions(+), 11 deletions(-) diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp index 39b0ebf45..14867726e 100644 --- a/src/cmp/cmppass1-call.lsp +++ b/src/cmp/cmppass1-call.lsp @@ -4,12 +4,7 @@ ;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll ;;;; Copyright (c) 2021, Daniel Kochmański ;;;; -;;;; This program is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. -;;;; -;;;; See file '../Copyright' for full details. +;;;; See the file 'LICENSE' for the copyright details. ;;;; (in-package #:compiler) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index 170862b12..6b753f1db 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -4,12 +4,8 @@ ;;;; ;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll ;;;; -;;;; This program is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. +;;;; See the file 'LICENSE' for the copyright details. ;;;; -;;;; See file '../Copyright' for full details. ;;;; CMPPROP Type propagation.