From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED.blaine.gmane.org!not-for-mail From: Andrea Corallo Newsgroups: gmane.emacs.devel Subject: On elisp running native Date: Thu, 28 Nov 2019 06:54:10 +0000 Message-ID: Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: blaine.gmane.org; posting-host="blaine.gmane.org:195.159.176.226"; logging-data="21792"; mail-complaints-to="usenet@blaine.gmane.org" To: emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Thu Nov 28 08:06:34 2019 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([209.51.188.17]) by blaine.gmane.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.89) (envelope-from ) id 1iaDsm-0005I6-Ot for ged-emacs-devel@m.gmane.org; Thu, 28 Nov 2019 08:06:34 +0100 Original-Received: from localhost ([::1]:45850 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1iaDsl-00080U-G3 for ged-emacs-devel@m.gmane.org; Thu, 28 Nov 2019 02:06:31 -0500 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:41031) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1iaDpT-0005Wj-Es for emacs-devel@gnu.org; Thu, 28 Nov 2019 02:03:18 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1iaDmL-0006Go-40 for emacs-devel@gnu.org; Thu, 28 Nov 2019 02:00:03 -0500 Original-Received: from mx.sdf.org ([205.166.94.20]:57054) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1iaDmI-000628-Jp for emacs-devel@gnu.org; Thu, 28 Nov 2019 01:59:51 -0500 Original-Received: from sdf.org (IDENT:akrl@sverige.freeshell.org [205.166.94.5]) by mx.sdf.org (8.15.2/8.14.5) with ESMTPS id xAS6sBPN008200 (using TLSv1.2 with cipher DHE-RSA-AES256-GCM-SHA384 (256 bits) verified NO) for ; Thu, 28 Nov 2019 06:54:11 GMT Original-Received: (from akrl@localhost) by sdf.org (8.15.2/8.12.8/Submit) id xAS6sBVM001862; Thu, 28 Nov 2019 06:54:11 GMT X-detected-operating-system: by eggs.gnu.org: Genre and OS details not recognized. X-Received-From: 205.166.94.20 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.23 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.org gmane.emacs.devel:242821 Archived-At: --=-=-= Content-Type: text/plain Hi all. I'd like share the investigation I've been working on to give Emacs the ability to compile and run elisp as native code. Despite being in very early stage it's functional and shows some quite interesting potential in terms of performance benefit. I then thought was at a good stage to be shared and discussed. I wrote a small page to describe what I did and how it works plus the current status not to have the information spread in various mails. http://akrl.sdf.org/gccemacs.html The repository is hosted at the following link and the current patch is attached. https://gitlab.com/koral/gccemacs In case this is of interest I'd love to see it as feature branch to better collect feedback and work on its evolution. Best Regards Andrea -- akrl@sdf.org --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=gccemacs.patch diff --git a/configure.ac b/configure.ac index 3b6a2a6..1621844 100644 --- a/configure.ac +++ b/configure.ac @@ -463,6 +463,7 @@ AC_DEFUN OPTION_DEFAULT_ON([zlib],[don't compile with zlib decompression support]) OPTION_DEFAULT_ON([modules],[compile with dynamic modules support]) OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support]) +OPTION_DEFAULT_ON([nativecomp],[don't compile with emacs lisp native compiler support]) AC_ARG_WITH([file-notification],[AS_HELP_STRING([--with-file-notification=LIB], [use a file notification library (LIB one of: yes, inotify, kqueue, gfile, w32, no)])], @@ -3724,6 +3725,33 @@ AC_DEFUN emacs_major_version="${PACKAGE_VERSION%%.*}" AC_SUBST(emacs_major_version) +### Emacs Lisp native compiler support +HAVE_NATIVE_COMP=no +LIBGCCJIT_LIB= +COMP_OBJ= +if test "${with_nativecomp}" != "no"; then + AC_CHECK_HEADER([libgccjit.h], [HAVE_NATIVE_COMP=yes]) + if test "${HAVE_NATIVE_COMP}" = "yes"; then + LIBGCCJIT_LIB="-lgccjit -ldl" + if test "${HAVE_MODULES}" = yes; then + COMP_OBJ="comp.o" + else + COMP_OBJ="dynlib.o comp.o" + fi + AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if you have the libgccjit library (-lgccjit).]) + AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln", + [System extension for native compiled elisp]) + else + AC_MSG_ERROR([elisp native compiler requested but libgccjit not found. +If you are sure you want Emacs compiled without elisp native compiler, pass + --without-nativecomp +to configure.]) + fi +fi +AC_SUBST(LIBGCCJIT_LIB) +AC_SUBST(COMP_OBJ) + + ### Use -lpng if available, unless '--with-png=no'. HAVE_PNG=no LIBPNG= @@ -5702,6 +5730,7 @@ AC_DEFUN Does Emacs support the portable dumper? ${with_pdumper} Does Emacs support legacy unexec dumping? ${with_unexec} Which dumping strategy does Emacs use? ${with_dumping} + Does Emacs have native lisp compiler? ${HAVE_NATIVE_COMP} "]) if test -n "${EMACSDATA}"; then diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 905d99a..9efa2c6 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -562,6 +562,21 @@ byte-compile-output (defvar byte-compile-depth 0 "Current depth of execution stack.") (defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") +;; These are use by comp.el to spill data out of here +(cl-defstruct byte-to-native-function + "Named or anonymous function defined a top level." + name data) +(cl-defstruct byte-to-native-top-level + "All other top level forms." + form) +(defvar byte-native-compiling nil + "t while native compiling.") +(defvar byte-to-native-lap nil + "A-list to accumulate LAP. +Each pair is (NAME . LAP)") +(defvar byte-to-native-top-level-forms nil + "List of top level forms.") + ;;; The byte codes; this information is duplicated in bytecomp.c @@ -2017,7 +2032,9 @@ byte-compile-file ;; emacs-lisp files in the build tree are ;; recompiled). Previously this was accomplished by ;; deleting target-file before writing it. - (rename-file tempfile target-file t)) + (if byte-native-compiling + (delete-file tempfile) + (rename-file tempfile target-file t))) (or noninteractive (message "Wrote %s" target-file))) ;; This is just to give a better error message than write-region (let ((exists (file-exists-p target-file))) @@ -2234,6 +2251,10 @@ byte-compile-output-file-form ;; defalias calls are output directly by byte-compile-file-form-defmumble; ;; it does not pay to first build the defalias in defmumble and then parse ;; it here. + (when byte-native-compiling + ;; Spill output for the native compiler here + (push (make-byte-to-native-top-level :form form) + byte-to-native-top-level-forms)) (let ((print-escape-newlines t) (print-length nil) (print-level nil) @@ -2367,7 +2388,8 @@ byte-compile-keep-pending (defun byte-compile-flush-pending () (if byte-compile-output - (let ((form (byte-compile-out-toplevel t 'file))) + (let* ((byte-compile-current-form nil) + (form (byte-compile-out-toplevel t 'file))) (cond ((eq (car-safe form) 'progn) (mapc 'byte-compile-output-file-form (cdr form))) (form @@ -2687,6 +2709,16 @@ byte-compile-file-form-defmumble ;; If there's no doc string, provide -1 as the "doc string ;; index" so that no element will be treated as a doc string. (if (not (stringp (documentation code t))) -1 4))) + (when byte-native-compiling + ;; Spill output for the native compiler here. + (push (if macro + (make-byte-to-native-top-level + :form `(defalias ',name '(macro . ,code) nil)) + (if (commandp code) + (make-byte-to-native-top-level ;FIXME compile interactive functions. + :form `(defalias ',name ,code)) + (make-byte-to-native-function :name name :data code))) + byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having ;; b-c-output-file-form analyze the defalias. (byte-compile-output-docform @@ -3111,9 +3143,14 @@ byte-compile-out-toplevel (not (delq nil (mapcar 'consp (cdr (car body)))))))) (setq rest (cdr rest))) rest)) - (let ((byte-compile-vector (byte-compile-constants-vector))) - (list 'byte-code (byte-compile-lapcode byte-compile-output) - byte-compile-vector byte-compile-maxdepth))) + (let* ((byte-compile-vector (byte-compile-constants-vector)) + (out (list 'byte-code (byte-compile-lapcode byte-compile-output) + byte-compile-vector byte-compile-maxdepth))) + (when byte-native-compiling + ;; Spill LAP for the native compiler here + (push (cons byte-compile-current-form byte-compile-output) + byte-to-native-lap)) + out)) ;; it's a trivial function ((cdr body) (cons 'progn (nreverse body))) ((car body))))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el new file mode 100644 index 0000000..273bda8 --- /dev/null +++ b/lisp/emacs-lisp/comp.el @@ -0,0 +1,1917 @@ +;;; comp.el --- compilation of Lisp code into native code -*- lexical-binding: t -*- + +;; Author: Andrea Corallo + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Keywords: lisp +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; This code is an attempt to make the pig fly. +;; Or, to put it another way to make a 911 out of a turbocharged VW Bug. + +;;; Code: + +(require 'bytecomp) +(require 'gv) +(require 'cl-lib) +(require 'cl-extra) +(require 'subr-x) + +(defgroup comp nil + "Emacs Lisp native compiler." + :group 'lisp) + +(defcustom comp-speed 0 + "Compiler optimization level. From 0 to 3. +- 0 no optimizations are performed, compile time is favored. +- 1 lite optimizations. +- 2 heavy optimizations. +- 3 max optimization level, to be used only when necessary. + Warning: the compiler is free to perform dangerous optimizations." + :type 'number + :group 'comp) + +(defcustom comp-debug 0 + "Compiler debug level. From 0 to 3. +This intended for debugging the compiler itself. +- 0 no debug facility. + This is the recommended value unless you are debugging the compiler itself. +- 1 emit debug symbols and dump pseudo C code. +- 2 dump gcc passes and libgccjit log file. +- 3 dump libgccjit reproducers." + :type 'number + :group 'comp) + +(defcustom comp-verbose 0 + "Compiler verbosity. From 0 to 3. +This intended for debugging the compiler itself. +- 0 no logging. +- 1 final limple is logged. +- 2 LAP and final limple and some pass info are logged. +- 3 max verbosity." + :type 'number + :group 'comp) + +(defcustom comp-always-compile nil + "Unconditionally (re-)compile all files." + :type 'boolean + :group 'comp) + +(defconst comp-log-buffer-name "*Native-compile-Log*" + "Name of the native-compiler log buffer.") + +(defconst comp-async-buffer-name "*Async-native-compile-log*" + "Name of the async compilation buffer log.") + +(defvar comp-native-compiling nil + "This gets bound to t while native compilation. +Can be used by code that wants to expand differently in this case.") + +(defvar comp-pass nil + "Every pass has the right to bind what it likes here.") + +(defconst comp-passes '(comp-spill-lap + comp-limplify + comp-ssa + comp-propagate + comp-call-optim + comp-propagate + comp-dead-code + comp-final) + "Passes to be executed in order.") + +(defconst comp-known-ret-types '((cons . cons) + (1+ . number) + (1- . number) + (+ . number) + (- . number) + (* . number) + (/ . number) + (% . number) + ;; Type hints + (comp-hint-fixnum . fixnum) + (comp-hint-cons . cons)) + "Alist used for type propagation.") + +(defconst comp-type-hints '(comp-hint-fixnum + comp-hint-cons) + "List of fake functions used to give compiler hints.") + +(defconst comp-limple-sets '(set + setimm + set-par-to-local + set-args-to-local + set-rest-args-to-local) + "Limple set operators.") + +(defconst comp-limple-assignments `(fetch-handler + ,@comp-limple-sets) + "Limple operators that clobbers the first m-var argument.") + +(defconst comp-limple-calls '(call + callref + direct-call + direct-callref) + "Limple operators use to call subrs.") + +(eval-when-compile + (defconst comp-op-stack-info + (cl-loop with h = (make-hash-table) + for k across byte-code-vector + for v across byte-stack+-info + when k + do (puthash k v h) + finally return h) + "Hash table lap-op -> stack adjustment.")) + +(cl-defstruct comp-ctxt + "Lisp side of the compiler context." + (output nil :type string + :documentation "Target output file-name for the compilation.") + (top-level-forms () :type list + :documentation "List of spilled top level forms.") + (funcs-h (make-hash-table) :type hash-table + :documentation "lisp-func-name -> comp-func. +This is to build the prev field.") + (data-relocs-l () :type list + :documentation "Constant objects used by functions.") + (data-relocs-idx (make-hash-table :test #'equal) :type hash-table + :documentation "Obj -> position into data-relocs.") + (func-relocs-l () :type list + :documentation "Native functions imported.") + (func-relocs-idx (make-hash-table :test #'equal) :type hash-table + :documentation "Obj -> position into func-relocs.")) + +(cl-defstruct comp-args-base + (min nil :type number + :documentation "Minimum number of arguments allowed.")) + +(cl-defstruct (comp-args (:include comp-args-base)) + (max nil :type number + :documentation "Maximum number of arguments allowed. +To be used when ncall-conv is nil.")) + +(cl-defstruct (comp-nargs (:include comp-args-base)) + "Describe args when the function signature is of kind: +(ptrdiff_t nargs, Lisp_Object *args)." + (nonrest nil :type number + :documentation "Number of non rest arguments.") + (rest nil :type boolean + :documentation "t if rest argument is present.")) + +(cl-defstruct (comp-block (:copier nil) + (:constructor make--comp-block + (addr sp name))) ; Positional + "A basic block." + (name nil :type symbol) + ;; These two slots are used during limplification. + (sp nil :type number + :documentation "When non nil indicates the sp value while entering +into it.") + (addr nil :type number + :documentation "Start block LAP address.") + (insns () :type list + :documentation "List of instructions.") + (closed nil :type boolean + :documentation "t if closed.") + ;; All the followings are for SSA and CGF analysis. + (in-edges () :type list + :documentation "List of incoming edges.") + (out-edges () :type list + :documentation "List of out-coming edges.") + (dom nil :type comp-block + :documentation "Immediate dominator.") + (df (make-hash-table) :type hash-table + :documentation "Dominance frontier set. Block-name -> block") + (post-num nil :type number + :documentation "Post order number.") + (final-frame nil :type vector + :documentation "This is a copy of the frame when leaving the block. +Is in use to help the SSA rename pass.")) + +(cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) + "An edge connecting two basic blocks." + (src nil :type comp-block) + (dst nil :type comp-block) + (number nil :type number + :documentation "The index number corresponding to this edge in the + edge vector.")) + +(defun comp-block-preds (basic-block) + "Given BASIC-BLOCK return the list of its predecessors." + (mapcar #'comp-edge-src (comp-block-in-edges basic-block))) + +(defun comp-gen-counter () + "Return a sequential number generator." + (let ((n -1)) + (lambda () + (cl-incf n)))) + +(cl-defstruct (comp-func (:copier nil)) + "LIMPLE representation of a function." + (name nil :type symbol + :documentation "Function symbol name.") + (c-name nil :type string + :documentation "The function name in the native world.") + (byte-func nil + :documentation "Byte compiled version.") + (doc nil :type string + :documentation "Doc string.") + (lap () :type list + :documentation "LAP assembly representation.") + (args nil :type comp-args-base) + (frame-size nil :type number) + (blocks (make-hash-table) :type hash-table + :documentation "Key is the basic block symbol value is a comp-block +structure.") + (lap-block (make-hash-table :test #'equal) :type hash-table + :documentation "LAP lable -> LIMPLE basic block name.") + (edges () :type list + :documentation "List of edges connecting basic blocks.") + (block-cnt-gen (funcall #'comp-gen-counter) :type function + :documentation "Generates block numbers.") + (edge-cnt-gen (funcall #'comp-gen-counter) :type function + :documentation "Generates edges numbers.") + (ssa-cnt-gen (funcall #'comp-gen-counter) :type function + :documentation "Counter to create ssa limple vars.")) + +(defun comp-func-reset-generators (func) + "Reset unique id generators for FUNC." + (setf (comp-func-edge-cnt-gen func) (comp-gen-counter) + (comp-func-ssa-cnt-gen func) (comp-gen-counter))) + +(cl-defstruct (comp-mvar (:constructor make--comp-mvar)) + "A meta-variable being a slot in the meta-stack." + (slot nil :type fixnum + :documentation "Slot number. +-1 is a special value and indicates the scratch slot.") + (id nil :type (or null number) + :documentation "SSA number when in SSA form.") + (const-vld nil :type boolean + :documentation "Valid signal for the following slot.") + (constant nil + :documentation "When const-vld non nil this is used for holding + a value known at compile time.") + (type nil + :documentation "When non nil indicates the type when known at compile + time.") + (ref nil :type boolean + :documentation "When t the m-var is involved in a call where is passed by + reference.")) + +;; Special vars used by some passes +(defvar comp-func) + + + +(defun comp-set-op-p (op) + "Assignment predicate for OP." + (cl-find op comp-limple-sets)) + +(defun comp-assign-op-p (op) + "Assignment predicate for OP." + (cl-find op comp-limple-assignments)) + +(defun comp-limple-insn-call-p (insn) + "Limple INSN call predicate." + (when (member (car-safe insn) comp-limple-calls) + t)) + +(defun comp-type-hint-p (func) + "Type hint predicate for function name FUNC." + (member func comp-type-hints)) + +(defun comp-add-const-to-relocs (obj) + "Keep track of OBJ into the ctxt relocations. +The corresponding index is returned." + (let ((data-relocs-idx (comp-ctxt-data-relocs-idx comp-ctxt))) + (if-let ((idx (gethash obj data-relocs-idx))) + idx + (push obj (comp-ctxt-data-relocs-l comp-ctxt)) + (puthash obj (hash-table-count data-relocs-idx) data-relocs-idx)))) + +(defun comp-add-subr-to-relocs (subr-name) + "Keep track of SUBR-NAME into the ctxt relocations. +The corresponding index is returned." + (let ((func-relocs-idx (comp-ctxt-func-relocs-idx comp-ctxt))) + (if-let ((idx (gethash subr-name func-relocs-idx))) + idx + (push subr-name (comp-ctxt-func-relocs-l comp-ctxt)) + (puthash subr-name (hash-table-count func-relocs-idx) func-relocs-idx)))) + +(defmacro comp-within-log-buff (&rest body) + "Execute BODY while at the end the log-buffer. +BODY is evaluate only if `comp-verbose' is > 0." + (declare (debug (form body)) + (indent defun)) + `(when (> comp-verbose 0) + (with-current-buffer (get-buffer-create comp-log-buffer-name) + (setf buffer-read-only t) + (let ((inhibit-read-only t)) + (goto-char (point-max)) + ,@body)))) + +(defun comp-log (data verbosity) + "Log DATA given VERBOSITY." + (when (>= comp-verbose verbosity) + (if noninteractive + (if (atom data) + (message "%s" data) + (mapc (lambda (x) + (message "%s"(prin1-to-string x))) + data)) + (comp-within-log-buff + (if (and data (atom data)) + (insert data) + (mapc (lambda (x) + (insert (prin1-to-string x) "\n")) + data) + (insert "\n")))))) + +(defun comp-log-func (func verbosity) + "Log function FUNC. +VERBOSITY is a number between 0 and 3." + (when (>= comp-verbose verbosity) + (comp-log (format "\nFunction: %s\n" (comp-func-name func)) verbosity) + (cl-loop for block-name being each hash-keys of (comp-func-blocks func) + using (hash-value bb) + do (comp-log (concat "<" (symbol-name block-name) ">") verbosity) + (comp-log (comp-block-insns bb) verbosity)))) + +(defun comp-log-edges (func) + "Log edges in FUNC." + (let ((edges (comp-func-edges func))) + (comp-log (format "\nEdges in function: %s\n" + (comp-func-name func)) + 2) + (mapc (lambda (e) + (comp-log (format "n: %d src: %s dst: %s\n" + (comp-edge-number e) + (comp-block-name (comp-edge-src e)) + (comp-block-name (comp-edge-dst e))) + 2)) + edges))) + + +;;; spill-lap pass specific code. + +(defun comp-c-func-name (symbol prefix) + "Given SYMBOL return a name suitable for the native code. +Put PREFIX in front of it." + ;; Unfortunatelly not all symbol names are valid as C function names... + ;; Nassi's algorithm here: + (let* ((orig-name (symbol-name symbol)) + (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0) + for j from 0 by 2 + for i across orig-name + for byte = (format "%x" i) + do (aset str j (aref byte 0)) + (aset str (1+ j) (aref byte 1)) + finally return str)) + (human-readable (replace-regexp-in-string + "-" "_" orig-name)) + (human-readable (replace-regexp-in-string + (rx (not (any "0-9a-z_"))) "" human-readable))) + (concat prefix crypted "_" human-readable))) + +(defun comp-decrypt-lambda-list (x) + "Decript lambda list X." + (unless (fixnump x) + (signal 'native-compiler-error + "can't native compile a non lexical scoped function")) + (let ((rest (not (= (logand x 128) 0))) + (mandatory (logand x 127)) + (nonrest (ash x -8))) + (if (and (null rest) + (< nonrest 9)) ;; SUBR_MAX_ARGS + (make-comp-args :min mandatory + :max nonrest) + (make-comp-nargs :min mandatory + :nonrest nonrest + :rest rest)))) + +(defsubst comp-byte-frame-size (byte-compiled-func) + "Given BYTE-COMPILED-FUNC return the frame size to be allocated." + (aref byte-compiled-func 3)) + +(cl-defgeneric comp-spill-lap-function (input) + "Byte compile INPUT and spill lap for further stages.") + +(cl-defgeneric comp-spill-lap-function ((function-name symbol)) + "Byte compile FUNCTION-NAME spilling data from the byte compiler." + (let* ((f (symbol-function function-name)) + (func (make-comp-func :name function-name + :c-name (comp-c-func-name function-name"F")))) + (when (byte-code-function-p f) + (signal 'native-compiler-error + "can't native compile an already bytecompiled function")) + (setf (comp-func-byte-func func) + (byte-compile (comp-func-name func))) + (let ((lap (alist-get nil byte-to-native-lap))) + (cl-assert lap) + (comp-log lap 2) + (let ((lambda-list (aref (comp-func-byte-func func) 0))) + (setf (comp-func-args func) + (comp-decrypt-lambda-list lambda-list) + (comp-func-lap func) + lap + (comp-func-frame-size func) + (comp-byte-frame-size (comp-func-byte-func func)))) + (setf (comp-ctxt-top-level-forms comp-ctxt) + (list (make-byte-to-native-function :name function-name))) + (list func)))) + +(cl-defgeneric comp-spill-lap-function ((filename string)) + "Byte compile FILENAME spilling data from the byte compiler." + (byte-compile-file filename) + (unless byte-to-native-top-level-forms + (signal 'native-compiler-error "empty byte compiler output")) + (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms)) + (cl-loop + for f in (cl-loop for x in byte-to-native-top-level-forms ; All non anonymous. + when (and (byte-to-native-function-p x) + (byte-to-native-function-name x)) + collect x) + for name = (byte-to-native-function-name f) + for data = (byte-to-native-function-data f) + for doc = (when (>= (length data) 5) (aref data 4)) + for lap = (alist-get name byte-to-native-lap) + for lambda-list = (aref data 0) + for func = (make-comp-func :name name + :byte-func data + :doc doc + :c-name (comp-c-func-name name "F") + :args (comp-decrypt-lambda-list lambda-list) + :lap lap + :frame-size (comp-byte-frame-size data)) + do (comp-log (format "Function %s:\n" name) 1) + (comp-log lap 1) + collect func)) + +(defun comp-spill-lap (input) + "Byte compile and spill the LAP representation for INPUT. +If INPUT is a symbol this is the function-name to be compiled. +If INPUT is a string this is the file path to be compiled." + (let ((byte-native-compiling t) + (byte-to-native-lap ()) + (byte-to-native-top-level-forms ())) + (comp-spill-lap-function input))) + + +;;; Limplification pass specific code. + +(cl-defstruct (comp-limplify (:copier nil)) + "Support structure used during function limplification." + (frame nil :type vector + :documentation "Meta-stack used to flat LAP.") + (curr-block nil :type comp-block + :documentation "Current block being limplified.") + (sp -1 :type number + :documentation "Current stack pointer while walking LAP. +Points to the next slot to be filled.") + (pc 0 :type number + :documentation "Current program counter while walking LAP.") + (label-to-addr nil :type hash-table + :documentation "LAP hash table -> address.") + (pending-blocks () :type list + :documentation "List of blocks waiting for limplification.")) + +(defconst comp-lap-eob-ops + '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop + byte-goto-if-not-nil-else-pop byte-return byte-pushcatch + byte-switch byte-pushconditioncase) + "LAP end of basic blocks op codes.") + +(defsubst comp-lap-eob-p (inst) + "Return t if INST closes the current basic blocks, nil otherwise." + (when (member (car inst) comp-lap-eob-ops) + t)) + +(defsubst comp-lap-fall-through-p (inst) + "Return t if INST fall through, nil otherwise." + (when (not (member (car inst) '(byte-goto byte-return))) + t)) + +(defsubst comp-sp () + "Current stack pointer." + (comp-limplify-sp comp-pass)) +(gv-define-setter comp-sp (value) + `(setf (comp-limplify-sp comp-pass) ,value)) + +(defmacro comp-with-sp (sp &rest body) + "Execute BODY setting the stack pointer to SP. +Restore the original value afterwards." + (declare (debug (form body)) + (indent defun)) + (let ((sym (gensym))) + `(let ((,sym (comp-sp))) + (setf (comp-sp) ,sp) + (progn ,@body) + (setf (comp-sp) ,sym)))) + +(defsubst comp-slot-n (n) + "Slot N into the meta-stack." + (aref (comp-limplify-frame comp-pass) n)) + +(defsubst comp-slot () + "Current slot into the meta-stack pointed by sp." + (comp-slot-n (comp-sp))) + +(defsubst comp-slot+1 () + "Slot into the meta-stack pointed by sp + 1." + (comp-slot-n (1+ (comp-sp)))) + +(defsubst comp-label-to-addr (label) + "Find the address of LABEL." + (or (gethash label (comp-limplify-label-to-addr comp-pass)) + (signal 'native-ice (list "label not found" label)))) + +(defsubst comp-mark-curr-bb-closed () + "Mark the current basic block as closed." + (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)) + +(defun comp-bb-maybe-add (lap-addr &optional sp) + "If necessary create a pending basic block for LAP-ADDR with stack depth SP. +The basic block is returned regardless it was already declared or not." + (let ((bb (or (cl-loop ; See if the block was already liplified. + for bb being the hash-value in (comp-func-blocks comp-func) + when (equal (comp-block-addr bb) lap-addr) + return bb) + (cl-find-if (lambda (bb) ; Look within the pendings blocks. + (= (comp-block-addr bb) lap-addr)) + (comp-limplify-pending-blocks comp-pass))))) + (if bb + (progn + (unless (or (null sp) (= sp (comp-block-sp bb))) + (signal 'native-ice (list "incoherent stack pointers" + sp (comp-block-sp bb)))) + bb) + (car (push (make--comp-block lap-addr sp (comp-new-block-sym)) + (comp-limplify-pending-blocks comp-pass)))))) + +(defun comp-call (func &rest args) + "Emit a call for function FUNC with ARGS." + (comp-add-subr-to-relocs func) + `(call ,func ,@args)) + +(defun comp-callref (func nargs stack-off) + "Emit a call using narg abi for FUNC. +NARGS is the number of arguments. +STACK-OFF is the index of the first slot frame involved." + (comp-add-subr-to-relocs func) + `(callref ,func ,@(cl-loop repeat nargs + for sp from stack-off + collect (comp-slot-n sp)))) + +(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) + (when const-vld + (comp-add-const-to-relocs constant)) + (make--comp-mvar :slot slot :const-vld const-vld :constant constant + :type type)) + +(defun comp-new-frame (size &optional ssa) + "Return a clean frame of meta variables of size SIZE. +If SSA non nil populate it of m-var in ssa form." + (cl-loop with v = (make-vector size nil) + for i below size + for mvar = (if ssa + (make-comp-ssa-mvar :slot i) + (make-comp-mvar :slot i)) + do (aset v i mvar) + finally return v)) + +(defsubst comp-emit (insn) + "Emit INSN into basic block BB." + (let ((bb (comp-limplify-curr-block comp-pass))) + (cl-assert (not (comp-block-closed bb))) + (push insn (comp-block-insns bb)))) + +(defsubst comp-emit-set-call (call) + "Emit CALL assigning the result the the current slot frame. +If the callee function is known to have a return type propagate it." + (cl-assert call) + (comp-emit (list 'set (comp-slot) call))) + +(defun comp-copy-slot (src-n &optional dst-n) + "Set slot number DST-N to slot number SRC-N as source. +If DST-N is specified use it otherwise assume it to be the current slot." + (comp-with-sp (or dst-n (comp-sp)) + (let ((src-slot (comp-slot-n src-n))) + (cl-assert src-slot) + (comp-emit `(set ,(comp-slot) ,src-slot))))) + +(defsubst comp-emit-annotation (str) + "Emit annotation STR." + (comp-emit `(comment ,str))) + +(defun comp-emit-set-const (val) + "Set constant VAL to current slot." + (let ((rel-idx (comp-add-const-to-relocs val))) + (cl-assert (numberp rel-idx)) + (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val)))) + +(defun comp-make-curr-block (block-name entry-sp &optional addr) + "Create a basic block with BLOCK-NAME and set it as current block. +ENTRY-SP is the sp value when entering. +The block is added to the current function. +The block is returned." + (let ((bb (make--comp-block addr entry-sp block-name))) + (setf (comp-limplify-curr-block comp-pass) bb + (comp-limplify-pc comp-pass) addr + (comp-limplify-sp comp-pass) (comp-block-sp bb)) + (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) + bb)) + +(defun comp-emit-uncond-jump (lap-label) + "Emit an unconditional branch to LAP-LABEL." + (cl-destructuring-bind (label-num . stack-depth) lap-label + (when stack-depth + (cl-assert (= (1- stack-depth) (comp-sp)))) + (let ((target (comp-bb-maybe-add (comp-label-to-addr label-num) + (comp-sp)))) + (comp-emit `(jump ,(comp-block-name target))) + (comp-mark-curr-bb-closed)))) + +(defun comp-emit-cond-jump (a b target-offset lap-label negated) + "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. +TARGET-OFFSET is the positive offset on the SP when branching to the target +block. +If NEGATED non null negate the tested condition. +Return value is the fall through block name." + (cl-destructuring-bind (label-num . label-sp) lap-label + (let* ((bb (comp-block-name (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp-sp)))) ; Fall through block. + (target-sp (+ target-offset (comp-sp))) + (target (comp-block-name (comp-bb-maybe-add (comp-label-to-addr label-num) + target-sp)))) + (when label-sp + (cl-assert (= (1- label-sp) (+ target-offset (comp-sp))))) + (comp-emit (if negated + (list 'cond-jump a b target bb) + (list 'cond-jump a b bb target))) + (comp-mark-curr-bb-closed) + bb))) + +(defun comp-emit-handler (lap-label handler-type) + "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE." + (cl-destructuring-bind (label-num . label-sp) lap-label + (cl-assert (= (- label-sp 2) (comp-sp))) + (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp-sp))) + (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num) + (1+ (comp-sp)))) + (pop-bb (make--comp-block nil (comp-sp) (comp-new-block-sym)))) + (comp-emit (list 'push-handler + handler-type + (comp-slot+1) + (comp-block-name pop-bb) + (comp-block-name guarded-bb))) + (comp-mark-curr-bb-closed) + ;; Emit the basic block to pop the handler if we got the non local. + (puthash (comp-block-name pop-bb) pop-bb (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) pop-bb) + (comp-emit `(fetch-handler ,(comp-slot+1))) + (comp-emit `(jump ,(comp-block-name handler-bb))) + (comp-mark-curr-bb-closed)))) + +(defun comp-limplify-listn (n) + "Limplify list N." + (comp-with-sp (+ (comp-sp) n -1) + (comp-emit-set-call (comp-call 'cons + (comp-slot) + (make-comp-mvar :constant nil)))) + (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp) + do (comp-with-sp sp + (comp-emit-set-call (comp-call 'cons + (comp-slot) + (comp-slot+1)))))) + +(defun comp-new-block-sym () + "Return a unique symbol naming the next new basic block." + (intern (format "bb_%s" (funcall (comp-func-block-cnt-gen comp-func))))) + +(defun comp-fill-label-h () + "Fill label-to-addr hash table for the current function." + (setf (comp-limplify-label-to-addr comp-pass) (make-hash-table :test 'eql)) + (cl-loop for insn in (comp-func-lap comp-func) + for addr from 0 + do (pcase insn + (`(TAG ,label . ,_) + (puthash label addr (comp-limplify-label-to-addr comp-pass)))))) + +(defun comp-emit-switch (var last-insn) + "Emit a limple for a lap jump table given VAR and LAST-INSN." + ;; FIXME this not efficient for big jump tables. We should have a second + ;; strategy for this case. + (pcase last-insn + (`(setimm ,_ ,_ ,jmp-table) + (cl-loop + for test being each hash-keys of jmp-table + using (hash-value target-label) + with len = (hash-table-count jmp-table) + with test-func = (hash-table-test jmp-table) + for n from 1 + for last = (= n len) + for m-test = (make-comp-mvar :constant test) + for target-name = (comp-block-name (comp-bb-maybe-add (comp-label-to-addr target-label) + (comp-sp))) + for ff-bb = (if last + (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass)) + (comp-sp)) + (make--comp-block nil + (comp-sp) + (comp-new-block-sym))) + for ff-bb-name = (comp-block-name ff-bb) + if (eq test-func 'eq) + do (comp-emit (list 'cond-jump var m-test ff-bb-name target-name)) + else + ;; Store the result of the comparison into the scratch slot before + ;; emitting the conditional jump. + do (comp-emit (list 'set (make-comp-mvar :slot -1) + (comp-call test-func var m-test))) + (comp-emit (list 'cond-jump + (make-comp-mvar :slot -1) + (make-comp-mvar :constant nil) + target-name ff-bb-name)) + do (unless last + ;; All fall through are artificially created here except the last one. + (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) + (setf (comp-limplify-curr-block comp-pass) ff-bb)))) + (_ (signal 'native-ice + "missing previous setimm while creating a switch")))) + +(defun comp-emit-set-call-subr (subr-name sp-delta) + "Emit a call for SUBR-NAME. +SP-DELTA is the stack adjustment." + (let ((subr (symbol-function subr-name)) + (nargs (1+ (- sp-delta)))) + (unless (subrp subr) + (signal 'native-ice (list "not a subr" subr))) + (let* ((arity (subr-arity subr)) + (minarg (car arity)) + (maxarg (cdr arity))) + (when (eq maxarg 'unevalled) + (signal 'native-ice (list "subr contains unevalled args" subr-name))) + (if (eq maxarg 'many) + ;; callref case. + (comp-emit-set-call (comp-callref subr-name nargs (comp-sp))) + ;; Normal call. + (unless (and (>= maxarg nargs) (<= minarg nargs)) + (signal 'native-ice + (list "incoherent stack adjustment" nargs maxarg minarg))) + (let* ((subr-name subr-name) + (slots (cl-loop for i from 0 below maxarg + collect (comp-slot-n (+ i (comp-sp)))))) + (comp-emit-set-call (apply #'comp-call (cons subr-name slots)))))))) + +(eval-when-compile + (defun comp-op-to-fun (x) + "Given the LAP op strip \"byte-\" to have the subr name." + (intern (replace-regexp-in-string "byte-" "" x))) + + (defun comp-body-eff (body op-name sp-delta) + "Given the original body BODY compute the effective one. +When BODY is auto guess function name form the LAP byte-code +name. Otherwise expect lname fnname." + (pcase (car body) + ('auto + (list `(comp-emit-set-call-subr + ',(comp-op-to-fun op-name) + ,sp-delta))) + ((pred symbolp) + (list `(comp-emit-set-call-subr + ',(car body) + ,sp-delta))) + (_ body)))) + +(defmacro comp-op-case (&rest cases) + "Expand CASES into the corresponding `pcase' expansion. +This is responsible for generating the proper stack adjustment when known and +the annotation emission." + (declare (debug (body)) + (indent defun)) + `(pcase op + ,@(cl-loop for (op . body) in cases + for sp-delta = (gethash op comp-op-stack-info) + for op-name = (symbol-name op) + if body + collect `(',op + ;; Log all LAP ops except the TAG one. + ,(unless (eq op 'TAG) + `(comp-emit-annotation + ,(concat "LAP op " op-name))) + ;; Emit the stack adjustment if present. + ,(when (and sp-delta (not (eq 0 sp-delta))) + `(cl-incf (comp-sp) ,sp-delta)) + ,@(comp-body-eff body op-name sp-delta)) + else + collect `(',op (signal 'native-ice + (list "unsupported LAP op" ',op-name)))) + (_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op)))))) + +(defun comp-limplify-lap-inst (insn) + "Limplify LAP instruction INSN pushing it in the proper basic block." + (let ((op (car insn)) + (arg (if (consp (cdr insn)) + (cadr insn) + (cdr insn)))) + (comp-op-case + (TAG + (cl-destructuring-bind (_TAG label-num . label-sp) insn + ;; Paranoid? + (when label-sp + (cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass)))) + (comp-emit-annotation (format "LAP TAG %d" label-num)))) + (byte-stack-ref + (comp-copy-slot (- (comp-sp) arg 1))) + (byte-varref + (comp-emit-set-call (comp-call 'symbol-value (make-comp-mvar + :constant arg)))) + (byte-varset + (comp-emit (comp-call 'set_internal + (make-comp-mvar :constant arg) + (comp-slot+1)))) + (byte-varbind ;; Verify + (comp-emit (comp-call 'specbind + (make-comp-mvar :constant arg) + (comp-slot+1)))) + (byte-call + (cl-incf (comp-sp) (- arg)) + (comp-emit-set-call (comp-callref 'funcall (1+ arg) (comp-sp)))) + (byte-unbind + (comp-emit (comp-call 'helper_unbind_n + (make-comp-mvar :constant arg)))) + (byte-pophandler + (comp-emit '(pop-handler))) + (byte-pushconditioncase + (comp-emit-handler (cddr insn) 'condition-case)) + (byte-pushcatch + (comp-emit-handler (cddr insn) 'catcher)) + (byte-nth auto) + (byte-symbolp auto) + (byte-consp auto) + (byte-stringp auto) + (byte-listp auto) + (byte-eq auto) + (byte-memq auto) + (byte-not null) + (byte-car auto) + (byte-cdr auto) + (byte-cons auto) + (byte-list1 + (comp-limplify-listn 1)) + (byte-list2 + (comp-limplify-listn 2)) + (byte-list3 + (comp-limplify-listn 3)) + (byte-list4 + (comp-limplify-listn 4)) + (byte-length auto) + (byte-aref auto) + (byte-aset auto) + (byte-symbol-value auto) + (byte-symbol-function auto) + (byte-set auto) + (byte-fset auto) + (byte-get auto) + (byte-substring auto) + (byte-concat2 + (comp-emit-set-call (comp-callref 'concat 2 (comp-sp)))) + (byte-concat3 + (comp-emit-set-call (comp-callref 'concat 3 (comp-sp)))) + (byte-concat4 + (comp-emit-set-call (comp-callref 'concat 4 (comp-sp)))) + (byte-sub1 1-) + (byte-add1 1+) + (byte-eqlsign =) + (byte-gtr >) + (byte-lss <) + (byte-leq <=) + (byte-geq >=) + (byte-diff -) + (byte-negate + (comp-emit-set-call (comp-call 'negate (comp-slot)))) + (byte-plus +) + (byte-max auto) + (byte-min auto) + (byte-mult *) + (byte-point auto) + (byte-goto-char auto) + (byte-insert auto) + (byte-point-max auto) + (byte-point-min auto) + (byte-char-after auto) + (byte-following-char auto) + (byte-preceding-char preceding-char) + (byte-current-column auto) + (byte-indent-to + (comp-emit-set-call (comp-call 'indent-to + (comp-slot) + (make-comp-mvar :constant nil)))) + (byte-scan-buffer-OBSOLETE) + (byte-eolp auto) + (byte-eobp auto) + (byte-bolp auto) + (byte-bobp auto) + (byte-current-buffer auto) + (byte-set-buffer auto) + (byte-save-current-buffer + (comp-emit (comp-call 'record_unwind_current_buffer))) + (byte-set-mark-OBSOLETE) + (byte-interactive-p-OBSOLETE) + (byte-forward-char auto) + (byte-forward-word auto) + (byte-skip-chars-forward auto) + (byte-skip-chars-backward auto) + (byte-forward-line auto) + (byte-char-syntax auto) + (byte-buffer-substring auto) + (byte-delete-region auto) + (byte-narrow-to-region + (comp-emit-set-call (comp-call 'narrow-to-region + (comp-slot) + (comp-slot+1)))) + (byte-widen + (comp-emit-set-call (comp-call 'widen))) + (byte-end-of-line auto) + (byte-constant2) ; TODO + ;; Branches. + (byte-goto + (comp-emit-uncond-jump (cddr insn))) + (byte-goto-if-nil + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 + (cddr insn) nil)) + (byte-goto-if-not-nil + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0 + (cddr insn) t)) + (byte-goto-if-nil-else-pop + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 + (cddr insn) nil)) + (byte-goto-if-not-nil-else-pop + (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1 + (cddr insn) t)) + (byte-return + (comp-emit `(return ,(comp-slot+1)))) + (byte-discard 'pass) + (byte-dup + (comp-copy-slot (1- (comp-sp)))) + (byte-save-excursion + (comp-emit (comp-call 'record_unwind_protect_excursion))) + (byte-save-window-excursion-OBSOLETE) + (byte-save-restriction + (comp-emit (comp-call 'helper_save_restriction))) + (byte-catch) ;; Obsolete + (byte-unwind-protect + (comp-emit (comp-call 'helper_unwind_protect (comp-slot+1)))) + (byte-condition-case) ;; Obsolete + (byte-temp-output-buffer-setup-OBSOLETE) + (byte-temp-output-buffer-show-OBSOLETE) + (byte-unbind-all) ;; Obsolete + (byte-set-marker auto) + (byte-match-beginning auto) + (byte-match-end auto) + (byte-upcase auto) + (byte-downcase auto) + (byte-string= string-equal) + (byte-string< string-lessp) + (byte-equal auto) + (byte-nthcdr auto) + (byte-elt auto) + (byte-member auto) + (byte-assq auto) + (byte-nreverse auto) + (byte-setcar auto) + (byte-setcdr auto) + (byte-car-safe auto) + (byte-cdr-safe auto) + (byte-nconc auto) + (byte-quo /) + (byte-rem %) + (byte-numberp auto) + (byte-integerp auto) + (byte-listN + (cl-incf (comp-sp) (- 1 arg)) + (comp-emit-set-call (comp-callref 'list arg (comp-sp)))) + (byte-concatN + (cl-incf (comp-sp) (- 1 arg)) + (comp-emit-set-call (comp-callref 'concat arg (comp-sp)))) + (byte-insertN + (cl-incf (comp-sp) (- 1 arg)) + (comp-emit-set-call (comp-callref 'insert arg (comp-sp)))) + (byte-stack-set + (comp-copy-slot (1+ (comp-sp)) (- (comp-sp) arg -1))) + (byte-stack-set2 (cl-assert nil)) ;; TODO + (byte-discardN + (cl-incf (comp-sp) (- arg))) + (byte-switch + ;; Assume to follow the emission of a setimm. + ;; This is checked into comp-emit-switch. + (comp-emit-switch (comp-slot+1) + (cl-second (comp-block-insns + (comp-limplify-curr-block comp-pass))))) + (byte-constant + (comp-emit-set-const arg)) + (byte-discardN-preserve-tos + (cl-incf (comp-sp) (- arg)) + (comp-copy-slot (+ arg (comp-sp))))))) + +(defun comp-emit-narg-prologue (minarg nonrest rest) + "Emit the prologue for a narg function." + (cl-loop for i below minarg + do (comp-emit `(set-args-to-local ,(comp-slot-n i))) + (comp-emit '(inc-args))) + (cl-loop for i from minarg below nonrest + for bb = (intern (format "entry_%s" i)) + for fallback = (intern (format "entry_fallback_%s" i)) + do (comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback)) + (comp-make-curr-block bb (comp-sp)) + (comp-emit `(set-args-to-local ,(comp-slot-n i))) + (comp-emit '(inc-args)) + finally (comp-emit '(jump entry_rest_args))) + (when (not (= minarg nonrest)) + (cl-loop for i from minarg below nonrest + for bb = (intern (format "entry_fallback_%s" i)) + for next-bb = (if (= (1+ i) nonrest) + 'entry_rest_args + (intern (format "entry_fallback_%s" (1+ i)))) + do (comp-with-sp i + (comp-make-curr-block bb (comp-sp)) + (comp-emit-set-const nil) + (comp-emit `(jump ,next-bb))))) + (comp-make-curr-block 'entry_rest_args (comp-sp)) + (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest))) + (setf (comp-sp) nonrest) + (when (and (> nonrest 8) (null rest)) + (cl-decf (comp-sp)))) + +(defun comp-limplify-finalize-function (func) + "Reverse insns into all basic blocks of FUNC." + (cl-loop for bb being the hash-value in (comp-func-blocks func) + do (setf (comp-block-insns bb) + (nreverse (comp-block-insns bb)))) + (comp-log-func func 2) + func) + +(cl-defgeneric comp-emit-for-top-level (form) + "Emit the limple code for top level FORM.") + +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-function)) + (let* ((name (byte-to-native-function-name form)) + (f (gethash name (comp-ctxt-funcs-h comp-ctxt))) + (args (comp-func-args f)) + (c-name (comp-func-c-name f)) + (doc (comp-func-doc f))) + (cl-assert (and name f)) + (comp-emit (comp-call 'comp--register-subr + (make-comp-mvar :constant name) + (make-comp-mvar :constant (comp-args-base-min args)) + (make-comp-mvar :constant (if (comp-args-p args) + (comp-args-max args) + 'many)) + (make-comp-mvar :constant c-name) + (make-comp-mvar :constant doc))))) + +(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) + (let ((form (byte-to-native-top-level-form form))) + (comp-emit (comp-call 'eval + (make-comp-mvar :constant form) + (make-comp-mvar :constant t))))) + +(defun comp-limplify-top-level () + "Create a limple function doing the business for top level forms. +This will be called at load-time." + (let* ((func (make-comp-func :name 'top-level-run + :c-name "top_level_run" + :args (make-comp-args :min 0 :max 0) + :frame-size 0)) + (comp-func func) + (comp-pass (make-comp-limplify + :curr-block (make--comp-block -1 0 'top-level) + :frame (comp-new-frame 0)))) + (comp-make-curr-block 'entry (comp-sp)) + (comp-emit-annotation "Top level") + (mapc #'comp-emit-for-top-level (comp-ctxt-top-level-forms comp-ctxt)) + (comp-emit `(return ,(make-comp-mvar :constant t))) + (comp-limplify-finalize-function func))) + +(defun comp-addr-to-bb-name (addr) + "Search for a block starting at ADDR into pending or limplified blocks." + ;; FIXME Actually we could have another hash for this. + (cl-flet ((pred (bb) + (equal (comp-block-addr bb) addr))) + (if-let ((pending (cl-find-if #'pred + (comp-limplify-pending-blocks comp-pass)))) + (comp-block-name pending) + (cl-loop for bb being the hash-value in (comp-func-blocks comp-func) + when (pred bb) + return (comp-block-name bb))))) + +(defun comp-limplify-block (bb) + "Limplify basic-block BB and add it to the current function." + (setf (comp-limplify-curr-block comp-pass) bb + (comp-limplify-sp comp-pass) (comp-block-sp bb) + (comp-limplify-pc comp-pass) (comp-block-addr bb)) + (puthash (comp-block-name bb) bb (comp-func-blocks comp-func)) + (cl-loop + for inst-cell on (nthcdr (comp-limplify-pc comp-pass) + (comp-func-lap comp-func)) + for inst = (car inst-cell) + for next-inst = (car-safe (cdr inst-cell)) + do (comp-limplify-lap-inst inst) + (cl-incf (comp-limplify-pc comp-pass)) + when (comp-lap-fall-through-p inst) + do (pcase next-inst + (`(TAG ,_label . ,label-sp) + (when label-sp + (cl-assert (= (1- label-sp) (comp-sp)))) + (let* ((stack-depth (if label-sp + (1- label-sp) + (comp-sp))) + (next-bb (comp-block-name (comp-bb-maybe-add (comp-limplify-pc comp-pass) stack-depth)))) + (unless (comp-block-closed bb) + (comp-emit `(jump ,next-bb)))) + (cl-return))) + until (comp-lap-eob-p inst))) + +(defun comp-limplify-function (func) + "Limplify a single function FUNC." + (let* ((frame-size (comp-func-frame-size func)) + (comp-func func) + (comp-pass (make-comp-limplify + :frame (comp-new-frame frame-size))) + (args (comp-func-args func))) + (comp-fill-label-h) + ;; Prologue + (comp-make-curr-block 'entry (comp-sp)) + (comp-emit-annotation (concat "Lisp function: " + (symbol-name (comp-func-name func)))) + (if (comp-args-p args) + (cl-loop for i below (comp-args-max args) + do (cl-incf (comp-sp)) + (comp-emit `(set-par-to-local ,(comp-slot) ,i))) + (comp-emit-narg-prologue (comp-args-base-min args) + (comp-nargs-nonrest args) + (comp-nargs-rest args))) + (comp-emit '(jump bb_0)) + ;; Body + (comp-bb-maybe-add 0 (comp-sp)) + (cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass)) + while next-bb + do (comp-limplify-block next-bb)) + ;; Sanity check against block duplication. + (cl-loop with addr-h = (make-hash-table) + for bb being the hash-value in (comp-func-blocks func) + for addr = (comp-block-addr bb) + when addr + do (cl-assert (null (gethash addr addr-h))) + (puthash addr t addr-h)) + (comp-limplify-finalize-function func))) + +(defun comp-add-func-to-ctxt (func) + "Add FUNC to the current compiler contex." + (puthash (comp-func-name func) + func + (comp-ctxt-funcs-h comp-ctxt))) + +(defun comp-limplify (lap-funcs) + "Compute the LIMPLE ir for LAP-FUNCS. +Top level forms for the current context are rendered too." + (mapc #'comp-add-func-to-ctxt (mapcar #'comp-limplify-function lap-funcs)) + (comp-add-func-to-ctxt (comp-limplify-top-level))) + + +;;; SSA pass specific code. +;; After limplification no edges are present between basic blocks and an +;; implicit phi is present for every slot at the beginning of every basic block. +;; This pass is responsible for building all the edges and replace all m-vars +;; plus placing the needed phis. +;; Because the number of phis placed is (supposed) to be the minimum necessary +;; this form is called 'minimal SSA form'. +;; This pass should be run every time basic blocks or m-var are shuffled. + +(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type) + (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func)) + :slot slot :const-vld const-vld :constant constant + :type type)) + +(defun comp-compute-edges () + "Compute the basic block edges for the current function." + (cl-flet ((edge-add (&rest args) + (push + (apply #'make--comp-edge + :number (funcall (comp-func-edge-cnt-gen comp-func)) + args) + (comp-func-edges comp-func)))) + + (cl-loop with blocks = (comp-func-blocks comp-func) + for bb being each hash-value of blocks + for last-insn = (car (last (comp-block-insns bb))) + for (op first second third forth) = last-insn + do (cl-case op + (jump + (edge-add :src bb :dst (gethash first blocks))) + (cond-jump + (edge-add :src bb :dst (gethash third blocks)) + (edge-add :src bb :dst (gethash forth blocks))) + (cond-jump-narg-leq + (edge-add :src bb :dst (gethash second blocks)) + (edge-add :src bb :dst (gethash third blocks))) + (push-handler + (edge-add :src bb :dst (gethash third blocks)) + (edge-add :src bb :dst (gethash forth blocks))) + (return) + (otherwise + (signal 'native-ice + (list "block does not end with a branch" + bb + (comp-func-name comp-func))))) + finally (setf (comp-func-edges comp-func) + (nreverse (comp-func-edges comp-func))) + ;; Update edge refs into blocks. + (cl-loop for edge in (comp-func-edges comp-func) + do (push edge + (comp-block-out-edges (comp-edge-src edge))) + (push edge + (comp-block-in-edges (comp-edge-dst edge)))) + (comp-log-edges comp-func)))) + +(defun comp-collect-rev-post-order (basic-block) + "Walk BASIC-BLOCK children and return their name in reversed post-order." + (let ((visited (make-hash-table)) + (acc ())) + (cl-labels ((collect-rec (bb) + (let ((name (comp-block-name bb))) + (unless (gethash name visited) + (puthash name t visited) + (cl-loop for e in (comp-block-out-edges bb) + for dst-block = (comp-edge-dst e) + do (collect-rec dst-block)) + (push name acc))))) + (collect-rec basic-block) + acc))) + +(defun comp-compute-dominator-tree () + "Compute immediate dominators for each basic block in current function." + ;; Originally based on: "A Simple, Fast Dominance Algorithm" + ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). + (cl-flet ((intersect (b1 b2) + (let ((finger1 (comp-block-post-num b1)) + (finger2 (comp-block-post-num b2))) + (while (not (= finger1 finger2)) + (while (< finger1 finger2) + (setf b1 (comp-block-dom b1) + finger1 (comp-block-post-num b1))) + (while (< finger2 finger1) + (setf b2 (comp-block-dom b2) + finger2 (comp-block-post-num b2)))) + b1)) + (first-processed (l) + (if-let ((p (cl-find-if (lambda (p) (comp-block-dom p)) l))) + p + (signal 'native-ice "cant't find first preprocessed")))) + + (when-let ((blocks (comp-func-blocks comp-func)) + (entry (gethash 'entry blocks)) + ;; No point to go on if the only bb is 'entry'. + (bb1 (gethash 'bb_1 blocks))) + (cl-loop with rev-bb-list = (comp-collect-rev-post-order entry) + with changed = t + while changed + initially (progn + (comp-log "Computing dominator tree...\n" 2) + (setf (comp-block-dom entry) entry) + ;; Set the post order number. + (cl-loop for name in (reverse rev-bb-list) + for b = (gethash name blocks) + for i from 0 + do (setf (comp-block-post-num b) i))) + do (cl-loop + for name in (cdr rev-bb-list) + for b = (gethash name blocks) + for preds = (comp-block-preds b) + for new-idom = (first-processed preds) + initially (setf changed nil) + do (cl-loop for p in (delq new-idom preds) + when (comp-block-dom p) + do (setf new-idom (intersect p new-idom))) + unless (eq (comp-block-dom b) new-idom) + do (setf (comp-block-dom b) new-idom + changed t)))))) + +(defun comp-compute-dominator-frontiers () + "Compute the dominator frontier for each basic block in `comp-func'." + ;; Originally based on: "A Simple, Fast Dominance Algorithm" + ;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001). + (cl-loop with blocks = (comp-func-blocks comp-func) + for b-name being each hash-keys of blocks + using (hash-value b) + for preds = (comp-block-preds b) + when (>= (length preds) 2) ; All joins + do (cl-loop for p in preds + for runner = p + do (while (not (eq runner (comp-block-dom b))) + (puthash b-name b (comp-block-df runner)) + (setf runner (comp-block-dom runner)))))) + +(defun comp-log-block-info () + "Log basic blocks info for the current function." + (maphash (lambda (name bb) + (let ((dom (comp-block-dom bb)) + (df (comp-block-df bb))) + (comp-log (format "block: %s idom: %s DF %s\n" + name + (when dom (comp-block-name dom)) + (cl-loop for b being each hash-keys of df + collect b)) + 3))) + (comp-func-blocks comp-func))) + +(defun comp-place-phis () + "Place phi insns into the current function." + ;; Originally based on: Static Single Assignment Book + ;; Algorithm 3.1: Standard algorithm for inserting phi-functions + (cl-flet ((add-phi (slot-n bb) + ;; Add a phi func for slot SLOT-N at the top of BB. + (push `(phi ,slot-n) (comp-block-insns bb))) + (slot-assigned-p (slot-n bb) + ;; Return t if a SLOT-N was assigned within BB. + (cl-loop for insn in (comp-block-insns bb) + when (and (comp-assign-op-p (car insn)) + (= slot-n (comp-mvar-slot (cadr insn)))) + return t))) + + (cl-loop for i from 0 below (comp-func-frame-size comp-func) + ;; List of blocks with a definition of mvar i + for defs-v = (cl-loop with blocks = (comp-func-blocks comp-func) + for b being each hash-value of blocks + when (slot-assigned-p i b) + collect b) + ;; Set of basic blocks where phi is added. + for f = () + ;; Worklist, set of basic blocks that contain definitions of v. + for w = defs-v + do + (while w + (let ((x (pop w))) + (cl-loop for y being each hash-value of (comp-block-df x) + unless (cl-find y f) + do (add-phi i y) + (push y f) + ;; Adding a phi implies mentioning the + ;; corresponding slot so in case adjust w. + (unless (cl-find y defs-v) + (push y w)))))))) + +(defun comp-dom-tree-walker (bb pre-lambda post-lambda) + "Dominator tree walker function starting from basic block BB. +PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil." + (when pre-lambda + (funcall pre-lambda bb)) + (when-let ((out-edges (comp-block-out-edges bb))) + (cl-loop for ed in out-edges + for child = (comp-edge-dst ed) + when (eq bb (comp-block-dom child)) + ;; Current block is the immediate dominator then recur. + do (comp-dom-tree-walker child pre-lambda post-lambda))) + (when post-lambda + (funcall post-lambda bb))) + +(cl-defstruct (comp-ssa (:copier nil)) + "Support structure used while SSA renaming." + (frame (comp-new-frame (comp-func-frame-size comp-func) t) :type vector + :documentation "Vector of m-vars.")) + +(defun comp-ssa-rename-insn (insn frame) + (dotimes (slot-n (comp-func-frame-size comp-func)) + (cl-flet ((targetp (x) + ;; Ret t if x is an mvar and target the correct slot number. + (and (comp-mvar-p x) + (eql slot-n (comp-mvar-slot x)))) + (new-lvalue () + ;; If is an assignment make a new mvar and put it as l-value. + (let ((mvar (make-comp-ssa-mvar :slot slot-n))) + (setf (aref frame slot-n) mvar + (cadr insn) mvar)))) + (pcase insn + (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) + (let ((mvar (aref frame slot-n))) + (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn)))) + (new-lvalue)) + (`(phi ,n) + (when (equal n slot-n) + (new-lvalue))) + (_ + (let ((mvar (aref frame slot-n))) + (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))))))) + +(defun comp-ssa-rename () + "Entry point to rename into SSA within the current function." + (comp-log "Renaming\n" 2) + (let ((frame-size (comp-func-frame-size comp-func)) + (visited (make-hash-table))) + (cl-labels ((ssa-rename-rec (bb in-frame) + (unless (gethash bb visited) + (puthash bb t visited) + (cl-loop for insn in (comp-block-insns bb) + do (comp-ssa-rename-insn insn in-frame)) + (setf (comp-block-final-frame bb) + (copy-sequence in-frame)) + (when-let ((out-edges (comp-block-out-edges bb))) + (cl-loop for ed in out-edges + for child = (comp-edge-dst ed) + ;; Provide a copy of the same frame to all childs. + do (ssa-rename-rec child (copy-sequence in-frame))))))) + + (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func)) + (comp-new-frame frame-size t))))) + +(defun comp-finalize-phis () + "Fixup r-values into phis in all basic blocks." + (cl-flet ((finalize-phi (args b) + ;; Concatenate into args all incoming m-vars for this phi. + (setcdr args + (cl-loop with slot-n = (comp-mvar-slot (car args)) + for e in (comp-block-in-edges b) + for b = (comp-edge-src e) + for in-frame = (comp-block-final-frame b) + collect (aref in-frame slot-n))))) + + (cl-loop for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop for (op . args) in (comp-block-insns b) + when (eq op 'phi) + do (finalize-phi args b))))) + +(defun comp-ssa (_) + "Port all functions into mininal SSA form." + (maphash (lambda (_ f) + (let ((comp-func f)) + ;; TODO: if this is run more than once we should clean all CFG + ;; data including phis here. + (comp-func-reset-generators comp-func) + (comp-compute-edges) + (comp-compute-dominator-tree) + (comp-compute-dominator-frontiers) + (comp-log-block-info) + (comp-place-phis) + (comp-ssa-rename) + (comp-finalize-phis) + (comp-log-func comp-func 3))) + (comp-ctxt-funcs-h comp-ctxt))) + + +;;; propagate pass specific code. +;; A very basic propagation pass follows. +;; This propagates values and types plus ref property in the control flow graph. +;; This is also responsible for removing function calls to pure functions if +;; possible. + +(defsubst comp-strict-type-of (obj) + "Given OBJ return its type understanding fixnums." + ;; Should be certainly smarter but now we take advantages just from fixnums. + (if (fixnump obj) + 'fixnum + (type-of obj))) + +(defun comp-copy-insn (insn) + "Deep copy INSN." + ;; Adapted from `copy-tree'. + (if (consp insn) + (let (result) + (while (consp insn) + (let ((newcar (car insn))) + (if (or (consp (car insn)) (comp-mvar-p (car insn))) + (setf newcar (comp-copy-insn (car insn)))) + (push newcar result)) + (setf insn (cdr insn))) + (nconc (nreverse result) + (if (comp-mvar-p insn) (comp-copy-insn insn) insn))) + (if (comp-mvar-p insn) + (copy-comp-mvar insn) + insn))) + +(defun comp-basic-const-propagate () + "Propagate simple constants for setimm operands. +This can run just once." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn in (comp-block-insns b) + do (pcase insn + (`(setimm ,lval ,_ ,v) + (setf (comp-mvar-const-vld lval) t + (comp-mvar-constant lval) v + (comp-mvar-type lval) (comp-strict-type-of v))))))) + +(defsubst comp-mvar-propagate (lval rval) + "Propagate into LVAL properties of RVAL." + (setf (comp-mvar-const-vld lval) (comp-mvar-const-vld rval) + (comp-mvar-constant lval) (comp-mvar-constant rval) + (comp-mvar-type lval) (comp-mvar-type rval))) + +(defsubst comp-function-call-remove (insn f args) + "Given INSN when F is pure if all ARGS are known remove the function call." + (when (and (get f 'pure) ; Can we just optimize pure here? See byte-opt.el + (cl-every #'comp-mvar-const-vld args)) + (let ((val (apply f (mapcar #'comp-mvar-constant args)))) + ;; See `comp-emit-set-const'. + (setf (car insn) 'setimm + (cddr insn) (list (comp-add-const-to-relocs val) val))))) + +(defun comp-propagate-insn (insn) + "Propagate within INSN." + (pcase insn + (`(set ,lval ,rval) + (pcase rval + (`(,(or 'call 'direct-call) ,f . ,args) + (setf (comp-mvar-type lval) + (alist-get f comp-known-ret-types)) + (comp-function-call-remove insn f args)) + (`(,(or 'callref 'direct-callref) ,f . ,args) + (cl-loop for v in args + do (setf (comp-mvar-ref v) t)) + (setf (comp-mvar-type lval) + (alist-get f comp-known-ret-types)) + (comp-function-call-remove insn f args)) + (_ + (comp-mvar-propagate lval rval)))) + (`(phi ,lval . ,rest) + ;; Const prop here. + (when-let* ((vld (cl-every #'comp-mvar-const-vld rest)) + (consts (mapcar #'comp-mvar-constant rest)) + (x (car consts)) + (equals (cl-every (lambda (y) (equal x y)) consts))) + (setf (comp-mvar-constant lval) x)) + ;; Type propagation. + ;; FIXME: checking for type equality is not sufficient cause does not + ;; account type hierarchy! + (when-let* ((types (mapcar #'comp-mvar-type rest)) + (non-empty (cl-notany #'null types)) + (x (car types)) + (eqs (cl-every (lambda (y) (eq x y)) types))) + (setf (comp-mvar-type lval) x)) + ;; Reference propagation. + (let ((operands (cons lval rest))) + (when (cl-some #'comp-mvar-ref operands) + (mapc (lambda (x) (setf (comp-mvar-ref x) t)) operands)))))) + +(defun comp-propagate* () + "Propagate for set* and phi operands. +Return t if something was changed." + (cl-loop with modified = nil + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop for insn in (comp-block-insns b) + for orig-insn = (unless modified ; Save consing after 1th change. + (comp-copy-insn insn)) + do (comp-propagate-insn insn) + when (and (null modified) (not (equal insn orig-insn))) + do (setf modified t)) + finally return modified)) + +(defun comp-propagate (_) + (when (>= comp-speed 2) + (maphash (lambda (_ f) + (let ((comp-func f)) + (comp-basic-const-propagate) + (cl-loop + for i from 1 + while (comp-propagate*) + finally (comp-log (format "Propagation run %d times\n" i) 2)) + (comp-log-func comp-func 3))) + (comp-ctxt-funcs-h comp-ctxt)))) + + +;;; Call optimizer pass specific code. +;; This pass is responsible for the following optimizations: +;; - Call to subrs that are in defined in the C source and are passing through +;; funcall trampoline gets optimized into normal indirect calls. +;; This makes effectively this calls equivalent to all the subrs that got +;; dedicated byte-code ops. +;; Triggered at comp-speed >= 2. +;; - Recursive calls gets optimized into direct calls. +;; Triggered at comp-speed >= 2. +;; - Intra compilation unit procedure calls gets optimized into direct calls. +;; This can be a big win and even allow gcc to inline but does not make +;; function in the compilation unit re-definable safely without recompiling +;; the full compilation unit. +;; For this reason this is triggered only at comp-speed == 3. + +(defun comp-call-optim-form-call (callee args self) + "" + (cl-flet ((fill-args (args total) + ;; Fill missing args to reach TOTAL + (append args (cl-loop repeat (- total (length args)) + collect (make-comp-mvar :constant nil)))) + (clean-args-ref (args) + ;; Clean-up the ref slot in all args + (mapc (lambda (arg) + (setf (comp-mvar-ref arg) nil)) + args) + args)) + (when (symbolp callee) ; Do nothing if callee is a byte compiled func. + (let* ((f (symbol-function callee)) + (subrp (subrp f)) + (callee-in-unit (gethash callee + (comp-ctxt-funcs-h comp-ctxt)))) + (cond + ((and subrp (not (subr-native-elisp-p f))) + ;; Trampoline removal. + (let* ((maxarg (cdr (subr-arity f))) + (call-type (if (if subrp + (not (numberp maxarg)) + (comp-nargs-p callee-in-unit)) + 'callref + 'call)) + (args (if (eq call-type 'callref) + args + (fill-args args maxarg)))) + (comp-add-subr-to-relocs callee) + `(,call-type ,callee ,@(clean-args-ref args)))) + ;; Intra compilation unit procedure call optimization. + ;; Attention speed 3 triggers that for non self calls too!! + ((or (eq callee self) + (and (>= comp-speed 3) + callee-in-unit)) + (let* ((func-args (comp-func-args callee-in-unit)) + (nargs (comp-nargs-p func-args)) + (call-type (if nargs 'direct-callref 'direct-call)) + (args (if (eq call-type 'direct-callref) + args + (fill-args args (comp-args-max func-args))))) + `(,call-type ,callee ,@(clean-args-ref args)))) + ((comp-type-hint-p callee) + `(call ,callee ,@args))))))) + +(defun comp-call-optim-func () + "Perform the trampoline call optimization for the current function." + (cl-loop + with self = (comp-func-name comp-func) + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn-cell on (comp-block-insns b) + for insn = (car insn-cell) + do (pcase insn + (`(set ,lval (callref funcall ,f . ,rest)) + (when-let ((new-form (comp-call-optim-form-call + (comp-mvar-constant f) rest self))) + (setcar insn-cell `(set ,lval ,new-form)))) + (`(callref funcall ,f . ,rest) + (when-let ((new-form (comp-call-optim-form-call + (comp-mvar-constant f) rest self))) + (setcar insn-cell new-form))))))) + +(defun comp-call-optim (_) + "Try to optimize out funcall trampoline usage when possible." + (when (>= comp-speed 2) + (maphash (lambda (_ f) + (let ((comp-func f)) + (comp-call-optim-func))) + (comp-ctxt-funcs-h comp-ctxt)))) + + +;;; Dead code elimination pass specific code. +;; This simple pass try to eliminate insns became useful after propagation. +;; Even if gcc would take care of this is good to perform this here +;; in the hope of removing memory references. +;; +;; This pass can be run as last optim. + +(defun comp-collect-mvar-ids (insn) + "Collect the m-var unique identifiers into INSN." + (cl-loop for x in insn + if (consp x) + append (comp-collect-mvar-ids x) + else + when (comp-mvar-p x) + collect (comp-mvar-id x))) + +(defun comp-dead-assignments-func () + "Clean-up dead assignments into current function. +Return the list of m-var ids nuked." + (let ((l-vals ()) + (r-vals ())) + ;; Collect used r and l-values. + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn in (comp-block-insns b) + for (op arg0 . rest) = insn + if (comp-set-op-p op) + do (push (comp-mvar-id arg0) l-vals) + (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals)) + else + do (setf r-vals (nconc (comp-collect-mvar-ids insn) r-vals)))) + ;; Every l-value appearing that does not appear as r-value has no right to + ;; exist and gets nuked. + (let ((nuke-list (cl-set-difference l-vals r-vals))) + (comp-log (format "Function %s\nl-vals %s\nr-vals %s\nNuking ids: %s\n" + (comp-func-name comp-func) + l-vals + r-vals + nuke-list) + 3) + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn-cell on (comp-block-insns b) + for insn = (car insn-cell) + for (op arg0 rest) = insn + when (and (comp-set-op-p op) + (member (comp-mvar-id arg0) nuke-list)) + do (setcar insn-cell + (if (comp-limple-insn-call-p rest) + rest + `(comment ,(format "optimized out: %s" + insn)))))) + nuke-list))) + +(defun comp-remove-type-hints-func () + "Remove type hints from the current function. +These are substituted with a normal 'set' op." + (cl-loop + for b being each hash-value of (comp-func-blocks comp-func) + do (cl-loop + for insn-cell on (comp-block-insns b) + for insn = (car insn-cell) + do (pcase insn + (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val)) + (setcar insn-cell `(set ,l-val ,r-val))))))) + +(defun comp-dead-code (_) + "Dead code elimination." + (when (>= comp-speed 2) + (maphash (lambda (_ f) + (let ((comp-func f)) + (cl-loop + for i from 1 + while (comp-dead-assignments-func) + finally (comp-log (format "dead code rm run %d times\n" i) 2) + (comp-log-func comp-func 3)) + (comp-remove-type-hints-func) + (comp-log-func comp-func 3))) + (comp-ctxt-funcs-h comp-ctxt)))) + + +;;; Final pass specific code. + +(defun comp-compile-ctxt-to-file (name) + "Compile as native code the current context naming it NAME. +Prepare every function for final compilation and drive the C back-end." + (cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt)) + (hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt)))) + (comp--compile-ctxt-to-file name)) + +(defun comp-final (_) + "Final pass driving the C back-end for code emission." + (let (compile-result) + (maphash (lambda (_ f) + (comp-log-func f 1)) + (comp-ctxt-funcs-h comp-ctxt)) + (comp--init-ctxt) + (unwind-protect + (setf compile-result + (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt))) + (and (comp--release-ctxt) + compile-result)))) + + +;;; Compiler type hints. +;; These are public entry points be used in user code to give comp suggestion +;; about types. +;; These can be used to implement CL style 'the', 'declare' or something like. +;; Note: types will propagates. +;; WARNING: At speed >= 2 type checking is not performed anymore and suggestions +;; are assumed just to be true. Use with extreme caution... + +(defun comp-hint-fixnum (x) + (unless (fixnump x) + (signal 'wrong-type-argument x))) + +(defun comp-hint-cons (x) + (unless (consp x) + (signal 'wrong-type-argument x))) + + +;; Some entry point support code. + +(defvar comp-src-pool () + "List containing the files to be compiled.") + +(defvar comp-prc-pool () + "List containing all async compilation processes.") + +(defun comp-to-file-p (file) + "Return t if FILE has to be compiled." + (let ((compiled-f (concat file "n"))) + (or comp-always-compile + (not (and (file-exists-p compiled-f) + (file-newer-than-file-p compiled-f file)))))) + +(cl-defun comp-start-async-worker () + "Run an async compile worker." + (let (f) + (while (setf f (pop comp-src-pool)) + (when (comp-to-file-p f) + (let* ((code `(progn + (require 'comp) + (setf comp-speed ,comp-speed + comp-debug ,comp-debug + comp-verbose ,comp-verbose + load-path ',load-path) + (message "Compiling %s started." ,f) + (native-compile ,f)))) + (push (make-process :name (concat "Compiling: " f) + :buffer (get-buffer-create comp-async-buffer-name) + :command (list (concat invocation-directory + invocation-name) + "--batch" + "--eval" + (prin1-to-string code)) + :sentinel (lambda (prc _event) + (accept-process-output prc) + (comp-start-async-worker))) + comp-prc-pool) + (cl-return-from comp-start-async-worker)))) + (when (cl-notany #'process-live-p comp-prc-pool) + (let ((msg "Compilation finished.")) + (setf comp-prc-pool ()) + (with-current-buffer (get-buffer-create comp-async-buffer-name) + (save-excursion + (goto-char (point-max)) + (insert msg "\n"))) + (message msg))))) + +;;; Compiler entry points. + +;;;###autoload +(defun native-compile (input) + "Compile INPUT into native code. +This is the entry-point for the Emacs Lisp native compiler. +If INPUT is a symbol, native compile its function definition. +If INPUT is a string, use it as the file path to be native compiled. +Return the compilation unit file name." + (unless (or (symbolp input) + (stringp input)) + (signal 'native-compiler-error + (list "not a symbol function or file" input))) + (let ((data input) + (comp-native-compiling t) + (comp-ctxt (make-comp-ctxt + :output (if (symbolp input) + (make-temp-file (concat (symbol-name input) "-")) + (file-name-sans-extension (expand-file-name input)))))) + (comp-log "\n \n" 1) + (condition-case err + (mapc (lambda (pass) + (comp-log (format "Running pass %s:\n" pass) 2) + (setf data (funcall pass data))) + comp-passes) + (native-compiler-error + ;; Add source input. + (let ((err-val (cdr err))) + (signal (car err) (if (consp err-val) + (cons input err-val) + (list input err-val)))))) + data)) + +;;;###autoload +(defun native-compile-async (input &optional jobs recursively) + "Compile INPUT asynchronously. +INPUT can be either a list of files a folder or a file. +JOBS specifies the number of jobs (commands) to run simultaneously (1 default). +Follow folders RECURSIVELY if non nil." + (let ((jobs (or jobs 1)) + (files (if (listp input) + input + (if (file-directory-p input) + (if recursively + (directory-files-recursively input "\\.el$") + (directory-files input t "\\.el$")) + (if (file-exists-p input) + (list input) + (signal 'native-compiler-error + "input not a file nor directory")))))) + (setf comp-src-pool (nconc files comp-src-pool)) + (cl-loop repeat jobs + do (comp-start-async-worker)) + (message "Compilation started."))) + +(provide 'comp) + +;;; comp.el ends here diff --git a/src/Makefile.in b/src/Makefile.in index 76aa6a1..fd189e9 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -326,6 +326,10 @@ GETLOADAVG_LIBS = GMP_LIB = @GMP_LIB@ GMP_OBJ = @GMP_OBJ@ +LIBGCCJIT = @LIBGCCJIT_LIB@ +## dynlib.o comp.o if native compiler is enabled, else empty +COMP_OBJ = @COMP_OBJ@ + RUN_TEMACS = ./temacs # Whether builds should contain details. '--no-build-details' or empty. @@ -414,7 +418,7 @@ base_obj = cmds.o casetab.o casefiddle.o indent.o search.o regex-emacs.o undo.o \ alloc.o pdumper.o data.o doc.o editfns.o callint.o \ eval.o floatfns.o fns.o font.o print.o lread.o $(MODULES_OBJ) \ - syntax.o $(UNEXEC_OBJ) bytecode.o \ + syntax.o $(UNEXEC_OBJ) bytecode.o $(COMP_OBJ) \ process.o gnutls.o callproc.o \ region-cache.o sound.o timefns.o atimer.o \ doprnt.o intervals.o textprop.o composite.o xml.o lcms.o $(NOTIFY_OBJ) \ @@ -531,7 +535,7 @@ LIBES = $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(HARFBUZZ_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \ $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ - $(JSON_LIBS) $(GMP_LIB) + $(JSON_LIBS) $(GMP_LIB) $(LIBGCCJIT) ## FORCE it so that admin/unidata can decide whether this file is ## up-to-date. Although since charprop depends on bootstrap-emacs, diff --git a/src/comp.c b/src/comp.c new file mode 100644 index 0000000..e2629de --- /dev/null +++ b/src/comp.c @@ -0,0 +1,3480 @@ +/* Compile elisp into native code. + Copyright (C) 2019 Free Software Foundation, Inc. + +Author: Andrea Corallo + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see . */ + +#include + +#ifdef HAVE_NATIVE_COMP + +#include +#include +#include +#include + +#include "lisp.h" +#include "puresize.h" +#include "window.h" +#include "dynlib.h" +#include "buffer.h" +#include "blockinput.h" + +/* C symbols emitted for the load relocation mechanism. */ +#define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" +#define PURE_RELOC_SYM "pure_reloc" +#define DATA_RELOC_SYM "d_reloc" +#define IMPORTED_FUNC_RELOC_SYM "f_reloc" +#define TEXT_DATA_RELOC_SYM "text_data_reloc" +#define TEXT_IMPORTED_FUNC_RELOC_SYM "text_imported_funcs" + +#define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) +#define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) + +#define STR_VALUE(s) #s +#define STR(s) STR_VALUE (s) + +#define FIRST(x) \ + XCAR(x) +#define SECOND(x) \ + XCAR (XCDR (x)) +#define THIRD(x) \ + XCAR (XCDR (XCDR (x))) + +/* Like call1 but stringify and intern. */ +#define CALL1I(fun, arg) \ + CALLN (Ffuncall, intern_c_string (STR (fun)), arg) + +#define DECL_BLOCK(name, func) \ + gcc_jit_block *(name) = \ + gcc_jit_function_new_block ((func), STR (name)) + +#ifdef HAVE__SETJMP +#define SETJMP _setjmp +#else +#define SETJMP setjmp +#endif +#define SETJMP_NAME STR (SETJMP) + +/* C side of the compiler context. */ + +typedef struct { + gcc_jit_context *ctxt; + gcc_jit_type *void_type; + gcc_jit_type *bool_type; + gcc_jit_type *char_type; + gcc_jit_type *int_type; + gcc_jit_type *unsigned_type; + gcc_jit_type *long_type; + gcc_jit_type *unsigned_long_type; + gcc_jit_type *long_long_type; + gcc_jit_type *unsigned_long_long_type; + gcc_jit_type *emacs_int_type; + gcc_jit_type *void_ptr_type; + gcc_jit_type *char_ptr_type; + gcc_jit_type *ptrdiff_type; + gcc_jit_type *uintptr_type; + gcc_jit_type *lisp_obj_type; + gcc_jit_type *lisp_obj_ptr_type; + gcc_jit_field *lisp_obj_as_ptr; + gcc_jit_field *lisp_obj_as_num; + /* struct Lisp_Cons */ + gcc_jit_struct *lisp_cons_s; + gcc_jit_field *lisp_cons_u; + gcc_jit_field *lisp_cons_u_s; + gcc_jit_field *lisp_cons_u_s_car; + gcc_jit_field *lisp_cons_u_s_u; + gcc_jit_field *lisp_cons_u_s_u_cdr; + gcc_jit_type *lisp_cons_type; + gcc_jit_type *lisp_cons_ptr_type; + /* struct jmp_buf. */ + gcc_jit_struct *jmp_buf_s; + /* struct handler. */ + gcc_jit_struct *handler_s; + gcc_jit_field *handler_jmp_field; + gcc_jit_field *handler_val_field; + gcc_jit_field *handler_next_field; + gcc_jit_type *handler_ptr_type; + gcc_jit_lvalue *loc_handler; + /* struct thread_state. */ + gcc_jit_struct *thread_state_s; + gcc_jit_field *m_handlerlist; + gcc_jit_type *thread_state_ptr_type; + gcc_jit_rvalue *current_thread_ref; + /* Other globals. */ + gcc_jit_rvalue *pure_ref; + /* libgccjit has really limited support for casting therefore this union will + be used for the scope. */ + gcc_jit_type *cast_union_type; + gcc_jit_field *cast_union_as_ll; + gcc_jit_field *cast_union_as_ull; + gcc_jit_field *cast_union_as_l; + gcc_jit_field *cast_union_as_ul; + gcc_jit_field *cast_union_as_u; + gcc_jit_field *cast_union_as_i; + gcc_jit_field *cast_union_as_b; + gcc_jit_field *cast_union_as_uintptr; + gcc_jit_field *cast_union_as_ptrdiff; + gcc_jit_field *cast_union_as_c_p; + gcc_jit_field *cast_union_as_v_p; + gcc_jit_field *cast_union_as_lisp_cons_ptr; + gcc_jit_field *cast_union_as_lisp_obj; + gcc_jit_field *cast_union_as_lisp_obj_ptr; + gcc_jit_function *func; /* Current function being compiled. */ + gcc_jit_block *block; /* Current basic block being compiled. */ + gcc_jit_lvalue **frame; /* Frame for the current function. */ + gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ + gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ + gcc_jit_rvalue *most_positive_fixnum; + gcc_jit_rvalue *most_negative_fixnum; + gcc_jit_rvalue *one; + gcc_jit_rvalue *inttypebits; + gcc_jit_rvalue *lisp_int0; + gcc_jit_function *pseudovectorp; + gcc_jit_function *bool_to_lisp_obj; + gcc_jit_function *add1; + gcc_jit_function *sub1; + gcc_jit_function *negate; + gcc_jit_function *car; + gcc_jit_function *cdr; + gcc_jit_function *setcar; + gcc_jit_function *setcdr; + gcc_jit_function *check_type; + gcc_jit_function *check_impure; + Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */ + Lisp_Object exported_funcs_h; /* subr_name -> gcc_jit_function *. */ + Lisp_Object imported_funcs_h; /* subr_name -> reloc_field. */ + Lisp_Object emitter_dispatcher; + gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs. */ + gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs. */ +} comp_t; + +static comp_t comp; + +FILE *logfile = NULL; + +/* This is used for serialized objects by the reload mechanism. */ +typedef struct { + ptrdiff_t len; + const char data[]; +} static_obj_t; + + +/* + Helper functions called by the run-time. +*/ +Lisp_Object helper_save_window_excursion (Lisp_Object v1); +void helper_unwind_protect (Lisp_Object handler); +Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); +Lisp_Object helper_unbind_n (Lisp_Object n); +void helper_save_restriction (void); +bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code); + + +static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) +format_string (const char *format, ...) +{ + static char scratch_area[512]; + va_list va; + va_start (va, format); + int res = vsnprintf (scratch_area, sizeof (scratch_area), format, va); + if (res >= sizeof (scratch_area)) + { + scratch_area[sizeof (scratch_area) - 4] = '.'; + scratch_area[sizeof (scratch_area) - 3] = '.'; + scratch_area[sizeof (scratch_area) - 2] = '.'; + } + va_end (va); + return scratch_area; +} + +static void +bcall0 (Lisp_Object f) +{ + Ffuncall (1, &f); +} + +/* Try to return the original subr from `symbol' even if this was advised. */ +static Lisp_Object +symbol_subr (Lisp_Object symbol) +{ + Lisp_Object maybe_subr = Fsymbol_function (symbol); + + if (SUBRP (maybe_subr)) + return maybe_subr; + + if (!NILP (CALL1I (advice--p, maybe_subr))) + maybe_subr = CALL1I (ad-get-orig-definition, symbol); + + return SUBRP (maybe_subr) ? maybe_subr : Qnil; +} + +static gcc_jit_field * +type_to_cast_field (gcc_jit_type *type) +{ + gcc_jit_field *field; + + if (type == comp.long_long_type) + field = comp.cast_union_as_ll; + else if (type == comp.unsigned_long_long_type) + field = comp.cast_union_as_ull; + else if (type == comp.long_type) + field = comp.cast_union_as_l; + else if (type == comp.unsigned_long_type) + field = comp.cast_union_as_ul; + else if (type == comp.unsigned_type) + field = comp.cast_union_as_u; + else if (type == comp.int_type) + field = comp.cast_union_as_i; + else if (type == comp.bool_type) + field = comp.cast_union_as_b; + else if (type == comp.void_ptr_type) + field = comp.cast_union_as_v_p; + else if (type == comp.uintptr_type) + field = comp.cast_union_as_uintptr; + else if (type == comp.ptrdiff_type) + field = comp.cast_union_as_ptrdiff; + else if (type == comp.char_ptr_type) + field = comp.cast_union_as_c_p; + else if (type == comp.lisp_cons_ptr_type) + field = comp.cast_union_as_lisp_cons_ptr; + else if (type == comp.lisp_obj_type) + field = comp.cast_union_as_lisp_obj; + else if (type == comp.lisp_obj_ptr_type) + field = comp.cast_union_as_lisp_obj_ptr; + else + xsignal1 (Qnative_ice, build_string ("unsupported cast")); + + return field; +} + +static gcc_jit_block * +retrive_block (Lisp_Object block_name) +{ + Lisp_Object value = Fgethash (block_name, comp.func_blocks_h, Qnil); + + if (NILP (value)) + xsignal1 (Qnative_ice, build_string ("missing basic block")); + + return (gcc_jit_block *) xmint_pointer (value); +} + +static void +declare_block (Lisp_Object block_name) +{ + char *name_str = SSDATA (SYMBOL_NAME (block_name)); + gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str); + Lisp_Object value = make_mint_ptr (block); + + if (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil))) + xsignal1 (Qnative_ice, build_string ("double basic block declaration")); + + Fputhash (block_name, value, comp.func_blocks_h); +} + +static gcc_jit_lvalue * +get_slot (Lisp_Object mvar) +{ + EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, mvar)); + if (slot_n == -1) + { + if (!comp.scratch) + comp.scratch = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + "scratch"); + return comp.scratch; + } + gcc_jit_lvalue **frame = + (CALL1I (comp-mvar-ref, mvar) || SPEED < 2) + ? comp.frame : comp.f_frame; + return frame[slot_n]; +} + +static void +register_emitter (Lisp_Object key, void *func) +{ + Lisp_Object value = make_mint_ptr (func); + Fputhash (key, value, comp.emitter_dispatcher); +} + +static void +emit_comment (const char *str) +{ + if (COMP_DEBUG) + gcc_jit_block_add_comment (comp.block, + NULL, + str); +} + +/* + Declare an imported function. + When nargs is MANY (ptrdiff_t nargs, Lisp_Object *args) signature is assumed. + When types is NULL args are assumed to be all Lisp_Objects. +*/ +static gcc_jit_field * +declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, + int nargs, gcc_jit_type **types) +{ + /* Don't want to declare the same function two times. */ + if (!NILP (Fgethash (subr_sym, comp.imported_funcs_h, Qnil))) + xsignal2 (Qnative_ice, + build_string ("unexpected double function declaration"), + subr_sym); + + if (nargs == MANY) + { + nargs = 2; + types = alloca (nargs * sizeof (* types)); + types[0] = comp.ptrdiff_type; + types[1] = comp.lisp_obj_ptr_type; + } + else if (nargs == UNEVALLED) + { + nargs = 1; + types = alloca (nargs * sizeof (* types)); + types[0] = comp.lisp_obj_type; + } + else if (!types) + { + types = alloca (nargs * sizeof (* types)); + for (ptrdiff_t i = 0; i < nargs; i++) + types[i] = comp.lisp_obj_type; + } + + /* String containing the function ptr name. */ + Lisp_Object f_ptr_name = + CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), + subr_sym, make_string ("R", 1)); + + gcc_jit_type *f_ptr_type = + gcc_jit_context_new_function_ptr_type (comp.ctxt, + NULL, + ret_type, + nargs, + types, + 0); + gcc_jit_field *field = + gcc_jit_context_new_field (comp.ctxt, + NULL, + f_ptr_type, + SSDATA (f_ptr_name)); + + Fputhash (subr_sym, make_mint_ptr (field), comp.imported_funcs_h); + return field; +} + +/* Emit calls fetching from existing declarations. */ +static gcc_jit_rvalue * +emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, + gcc_jit_rvalue **args, bool direct) +{ + Lisp_Object func = + Fgethash (subr_sym, direct ? comp.exported_funcs_h: comp.imported_funcs_h, + Qnil); + if (NILP (func)) + xsignal2 (Qnative_ice, + build_string ("missing function declaration"), + subr_sym); + + if (direct) + { + emit_comment (format_string ("direct call to subr: %s", + SSDATA (SYMBOL_NAME (subr_sym)))); + return gcc_jit_context_new_call (comp.ctxt, + NULL, + xmint_pointer (func), + nargs, + args); + } + else + { + gcc_jit_lvalue *f_ptr = + gcc_jit_lvalue_access_field (comp.func_relocs, + NULL, + (gcc_jit_field *) xmint_pointer (func)); + if (!f_ptr) + xsignal2 (Qnative_ice, + build_string ("missing function relocation"), + subr_sym); + emit_comment (format_string ("calling subr: %s", + SSDATA (SYMBOL_NAME (subr_sym)))); + return gcc_jit_context_new_call_through_ptr (comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (f_ptr), + nargs, + args); + } +} + +static gcc_jit_rvalue * +emit_call_ref (Lisp_Object subr_sym, ptrdiff_t nargs, + gcc_jit_lvalue *base_arg, bool direct) +{ + gcc_jit_rvalue *args[] = + { gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + nargs), + gcc_jit_lvalue_get_address (base_arg, NULL) }; + return emit_call (subr_sym, comp.lisp_obj_type, 2, args, direct); +} + +/* Close current basic block emitting a conditional. */ + +static void +emit_cond_jump (gcc_jit_rvalue *test, + gcc_jit_block *then_target, gcc_jit_block *else_target) +{ + if (gcc_jit_rvalue_get_type (test) == comp.bool_type) + gcc_jit_block_end_with_conditional (comp.block, + NULL, + test, + then_target, + else_target); + else + /* In case test is not bool we do a logical negation to obtain a bool as + result. */ + gcc_jit_block_end_with_conditional ( + comp.block, + NULL, + gcc_jit_context_new_unary_op (comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.bool_type, + test), + else_target, + then_target); + +} + +static gcc_jit_rvalue * +emit_cast (gcc_jit_type *new_type, gcc_jit_rvalue *obj) +{ + static ptrdiff_t i; + + gcc_jit_field *orig_field = + type_to_cast_field (gcc_jit_rvalue_get_type (obj)); + gcc_jit_field *dest_field = type_to_cast_field (new_type); + + gcc_jit_lvalue *tmp_u = + gcc_jit_function_new_local (comp.func, + NULL, + comp.cast_union_type, + format_string ("union_cast_%td", i++)); + gcc_jit_block_add_assignment (comp.block, + NULL, + gcc_jit_lvalue_access_field (tmp_u, + NULL, + orig_field), + obj); + + return gcc_jit_rvalue_access_field ( gcc_jit_lvalue_as_rvalue (tmp_u), + NULL, + dest_field); +} + +/* + Emit the equivalent of: + (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i) +*/ + +static gcc_jit_rvalue * +emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, + int size_of_ptr_ref, gcc_jit_rvalue *i) +{ + emit_comment ("ptr_arithmetic"); + + gcc_jit_rvalue *offset = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MULT, + comp.uintptr_type, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, + size_of_ptr_ref), + emit_cast (comp.uintptr_type, i)); + + return + emit_cast ( + ptr_type, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.uintptr_type, + emit_cast (comp.uintptr_type, ptr), + offset)); +} + +static gcc_jit_rvalue * +emit_XLI (gcc_jit_rvalue *obj) +{ + emit_comment ("XLI"); + + return gcc_jit_rvalue_access_field (obj, + NULL, + comp.lisp_obj_as_num); +} + +static gcc_jit_lvalue * +emit_lval_XLI (gcc_jit_lvalue *obj) +{ + emit_comment ("lval_XLI"); + + return gcc_jit_lvalue_access_field (obj, + NULL, + comp.lisp_obj_as_num); +} + +/* +static gcc_jit_rvalue * +emit_XLP (gcc_jit_rvalue *obj) +{ + emit_comment ("XLP"); + + return gcc_jit_rvalue_access_field (obj, + NULL, + comp.lisp_obj_as_ptr); +} + +static gcc_jit_lvalue * +emit_lval_XLP (gcc_jit_lvalue *obj) +{ + emit_comment ("lval_XLP"); + + return gcc_jit_lvalue_access_field (obj, + NULL, + comp.lisp_obj_as_ptr); +} */ +static gcc_jit_rvalue * +emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, ptrdiff_t lisp_word_tag) +{ + /* #define XUNTAG(a, type, ctype) ((ctype *) + ((char *) XLP (a) - LISP_WORD_TAG (type))) */ + emit_comment ("XUNTAG"); + + return emit_cast (gcc_jit_type_get_pointer (type), + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.emacs_int_type, + emit_XLI (a), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_int_type, + lisp_word_tag))); +} + +static gcc_jit_rvalue * +emit_XCONS (gcc_jit_rvalue *a) +{ + emit_comment ("XCONS"); + + return emit_XUNTAG (a, + gcc_jit_struct_as_type (comp.lisp_cons_s), + LISP_WORD_TAG (Lisp_Cons)); +} + +static gcc_jit_rvalue * +emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +{ + emit_comment ("EQ"); + + return gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_EQ, + emit_XLI (x), + emit_XLI (y)); +} + +static gcc_jit_rvalue * +emit_TAGGEDP (gcc_jit_rvalue *obj, ptrdiff_t tag) +{ + /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ + - (unsigned) (tag)) \ + & ((1 << GCTYPEBITS) - 1))) */ + emit_comment ("TAGGEDP"); + + gcc_jit_rvalue *sh_res = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + emit_XLI (obj), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_int_type, + (USE_LSB_TAG ? 0 : VALBITS))); + + gcc_jit_rvalue *minus_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_type, + emit_cast (comp.unsigned_type, sh_res), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + tag)); + + gcc_jit_rvalue *res = + gcc_jit_context_new_unary_op ( + comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.int_type, + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.unsigned_type, + minus_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + ((1 << GCTYPEBITS) - 1)))); + + return res; +} + +static gcc_jit_rvalue * +emit_VECTORLIKEP (gcc_jit_rvalue *obj) +{ + emit_comment ("VECTORLIKEP"); + + return emit_TAGGEDP (obj, Lisp_Vectorlike); +} + +static gcc_jit_rvalue * +emit_CONSP (gcc_jit_rvalue *obj) +{ + emit_comment ("CONSP"); + + return emit_TAGGEDP (obj, Lisp_Cons); +} + +static gcc_jit_rvalue * +emit_FLOATP (gcc_jit_rvalue *obj) +{ + emit_comment ("FLOATP"); + + return emit_TAGGEDP (obj, Lisp_Float); +} + +static gcc_jit_rvalue * +emit_BIGNUMP (gcc_jit_rvalue *obj) +{ + /* PSEUDOVECTORP (x, PVEC_BIGNUM); */ + emit_comment ("BIGNUMP"); + + gcc_jit_rvalue *args[] = + { obj, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + PVEC_BIGNUM) }; + + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.pseudovectorp, + 2, + args); +} + +static gcc_jit_rvalue * +emit_FIXNUMP (gcc_jit_rvalue *obj) +{ + /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) + - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) + & ((1 << INTTYPEBITS) - 1))) */ + emit_comment ("FIXNUMP"); + + gcc_jit_rvalue *sh_res = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + emit_XLI (obj), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_int_type, + (USE_LSB_TAG ? 0 : FIXNUM_BITS))); + + gcc_jit_rvalue *minus_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_type, + emit_cast (comp.unsigned_type, sh_res), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + (Lisp_Int0 >> !USE_LSB_TAG))); + + gcc_jit_rvalue *res = + gcc_jit_context_new_unary_op ( + comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.int_type, + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.unsigned_type, + minus_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + ((1 << INTTYPEBITS) - 1)))); + + return res; +} + +static gcc_jit_rvalue * +emit_XFIXNUM (gcc_jit_rvalue *obj) +{ + emit_comment ("XFIXNUM"); + + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + emit_XLI (obj), + comp.inttypebits); +} + +static gcc_jit_rvalue * +emit_INTEGERP (gcc_jit_rvalue *obj) +{ + emit_comment ("INTEGERP"); + + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_cast (comp.bool_type, + emit_FIXNUMP (obj)), + emit_BIGNUMP (obj)); +} + +static gcc_jit_rvalue * +emit_NUMBERP (gcc_jit_rvalue *obj) +{ + emit_comment ("NUMBERP"); + + return gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_INTEGERP (obj), + emit_cast (comp.bool_type, + emit_FLOATP (obj))); +} + +static gcc_jit_rvalue * +emit_make_fixnum (gcc_jit_rvalue *obj) +{ + emit_comment ("make_fixnum"); + + gcc_jit_rvalue *tmp = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_int_type, + obj, + comp.inttypebits); + + tmp = gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_PLUS, + comp.emacs_int_type, + tmp, + comp.lisp_int0); + + gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + "lisp_obj_fixnum"); + + gcc_jit_block_add_assignment (comp.block, + NULL, + emit_lval_XLI (res), + tmp); + + return gcc_jit_lvalue_as_rvalue (res); +} + +static gcc_jit_rvalue * +emit_const_lisp_obj (Lisp_Object obj) +{ + emit_comment (format_string ("const lisp obj: %s", + SSDATA (Fprin1_to_string (obj, Qnil)))); + + if (Qnil == NULL && EQ (obj, Qnil)) + return emit_cast (comp.lisp_obj_type, + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + NULL)); + + Lisp_Object d_reloc_idx = CALL1I (comp-ctxt-data-relocs-idx, Vcomp_ctxt); + ptrdiff_t reloc_fixn = XFIXNUM (Fgethash (obj, d_reloc_idx, Qnil)); + gcc_jit_rvalue *reloc_n = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + reloc_fixn); + return + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_array_access (comp.ctxt, + NULL, + comp.data_relocs, + reloc_n)); +} + +static gcc_jit_rvalue * +emit_NILP (gcc_jit_rvalue *x) +{ + emit_comment ("NILP"); + return emit_EQ (x, emit_const_lisp_obj (Qnil)); +} + +static gcc_jit_rvalue * +emit_XCAR (gcc_jit_rvalue *c) +{ + emit_comment ("XCAR"); + + /* XCONS (c)->u.s.car */ + return + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u.s */ + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u */ + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + emit_XCONS (c), + NULL, + comp.lisp_cons_u)), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_car); +} + +static gcc_jit_lvalue * +emit_lval_XCAR (gcc_jit_rvalue *c) +{ + emit_comment ("lval_XCAR"); + + /* XCONS (c)->u.s.car */ + return + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u.s */ + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u */ + gcc_jit_rvalue_dereference_field ( + emit_XCONS (c), + NULL, + comp.lisp_cons_u), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_car); +} + +static gcc_jit_rvalue * +emit_XCDR (gcc_jit_rvalue *c) +{ + emit_comment ("XCDR"); + /* XCONS (c)->u.s.u.cdr */ + return + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u.s.u */ + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u.s */ + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u */ + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + emit_XCONS (c), + NULL, + comp.lisp_cons_u)), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_u), + NULL, + comp.lisp_cons_u_s_u_cdr); +} + +static gcc_jit_lvalue * +emit_lval_XCDR (gcc_jit_rvalue *c) +{ + emit_comment ("lval_XCDR"); + + /* XCONS (c)->u.s.u.cdr */ + return + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u.s.u */ + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u.s */ + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u */ + gcc_jit_rvalue_dereference_field ( + emit_XCONS (c), + NULL, + comp.lisp_cons_u), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_u), + NULL, + comp.lisp_cons_u_s_u_cdr); +} + +static void +emit_CHECK_CONS (gcc_jit_rvalue *x) +{ + emit_comment ("CHECK_CONS"); + + gcc_jit_rvalue *args[] = + { emit_CONSP (x), + emit_const_lisp_obj (Qconsp), + x }; + + gcc_jit_block_add_eval ( + comp.block, + NULL, + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_type, + 3, + args)); +} + +static gcc_jit_rvalue * +emit_car_addr (gcc_jit_rvalue *c) +{ + emit_comment ("car_addr"); + + return gcc_jit_lvalue_get_address (emit_lval_XCAR (c), NULL); +} + +static gcc_jit_rvalue * +emit_cdr_addr (gcc_jit_rvalue *c) +{ + emit_comment ("cdr_addr"); + + return gcc_jit_lvalue_get_address (emit_lval_XCDR (c), NULL); +} + +static void +emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) +{ + emit_comment ("XSETCAR"); + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + gcc_jit_rvalue_dereference ( + emit_car_addr (c), + NULL), + n); +} + +static void +emit_XSETCDR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) +{ + emit_comment ("XSETCDR"); + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + gcc_jit_rvalue_dereference ( + emit_cdr_addr (c), + NULL), + n); +} + +static gcc_jit_rvalue * +emit_PURE_P (gcc_jit_rvalue *ptr) +{ + + emit_comment ("PURE_P"); + + return + gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_LE, + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.uintptr_type, + emit_cast (comp.uintptr_type, ptr), + emit_cast (comp.uintptr_type, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.pure_ref, NULL)))), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, + PURESIZE)); +} + + +/*************************************/ +/* Code emitted by LIMPLE statemes. */ +/*************************************/ + +/* Emit an r-value from an mvar meta variable. + In case this is a constant that was propagated return it otherwise load it + from frame. */ + +static gcc_jit_rvalue * +emit_mvar_val (Lisp_Object mvar) +{ + Lisp_Object const_vld = CALL1I (comp-mvar-const-vld, mvar); + Lisp_Object constant = CALL1I (comp-mvar-constant, mvar); + + if (!NILP (const_vld)) + { + if (FIXNUMP (constant)) + { + /* We can still emit directly objects that are self-contained in a + word (read fixnums). */ + emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); + gcc_jit_rvalue *word = + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + constant); + return emit_cast (comp.lisp_obj_type, word); + } + /* Other const objects are fetched from the reloc array. */ + return emit_const_lisp_obj (constant); + } + + return gcc_jit_lvalue_as_rvalue (get_slot (mvar)); +} + +static void +emit_frame_assignment (Lisp_Object dst_mvar, gcc_jit_rvalue *val) +{ + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + get_slot (dst_mvar), + val); +} + +static gcc_jit_rvalue * +emit_set_internal (Lisp_Object args) +{ + /* + Ex: (set_internal #s(comp-mvar nil nil t comp-test-up-val nil nil) + #s(comp-mvar 1 4 t nil symbol nil)). + */ + /* TODO: Inline the most common case. */ + if (list_length (args) != 3) + xsignal2 (Qnative_ice, + build_string ("unexpected arg length for insns"), + args); + + args = XCDR (args); + int i = 0; + gcc_jit_rvalue *gcc_args[4]; + FOR_EACH_TAIL (args) + gcc_args[i++] = emit_mvar_val (XCAR (args)); + gcc_args[2] = emit_const_lisp_obj (Qnil); + gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + SET_INTERNAL_SET); + return emit_call (intern_c_string ("set_internal"), comp.void_type , 4, + gcc_args, false); +} + +/* This is for a regular function with arguments as m-var. */ + +static gcc_jit_rvalue * +emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type, bool direct) +{ + USE_SAFE_ALLOCA; + int i = 0; + Lisp_Object callee = FIRST (args); + args = XCDR (args); + ptrdiff_t nargs = list_length (args); + gcc_jit_rvalue **gcc_args = SAFE_ALLOCA (nargs * sizeof (*gcc_args)); + FOR_EACH_TAIL (args) + gcc_args[i++] = emit_mvar_val (XCAR (args)); + + SAFE_FREE (); + return emit_call (callee, ret_type, nargs, gcc_args, direct); +} + +static gcc_jit_rvalue * +emit_simple_limple_call_lisp_ret (Lisp_Object args) +{ + /* + Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) #s(comp-mvar 4 nil t nil nil)). + */ + return emit_simple_limple_call (args, comp.lisp_obj_type, false); +} + +static gcc_jit_rvalue * +emit_simple_limple_call_void_ret (Lisp_Object args) +{ + return emit_simple_limple_call (args, comp.void_type, false); +} + +/* Entry point to dispatch emitting (call fun ...). */ + +static gcc_jit_rvalue * +emit_limple_call (Lisp_Object insn) +{ + Lisp_Object callee_sym = FIRST (insn); + Lisp_Object emitter = Fgethash (callee_sym, comp.emitter_dispatcher, Qnil); + + if (!NILP (emitter)) + { + gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = xmint_pointer (emitter); + return emitter_ptr (insn); + } + + return emit_simple_limple_call_lisp_ret (insn); +} + +static gcc_jit_rvalue * +emit_limple_call_ref (Lisp_Object insn, bool direct) +{ + /* Ex: (funcall #s(comp-mvar 1 5 t eql symbol t) + #s(comp-mvar 2 6 nil nil nil t) + #s(comp-mvar 3 7 t 0 fixnum t)). */ + + Lisp_Object callee = FIRST (insn); + EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); + EMACS_INT base_ptr = 0; + if (nargs) + base_ptr = XFIXNUM (CALL1I (comp-mvar-slot, SECOND (insn))); + return emit_call_ref (callee, nargs, comp.frame[base_ptr], direct); +} + +/* Register an handler for a non local exit. */ + +static void +emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, + gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb, + Lisp_Object clobbered_mvar) +{ + /* struct handler *c = push_handler (POP, type); */ + + gcc_jit_rvalue *args[] = { handler, handler_type }; + gcc_jit_block_add_assignment ( + comp.block, + NULL, + comp.loc_handler, + emit_call (intern_c_string ("push_handler"), + comp.handler_ptr_type, 2, args, false)); + + args[0] = + gcc_jit_lvalue_get_address ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (comp.loc_handler), + NULL, + comp.handler_jmp_field), + NULL); + + gcc_jit_rvalue *res; + res = + emit_call (intern_c_string (SETJMP_NAME), comp.int_type, 1, args, false); + emit_cond_jump (res, handler_bb, guarded_bb); +} + +static void +emit_limple_insn (Lisp_Object insn) +{ + Lisp_Object op = XCAR (insn); + Lisp_Object args = XCDR (insn); + gcc_jit_rvalue *res; + Lisp_Object arg[6]; + + Lisp_Object p = XCDR (insn); + ptrdiff_t i = 0; + FOR_EACH_TAIL (p) + { + if (i == sizeof (arg) / sizeof (Lisp_Object)) + break; + arg[i++] = XCAR (p); + } + + if (EQ (op, Qjump)) + { + /* Unconditional branch. */ + gcc_jit_block *target = retrive_block (arg[0]); + gcc_jit_block_end_with_jump (comp.block, NULL, target); + } + else if (EQ (op, Qcond_jump)) + { + /* Conditional branch. */ + gcc_jit_rvalue *a = emit_mvar_val (arg[0]); + gcc_jit_rvalue *b = emit_mvar_val (arg[1]); + gcc_jit_block *target1 = retrive_block (arg[2]); + gcc_jit_block *target2 = retrive_block (arg[3]); + + emit_cond_jump (emit_EQ (a, b), target2, target1); + } + else if (EQ (op, Qcond_jump_narg_leq)) + { + /* + Limple: (cond-jump-narg-less 2 entry_2 entry_fallback_2) + C: if (nargs < 2) goto entry2_fallback; else goto entry_2; + */ + gcc_jit_lvalue *nargs = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); + gcc_jit_rvalue *n = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + XFIXNUM (arg[0])); + gcc_jit_block *target1 = retrive_block (arg[1]); + gcc_jit_block *target2 = retrive_block (arg[2]); + gcc_jit_rvalue *test = gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_LE, + gcc_jit_lvalue_as_rvalue (nargs), + n); + emit_cond_jump (test, target2, target1); + } + else if (EQ (op, Qphi)) + { + /* Nothing to do for phis into the backend. */ + } + else if (EQ (op, Qpush_handler)) + { + /* (push-handler condition-case #s(comp-mvar 0 3 t (arith-error) cons nil) 1 bb_2 bb_1) */ + int h_num UNINIT; + Lisp_Object handler_spec = arg[0]; + gcc_jit_rvalue *handler = emit_mvar_val (arg[1]); + if (EQ (handler_spec, Qcatcher)) + h_num = CATCHER; + else if (EQ (handler_spec, Qcondition_case)) + h_num = CONDITION_CASE; + else + xsignal2 (Qnative_ice, build_string ("incoherent insn"), insn); + gcc_jit_rvalue *handler_type = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + h_num); + gcc_jit_block *handler_bb = retrive_block (arg[2]); + gcc_jit_block *guarded_bb = retrive_block (arg[3]); + emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb, + arg[0]); + } + else if (EQ (op, Qpop_handler)) + { + /* + C: current_thread->m_handlerlist = + current_thread->m_handlerlist->next; + */ + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)), + NULL, + comp.m_handlerlist); + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (m_handlerlist), + NULL, + comp.handler_next_field))); + + } + else if (EQ (op, Qfetch_handler)) + { + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)), + NULL, + comp.m_handlerlist); + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.loc_handler, + gcc_jit_lvalue_as_rvalue (m_handlerlist)); + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (comp.loc_handler), + NULL, + comp.handler_next_field))); + emit_frame_assignment ( + arg[0], + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (comp.loc_handler), + NULL, + comp.handler_val_field))); + } + else if (EQ (op, Qcall)) + { + gcc_jit_block_add_eval (comp.block, NULL, + emit_limple_call (args)); + } + else if (EQ (op, Qcallref)) + { + gcc_jit_block_add_eval (comp.block, NULL, + emit_limple_call_ref (args, false)); + } + else if (EQ (op, Qdirect_call)) + { + gcc_jit_block_add_eval ( + comp.block, NULL, + emit_simple_limple_call (XCDR (insn), comp.lisp_obj_type, true)); + } + else if (EQ (op, Qdirect_callref)) + { + gcc_jit_block_add_eval (comp.block, NULL, + emit_limple_call_ref (XCDR (insn), true)); + } + else if (EQ (op, Qset)) + { + Lisp_Object arg1 = arg[1]; + + if (EQ (Ftype_of (arg1), Qcomp_mvar)) + res = emit_mvar_val (arg1); + else if (EQ (FIRST (arg1), Qcall)) + res = emit_limple_call (XCDR (arg1)); + else if (EQ (FIRST (arg1), Qcallref)) + res = emit_limple_call_ref (XCDR (arg1), false); + else if (EQ (FIRST (arg1), Qdirect_call)) + res = emit_simple_limple_call (XCDR (arg1), comp.lisp_obj_type, true); + else if (EQ (FIRST (arg1), Qdirect_callref)) + res = emit_limple_call_ref (XCDR (arg1), true); + else + xsignal2 (Qnative_ice, + build_string ("LIMPLE inconsistent arg1 for insn"), + insn); + + if (!res) + xsignal1 (Qnative_ice, + build_string (gcc_jit_context_get_first_error (comp.ctxt))); + + emit_frame_assignment (arg[0], res); + } + else if (EQ (op, Qset_par_to_local)) + { + /* Ex: (set-par-to-local #s(comp-mvar 0 3 nil nil nil nil) 0). */ + EMACS_INT param_n = XFIXNUM (arg[1]); + gcc_jit_rvalue *param = + gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, + param_n)); + emit_frame_assignment (arg[0], param); + } + else if (EQ (op, Qset_args_to_local)) + { + /* + Ex: (set-args-to-local #s(comp-mvar 1 6 nil nil nil nil)) + C: local[1] = *args; + */ + gcc_jit_rvalue *gcc_args = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1))); + + gcc_jit_rvalue *res = + gcc_jit_lvalue_as_rvalue (gcc_jit_rvalue_dereference (gcc_args, NULL)); + + emit_frame_assignment (arg[0], res); + } + else if (EQ (op, Qset_rest_args_to_local)) + { + /* + Ex: (set-rest-args-to-local #s(comp-mvar 2 9 nil nil nil nil)) + C: local[2] = list (nargs - 2, args); + */ + + EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, arg[0])); + gcc_jit_rvalue *n = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + slot_n); + gcc_jit_lvalue *nargs = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); + gcc_jit_lvalue *args = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); + + gcc_jit_rvalue *list_args[] = + { gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_MINUS, + comp.ptrdiff_type, + gcc_jit_lvalue_as_rvalue (nargs), + n), + gcc_jit_lvalue_as_rvalue (args) }; + + res = emit_call (Qlist, comp.lisp_obj_type, 2, + list_args, false); + + emit_frame_assignment (arg[0], res); + } + else if (EQ (op, Qinc_args)) + { + /* + Ex: (inc-args) + C: ++args; + */ + gcc_jit_lvalue *args = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); + + gcc_jit_block_add_assignment (comp.block, + NULL, + args, + emit_ptr_arithmetic ( + gcc_jit_lvalue_as_rvalue (args), + comp.lisp_obj_ptr_type, + sizeof (Lisp_Object), + comp.one)); + } + else if (EQ (op, Qsetimm)) + { + /* Ex: (setimm #s(comp-mvar 9 1 t 3 nil) 3 a). */ + gcc_jit_rvalue *reloc_n = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + XFIXNUM (arg[1])); + emit_comment (SSDATA (Fprin1_to_string (arg[2], Qnil))); + emit_frame_assignment ( + arg[0], + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_array_access (comp.ctxt, + NULL, + comp.data_relocs, + reloc_n))); + } + else if (EQ (op, Qcomment)) + { + /* Ex: (comment "Function: foo"). */ + emit_comment (SSDATA (arg[0])); + } + else if (EQ (op, Qreturn)) + { + gcc_jit_block_end_with_return (comp.block, + NULL, + emit_mvar_val (arg[0])); + } + else + { + xsignal2 (Qnative_ice, + build_string ("LIMPLE op inconsistent"), + op); + } +} + + +/**************/ +/* Inliners. */ +/**************/ + +static gcc_jit_rvalue * +emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn, + Lisp_Object type) +{ + bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type); + gcc_jit_rvalue *args[] = + { emit_mvar_val (SECOND (insn)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.bool_type, + type_hint) }; + + return gcc_jit_context_new_call (comp.ctxt, NULL, func, 2, args); +} + +/* Same as before but with two args. The type hint is on the 2th. */ +static gcc_jit_rvalue * +emit_call2_with_type_hint (gcc_jit_function *func, Lisp_Object insn, + Lisp_Object type) +{ + bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type); + gcc_jit_rvalue *args[] = + { emit_mvar_val (SECOND (insn)), + emit_mvar_val (THIRD (insn)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.bool_type, + type_hint) }; + + return gcc_jit_context_new_call (comp.ctxt, NULL, func, 3, args); +} + + +static gcc_jit_rvalue * +emit_add1 (Lisp_Object insn) +{ + return emit_call_with_type_hint (comp.add1, insn, Qfixnum); +} + +static gcc_jit_rvalue * +emit_sub1 (Lisp_Object insn) +{ + return emit_call_with_type_hint (comp.sub1, insn, Qfixnum); +} + +static gcc_jit_rvalue * +emit_negate (Lisp_Object insn) +{ + return emit_call_with_type_hint (comp.negate, insn, Qfixnum); +} + +static gcc_jit_rvalue * +emit_consp (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + gcc_jit_rvalue *res = emit_cast (comp.bool_type, + emit_CONSP (x)); + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.bool_to_lisp_obj, + 1, &res); +} + +static gcc_jit_rvalue * +emit_car (Lisp_Object insn) +{ + return emit_call_with_type_hint (comp.car, insn, Qcons); +} + +static gcc_jit_rvalue * +emit_cdr (Lisp_Object insn) +{ + return emit_call_with_type_hint (comp.cdr, insn, Qcons); +} + +static gcc_jit_rvalue * +emit_setcar (Lisp_Object insn) +{ + return emit_call2_with_type_hint (comp.setcar, insn, Qcons); +} + +static gcc_jit_rvalue * +emit_setcdr (Lisp_Object insn) +{ + return emit_call2_with_type_hint (comp.setcdr, insn, Qcons); +} + +static gcc_jit_rvalue * +emit_numperp (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + gcc_jit_rvalue *res = emit_NUMBERP (x); + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1, + &res); +} + +static gcc_jit_rvalue * +emit_integerp (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_val (SECOND (insn)); + gcc_jit_rvalue *res = emit_INTEGERP (x); + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1, + &res); +} + +/* This is in charge of serializing an object and export a function to + retrieve it at load time. */ +static void +emit_static_object (const char *name, Lisp_Object obj) +{ + /* libgccjit has no support for initialized static data. + The mechanism below is certainly not aesthetic but I assume the bottle neck + in terms of performance at load time will still be the reader. + NOTE: we can not relay on libgccjit even for valid NULL terminated C + strings cause of this funny bug that will affect all pre gcc10 era gccs: + https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html */ + + Lisp_Object str = Fprin1_to_string (obj, Qnil); + ptrdiff_t len = SBYTES (str); + const char *p = SSDATA (str); + + gcc_jit_type *a_type = + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + len + 1); + gcc_jit_field *fields[] = + { gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.ptrdiff_type, + "len"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + a_type, + "data") }; + + gcc_jit_type *data_struct_t = + gcc_jit_struct_as_type ( + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + format_string ("%s_struct", name), + 2, fields)); + + gcc_jit_lvalue *data_struct = + gcc_jit_context_new_global (comp.ctxt, + NULL, + GCC_JIT_GLOBAL_INTERNAL, + data_struct_t, + format_string ("%s_s", name)); + + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + gcc_jit_type_get_pointer (data_struct_t), + name, + 0, NULL, 0); + DECL_BLOCK (block, f); + + /* NOTE this truncates if the data has some zero byte before termination. */ + gcc_jit_block_add_comment (block, NULL, p); + + gcc_jit_lvalue *arr = + gcc_jit_lvalue_access_field (data_struct, NULL, fields[1]); + + for (ptrdiff_t i = 0; i < len; i++, p++) + { + gcc_jit_block_add_assignment ( + block, + NULL, + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + i)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.char_type, + *p)); + } + gcc_jit_block_add_assignment ( + block, + NULL, + gcc_jit_lvalue_access_field (data_struct, NULL, fields[0]), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + len)); + gcc_jit_rvalue *res = gcc_jit_lvalue_get_address (data_struct, NULL); + gcc_jit_block_end_with_return (block, NULL, res); +} + +static void +declare_runtime_imported_data (void) +{ + /* Imported symbols by inliner functions. */ + CALL1I (comp-add-const-to-relocs, Qnil); + CALL1I (comp-add-const-to-relocs, Qt); + CALL1I (comp-add-const-to-relocs, Qconsp); + CALL1I (comp-add-const-to-relocs, Qlistp); +} + +/* + Declare as imported all the functions that are requested from the runtime. + These are either subrs or not. +*/ +static Lisp_Object +declare_runtime_imported_funcs (void) +{ + /* For subr imported by the runtime we rely on the standard mechanism in place + for functions imported by lisp code. */ + CALL1I (comp-add-subr-to-relocs, intern_c_string ("1+")); + CALL1I (comp-add-subr-to-relocs, intern_c_string ("1-")); + CALL1I (comp-add-subr-to-relocs, Qplus); + CALL1I (comp-add-subr-to-relocs, Qminus); + CALL1I (comp-add-subr-to-relocs, Qlist); + + Lisp_Object field_list = Qnil; +#define ADD_IMPORTED(f_name, ret_type, nargs, args) \ + { \ + Lisp_Object name = intern_c_string (f_name); \ + Lisp_Object field = \ + make_mint_ptr (declare_imported_func (name, ret_type, nargs, args)); \ + Lisp_Object el = Fcons (name, field); \ + field_list = Fcons (el, field_list); \ + } while (0) + + gcc_jit_type *args[4]; + + ADD_IMPORTED ("wrong_type_argument", comp.void_type, 2, NULL); + + args[0] = comp.lisp_obj_type; + args[1] = comp.int_type; + ADD_IMPORTED ("helper_PSEUDOVECTOR_TYPEP_XUNTAG", comp.bool_type, 2, args); + + ADD_IMPORTED ("pure_write_error", comp.void_type, 1, NULL); + + args[0] = comp.lisp_obj_type; + args[1] = comp.int_type; + ADD_IMPORTED ("push_handler", comp.handler_ptr_type, 2, args); + + args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); + ADD_IMPORTED (SETJMP_NAME, comp.int_type, 1, args); + + ADD_IMPORTED ("record_unwind_protect_excursion", comp.void_type, 0, NULL); + + args[0] = comp.lisp_obj_type; + ADD_IMPORTED ("helper_unbind_n", comp.lisp_obj_type, 1, args); + + ADD_IMPORTED ("helper_save_restriction", comp.void_type, 0, NULL); + + ADD_IMPORTED ("record_unwind_current_buffer", comp.void_type, 0, NULL); + + args[0] = args[1] = args[2] = comp.lisp_obj_type; + args[3] = comp.int_type; + ADD_IMPORTED ("set_internal", comp.void_type, 4, args); + + args[0] = comp.lisp_obj_type; + ADD_IMPORTED ("helper_unwind_protect", comp.void_type, 1, args); + + args[0] = args[1] = comp.lisp_obj_type; + ADD_IMPORTED ("specbind", comp.void_type, 2, args); + +#undef ADD_IMPORTED + + return field_list; +} + +/* + This emit the code needed by every compilation unit to be loaded. +*/ +static void +emit_ctxt_code (void) +{ + USE_SAFE_ALLOCA; + + comp.current_thread_ref = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (comp.thread_state_ptr_type), + CURRENT_THREAD_RELOC_SYM)); + + comp.pure_ref = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (comp.void_ptr_type), + PURE_RELOC_SYM)); + + declare_runtime_imported_data (); + /* Imported objects. */ + EMACS_INT d_reloc_len = + XFIXNUM (CALL1I (hash-table-count, + CALL1I (comp-ctxt-data-relocs-idx, Vcomp_ctxt))); + Lisp_Object d_reloc = Fnreverse (CALL1I (comp-ctxt-data-relocs-l, Vcomp_ctxt)); + d_reloc = Fvconcat (1, &d_reloc); + + comp.data_relocs = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + d_reloc_len), + DATA_RELOC_SYM)); + + emit_static_object (TEXT_DATA_RELOC_SYM, d_reloc); + + /* Imported functions from non Lisp code. */ + Lisp_Object f_runtime = declare_runtime_imported_funcs (); + EMACS_INT f_reloc_len = XFIXNUM (Flength (f_runtime)); + + /* Imported subrs. */ + Lisp_Object f_subr = CALL1I (comp-ctxt-func-relocs-l, Vcomp_ctxt); + f_reloc_len += XFIXNUM (Flength (f_subr)); + + gcc_jit_field **fields = SAFE_ALLOCA (f_reloc_len * sizeof (*fields)); + Lisp_Object f_reloc_list = Qnil; + int n_frelocs = 0; + + FOR_EACH_TAIL (f_runtime) + { + Lisp_Object el = XCAR (f_runtime); + fields[n_frelocs++] = xmint_pointer (XCDR (el)); + f_reloc_list = Fcons (XCAR (el), f_reloc_list); + } + + FOR_EACH_TAIL (f_subr) + { + Lisp_Object subr_sym = XCAR (f_subr); + Lisp_Object subr = symbol_subr (subr_sym); + /* Ignore inliners. This are not real functions to be imported. */ + if (SUBRP (subr)) + { + Lisp_Object maxarg = XCDR (Fsubr_arity (subr)); + gcc_jit_field *field = + declare_imported_func (subr_sym, comp.lisp_obj_type, + FIXNUMP (maxarg) ? XFIXNUM (maxarg) : + EQ (maxarg, Qmany) ? MANY : UNEVALLED, + NULL); + fields[n_frelocs++] = field; + f_reloc_list = Fcons (subr_sym, f_reloc_list); + } + } + + Lisp_Object f_reloc_vec = make_vector (n_frelocs, Qnil); + f_reloc_list = Fnreverse (f_reloc_list); + ptrdiff_t i = 0; + FOR_EACH_TAIL (f_reloc_list) + { + ASET (f_reloc_vec, i++, XCAR (f_reloc_list)); + } + emit_static_object (TEXT_IMPORTED_FUNC_RELOC_SYM, f_reloc_vec); + + gcc_jit_struct *f_reloc_struct = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "function_reloc_struct", + n_frelocs, fields); + comp.func_relocs = + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_struct_as_type (f_reloc_struct), + IMPORTED_FUNC_RELOC_SYM); + + SAFE_FREE (); +} + + +/****************************************************************/ +/* Inline function definition and lisp data structure follows. */ +/****************************************************************/ + +/* struct Lisp_Cons definition. */ + +static void +define_lisp_cons (void) +{ + /* + union cdr_u + { + Lisp_Object cdr; + struct Lisp_Cons *chain; + }; + + struct cons_s + { + Lisp_Object car; + union cdr_u u; + }; + + union cons_u + { + struct cons_s s; + char align_pad[sizeof (struct Lisp_Cons)]; + }; + + struct Lisp_Cons + { + union cons_u u; + }; + */ + + comp.lisp_cons_s = + gcc_jit_context_new_opaque_struct (comp.ctxt, + NULL, + "comp_Lisp_Cons"); + comp.lisp_cons_type = + gcc_jit_struct_as_type (comp.lisp_cons_s); + comp.lisp_cons_ptr_type = + gcc_jit_type_get_pointer (comp.lisp_cons_type); + + comp.lisp_cons_u_s_u_cdr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "cdr"); + + gcc_jit_field *cdr_u_fields[] = + { comp.lisp_cons_u_s_u_cdr, + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_cons_ptr_type, + "chain") }; + + gcc_jit_type *cdr_u = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "comp_cdr_u", + sizeof (cdr_u_fields) + / sizeof (*cdr_u_fields), + cdr_u_fields); + + comp.lisp_cons_u_s_car = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "car"); + comp.lisp_cons_u_s_u = gcc_jit_context_new_field (comp.ctxt, + NULL, + cdr_u, + "u"); + gcc_jit_field *cons_s_fields[] = + { comp.lisp_cons_u_s_car, + comp.lisp_cons_u_s_u }; + + gcc_jit_struct *cons_s = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "comp_cons_s", + sizeof (cons_s_fields) + / sizeof (*cons_s_fields), + cons_s_fields); + + comp.lisp_cons_u_s = gcc_jit_context_new_field (comp.ctxt, + NULL, + gcc_jit_struct_as_type (cons_s), + "s"); + + gcc_jit_field *cons_u_fields[] = + { comp.lisp_cons_u_s, + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (struct Lisp_Cons)), + "align_pad") }; + + gcc_jit_type *lisp_cons_u_type = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "comp_cons_u", + sizeof (cons_u_fields) + / sizeof (*cons_u_fields), + cons_u_fields); + + comp.lisp_cons_u = + gcc_jit_context_new_field (comp.ctxt, + NULL, + lisp_cons_u_type, + "u"); + gcc_jit_struct_set_fields (comp.lisp_cons_s, + NULL, 1, &comp.lisp_cons_u); + +} + +/* Opaque jmp_buf definition. */ + +static void +define_jmp_buf (void) +{ + gcc_jit_field *field = + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (jmp_buf)), + "stuff"); + comp.jmp_buf_s = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "comp_jmp_buf", + 1, &field); +} + +/* struct handler definition */ + +static void +define_handler_struct (void) +{ + comp.handler_s = + gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "comp_handler"); + comp.handler_ptr_type = + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.handler_s)); + + comp.handler_jmp_field = gcc_jit_context_new_field (comp.ctxt, + NULL, + gcc_jit_struct_as_type ( + comp.jmp_buf_s), + "jmp"); + comp.handler_val_field = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "val"); + comp.handler_next_field = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.handler_ptr_type, + "next"); + gcc_jit_field *fields[] = + { gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + offsetof (struct handler, val)), + "pad0"), + comp.handler_val_field, + comp.handler_next_field, + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + offsetof (struct handler, jmp) + - offsetof (struct handler, next) + - sizeof (((struct handler *) 0)->next)), + "pad1"), + comp.handler_jmp_field, + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (struct handler) + - offsetof (struct handler, jmp) + - sizeof (((struct handler *) 0)->jmp)), + "pad2") }; + gcc_jit_struct_set_fields (comp.handler_s, + NULL, + sizeof (fields) / sizeof (*fields), + fields); + +} + +static void +define_thread_state_struct (void) +{ + /* Partially opaque definition for `thread_state'. + Because we need to access just m_handlerlist hopefully this is requires + less manutention then the full deifnition. */ + + comp.m_handlerlist = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.handler_ptr_type, + "m_handlerlist"); + gcc_jit_field *fields[] = + { gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + offsetof (struct thread_state, + m_handlerlist)), + "pad0"), + comp.m_handlerlist, + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type ( + comp.ctxt, + NULL, + comp.char_type, + sizeof (struct thread_state) + - offsetof (struct thread_state, + m_handlerlist) + - sizeof (((struct thread_state *) 0)->m_handlerlist)), + "pad1") }; + + comp.thread_state_s = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "comp_thread_state", + sizeof (fields) / sizeof (*fields), + fields); + comp.thread_state_ptr_type = + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state_s)); +} + +static void +define_cast_union (void) +{ + + comp.cast_union_as_ll = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "ll"); + comp.cast_union_as_ull = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_long_long_type, + "ull"); + comp.cast_union_as_l = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_type, + "l"); + comp.cast_union_as_ul = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_long_type, + "ul"); + comp.cast_union_as_u = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_type, + "u"); + comp.cast_union_as_i = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "i"); + comp.cast_union_as_b = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.bool_type, + "b"); + comp.cast_union_as_uintptr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.uintptr_type, + "uintptr"); + comp.cast_union_as_ptrdiff = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.ptrdiff_type, + "ptrdiff"); + comp.cast_union_as_c_p = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.char_ptr_type, + "c_p"); + comp.cast_union_as_v_p = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.void_ptr_type, + "v_p"); + comp.cast_union_as_lisp_cons_ptr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_cons_ptr_type, + "cons_ptr"); + comp.cast_union_as_lisp_obj = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "lisp_obj"); + comp.cast_union_as_lisp_obj_ptr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_ptr_type, + "lisp_obj_ptr"); + + + gcc_jit_field *cast_union_fields[] = + { comp.cast_union_as_ll, + comp.cast_union_as_ull, + comp.cast_union_as_l, + comp.cast_union_as_ul, + comp.cast_union_as_u, + comp.cast_union_as_i, + comp.cast_union_as_b, + comp.cast_union_as_uintptr, + comp.cast_union_as_ptrdiff, + comp.cast_union_as_c_p, + comp.cast_union_as_v_p, + comp.cast_union_as_lisp_cons_ptr, + comp.cast_union_as_lisp_obj, + comp.cast_union_as_lisp_obj_ptr }; + comp.cast_union_type = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "cast_union", + sizeof (cast_union_fields) + / sizeof (*cast_union_fields), + cast_union_fields); +} + +static void +define_CHECK_TYPE (void) +{ + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.int_type, + "ok"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "predicate"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "x") }; + comp.check_type = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.void_type, + "CHECK_TYPE", + 3, + param, + 0); + gcc_jit_rvalue *ok = gcc_jit_param_as_rvalue (param[0]); + gcc_jit_rvalue *predicate = gcc_jit_param_as_rvalue (param[1]); + gcc_jit_rvalue *x = gcc_jit_param_as_rvalue (param[2]); + + DECL_BLOCK (entry_block, comp.check_type); + DECL_BLOCK (ok_block, comp.check_type); + DECL_BLOCK (not_ok_block, comp.check_type); + + comp.block = entry_block; + comp.func = comp.check_type; + + emit_cond_jump (ok, ok_block, not_ok_block); + + gcc_jit_block_end_with_void_return (ok_block, NULL); + + comp.block = not_ok_block; + + gcc_jit_rvalue *wrong_type_args[] = { predicate, x }; + + gcc_jit_block_add_eval (comp.block, + NULL, + emit_call (intern_c_string ("wrong_type_argument"), + comp.void_type, 2, wrong_type_args, + false)); + + gcc_jit_block_end_with_void_return (not_ok_block, NULL); +} + +/* Define a substitute for CAR as always inlined function. */ + +static void +define_CAR_CDR (void) +{ + gcc_jit_function *func[2]; + char const *f_name[] = { "CAR", "CDR" }; + for (int i = 0; i < 2; i++) + { + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "c"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "cert_cons") }; + /* TODO: understand why after ipa-prop pass gcc is less keen on inlining + and as consequence can refuse to compile these. (see dhrystone.el) + Flag this and all the one involved in ipa-prop as + GCC_JIT_FUNCTION_INTERNAL not to fail compilation in case. + This seems at least to have no perf downside. */ + func[i] = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_obj_type, + f_name[i], + 2, param, 0); + + gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param[0]); + DECL_BLOCK (entry_block, func[i]); + DECL_BLOCK (is_cons_b, func[i]); + DECL_BLOCK (not_a_cons_b, func[i]); + comp.block = entry_block; + comp.func = func[i]; + emit_cond_jump ( + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_cast (comp.bool_type, + emit_CONSP (c))), + is_cons_b, + not_a_cons_b); + comp.block = is_cons_b; + if (i == 0) + gcc_jit_block_end_with_return (comp.block, NULL, emit_XCAR (c)); + else + gcc_jit_block_end_with_return (comp.block, NULL, emit_XCDR (c)); + + comp.block = not_a_cons_b; + + DECL_BLOCK (is_nil_b, func[i]); + DECL_BLOCK (not_nil_b, func[i]); + + emit_cond_jump (emit_NILP (c), is_nil_b, not_nil_b); + + comp.block = is_nil_b; + gcc_jit_block_end_with_return (comp.block, + NULL, + emit_const_lisp_obj (Qnil)); + + comp.block = not_nil_b; + gcc_jit_rvalue *wrong_type_args[] = + { emit_const_lisp_obj (Qlistp), c }; + + gcc_jit_block_add_eval (comp.block, + NULL, + emit_call (intern_c_string ("wrong_type_argument"), + comp.void_type, 2, wrong_type_args, + false)); + gcc_jit_block_end_with_return (comp.block, + NULL, + emit_const_lisp_obj (Qnil)); + } + comp.car = func[0]; + comp.cdr = func[1]; +} + +static void +define_setcar_setcdr (void) +{ + char const *f_name[] = { "setcar", "setcdr" }; + char const *par_name[] = { "new_car", "new_cdr" }; + + for (int i = 0; i < 2; i++) + { + gcc_jit_param *cell = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "cell"); + gcc_jit_param *new_el = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + par_name[i]); + + gcc_jit_param *param[] = + { cell, + new_el, + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "cert_cons") }; + + gcc_jit_function **f_ref = !i ? &comp.setcar : &comp.setcdr; + *f_ref = gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_obj_type, + f_name[i], + 3, param, 0); + DECL_BLOCK (entry_block, *f_ref); + comp.func = *f_ref; + comp.block = entry_block; + + /* CHECK_CONS (cell); */ + emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); + + /* CHECK_IMPURE (cell, XCONS (cell)); */ + gcc_jit_rvalue *args[] = + { gcc_jit_param_as_rvalue (cell), + emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; + + gcc_jit_block_add_eval (entry_block, + NULL, + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_impure, + 2, + args)); + + /* XSETCDR (cell, newel); */ + if (!i) + emit_XSETCAR (gcc_jit_param_as_rvalue (cell), + gcc_jit_param_as_rvalue (new_el)); + else + emit_XSETCDR (gcc_jit_param_as_rvalue (cell), + gcc_jit_param_as_rvalue (new_el)); + + /* return newel; */ + gcc_jit_block_end_with_return (entry_block, + NULL, + gcc_jit_param_as_rvalue (new_el)); + } +} + +/* + Define a substitute for Fadd1 Fsub1. + Currently expose just fixnum arithmetic. +*/ + +static void +define_add1_sub1 (void) +{ + gcc_jit_block *bb_orig = comp.block; + gcc_jit_function *func[2]; + char const *f_name[] = { "add1", "sub1" }; + char const *fall_back_func[] = { "1+", "1-" }; + gcc_jit_rvalue *compare[] = + { comp.most_positive_fixnum, comp.most_negative_fixnum }; + enum gcc_jit_binary_op op[] = + { GCC_JIT_BINARY_OP_PLUS, GCC_JIT_BINARY_OP_MINUS }; + for (ptrdiff_t i = 0; i < 2; i++) + { + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "n"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "cert_fixnum") }; + comp.func = func[i] = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_obj_type, + f_name[i], + 2, + param, 0); + DECL_BLOCK (entry_block, func[i]); + DECL_BLOCK (inline_block, func[i]); + DECL_BLOCK (fcall_block, func[i]); + + comp.block = entry_block; + + /* cert_fixnum || + ((FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM + ? (XFIXNUM (n) + 1) + : Fadd1 (n)) */ + + gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param[0]); + gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (n); + gcc_jit_rvalue *sure_fixnum = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_cast (comp.bool_type, + emit_FIXNUMP (n))); + + emit_cond_jump ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + sure_fixnum, + gcc_jit_context_new_comparison (comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + n_fixnum, + compare[i])), + inline_block, + fcall_block); + + comp.block = inline_block; + gcc_jit_rvalue *inline_res = + gcc_jit_context_new_binary_op (comp.ctxt, + NULL, + op[i], + comp.emacs_int_type, + n_fixnum, + comp.one); + + gcc_jit_block_end_with_return (inline_block, + NULL, + emit_make_fixnum (inline_res)); + + comp.block = fcall_block; + gcc_jit_rvalue *call_res = emit_call (intern_c_string (fall_back_func[i]), + comp.lisp_obj_type, 1, &n, false); + gcc_jit_block_end_with_return (fcall_block, + NULL, + call_res); + } + comp.block = bb_orig; + comp.add1 = func[0]; + comp.sub1 = func[1]; +} + +static void +define_negate (void) +{ + gcc_jit_block *bb_orig = comp.block; + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "n"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "cert_fixnum") }; + + comp.func = comp.negate = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_obj_type, + "negate", + 2, param, 0); + + DECL_BLOCK (entry_block, comp.negate); + DECL_BLOCK (inline_block, comp.negate); + DECL_BLOCK (fcall_block, comp.negate); + + comp.block = entry_block; + + /* (cert_fixnum || FIXNUMP (TOP)) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM + ? make_fixnum (- XFIXNUM (TOP)) : Fminus (1, &TOP)) */ + + gcc_jit_lvalue *n = gcc_jit_param_as_lvalue (param[0]); + gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (n)); + gcc_jit_rvalue *sure_fixnum = + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_cast (comp.bool_type, + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n)))); + + emit_cond_jump ( + gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + sure_fixnum, + gcc_jit_context_new_comparison (comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + n_fixnum, + comp.most_negative_fixnum)), + inline_block, + fcall_block); + + comp.block = inline_block; + gcc_jit_rvalue *inline_res = + gcc_jit_context_new_unary_op (comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_MINUS, + comp.emacs_int_type, + n_fixnum); + + gcc_jit_block_end_with_return (inline_block, + NULL, + emit_make_fixnum (inline_res)); + + comp.block = fcall_block; + gcc_jit_rvalue *call_res = emit_call_ref (Qminus, 1, n, false); + gcc_jit_block_end_with_return (fcall_block, + NULL, + call_res); + comp.block = bb_orig; +} + +/* Define a substitute for PSEUDOVECTORP as always inlined function. */ + +static void +define_PSEUDOVECTORP (void) +{ + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "a"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.int_type, + "code") }; + + comp.pseudovectorp = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.bool_type, + "PSEUDOVECTORP", + 2, + param, + 0); + + DECL_BLOCK (entry_block, comp.pseudovectorp); + DECL_BLOCK (ret_false_b, comp.pseudovectorp); + DECL_BLOCK (call_pseudovector_typep_b, comp.pseudovectorp); + + comp.block = entry_block; + comp.func = comp.pseudovectorp; + + emit_cond_jump (emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0])), + call_pseudovector_typep_b, + ret_false_b); + + comp.block = ret_false_b; + gcc_jit_block_end_with_return (ret_false_b, + NULL, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.bool_type, + false)); + + gcc_jit_rvalue *args[] = + { gcc_jit_param_as_rvalue (param[0]), + gcc_jit_param_as_rvalue (param[1]) }; + comp.block = call_pseudovector_typep_b; + /* FIXME use XUNTAG now that's available. */ + gcc_jit_block_end_with_return ( + call_pseudovector_typep_b, + NULL, + emit_call (intern_c_string ("helper_PSEUDOVECTOR_TYPEP_XUNTAG"), + comp.bool_type, 2, args, false)); +} + +static void +define_CHECK_IMPURE (void) +{ + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "obj"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.void_ptr_type, + "ptr") }; + comp.check_impure = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.void_type, + "CHECK_IMPURE", + 2, + param, + 0); + + DECL_BLOCK (entry_block, comp.check_impure); + DECL_BLOCK (err_block, comp.check_impure); + DECL_BLOCK (ok_block, comp.check_impure); + + comp.block = entry_block; + comp.func = comp.check_impure; + + emit_cond_jump (emit_PURE_P (gcc_jit_param_as_rvalue (param[0])), /* FIXME */ + err_block, + ok_block); + gcc_jit_block_end_with_void_return (ok_block, NULL); + + gcc_jit_rvalue *pure_write_error_arg = + gcc_jit_param_as_rvalue (param[0]); + + comp.block = err_block; + gcc_jit_block_add_eval (comp.block, + NULL, + emit_call (intern_c_string ("pure_write_error"), + comp.void_type, 1,&pure_write_error_arg, + false)); + + gcc_jit_block_end_with_void_return (err_block, NULL); +} + +/* Define a function to convert boolean into t or nil */ + +static void +define_bool_to_lisp_obj (void) +{ + /* x ? Qt : Qnil */ + gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "x"); + comp.bool_to_lisp_obj = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_ALWAYS_INLINE, + comp.lisp_obj_type, + "bool_to_lisp_obj", + 1, + ¶m, + 0); + DECL_BLOCK (entry_block, comp.bool_to_lisp_obj); + DECL_BLOCK (ret_t_block, comp.bool_to_lisp_obj); + DECL_BLOCK (ret_nil_block, comp.bool_to_lisp_obj); + comp.block = entry_block; + comp.func = comp.bool_to_lisp_obj; + + emit_cond_jump (gcc_jit_param_as_rvalue (param), + ret_t_block, + ret_nil_block); + + comp.block = ret_t_block; + gcc_jit_block_end_with_return (ret_t_block, + NULL, + emit_const_lisp_obj (Qt)); + + comp.block = ret_nil_block; + gcc_jit_block_end_with_return (ret_nil_block, + NULL, + emit_const_lisp_obj (Qnil)); + +} + +/* Declare a function being compiled and add it to comp.exported_funcs_h. */ + +static void +declare_function (Lisp_Object func) +{ + gcc_jit_function *gcc_func; + char *c_name = SSDATA (CALL1I (comp-func-c-name, func)); + Lisp_Object args = CALL1I (comp-func-args, func); + bool nargs = (CALL1I (comp-nargs-p, args)); + USE_SAFE_ALLOCA; + + if (!nargs) + { + EMACS_INT max_args = XFIXNUM (CALL1I (comp-args-max, args)); + gcc_jit_type **type = SAFE_ALLOCA (max_args * sizeof (*type)); + for (ptrdiff_t i = 0; i < max_args; i++) + type[i] = comp.lisp_obj_type; + + gcc_jit_param **param = SAFE_ALLOCA (max_args *sizeof (*param)); + for (int i = max_args - 1; i >= 0; i--) + param[i] = gcc_jit_context_new_param (comp.ctxt, + NULL, + type[i], + format_string ("par_%d", i)); + gcc_func = gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + c_name, + max_args, + param, + 0); + } + else + { + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.ptrdiff_type, + "nargs"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_ptr_type, + "args") }; + gcc_func = + gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + c_name, 2, param, 0); + } + + Fputhash (CALL1I (comp-func-name, func), + make_mint_ptr (gcc_func), + comp.exported_funcs_h); + + SAFE_FREE (); +} + +static void +compile_function (Lisp_Object func) +{ + USE_SAFE_ALLOCA; + EMACS_INT frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func)); + + comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-name, func), + comp.exported_funcs_h, Qnil)); + + gcc_jit_lvalue *frame_array = + gcc_jit_function_new_local ( + comp.func, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + frame_size), + "local"); + comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame)); + for (EMACS_INT i = 0; i < frame_size; ++i) + comp.frame[i] = + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (frame_array), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + i)); + + /* + The floating frame is a copy of the normal frame that can be used to store + locals if the are not going to be used in a nargs call. + This has two advantages: + - Enable gcc for better reordering (frame array is clobbered every time is + passed as parameter being involved into an nargs function call). + - Allow gcc to trigger other optimizations that are prevented by memory + referencing. + */ + if (SPEED >= 2) + { + comp.f_frame = SAFE_ALLOCA (frame_size * sizeof (*comp.f_frame)); + for (ptrdiff_t i = 0; i < frame_size; ++i) + comp.f_frame[i] = + gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + format_string ("local%td", i)); + } + + comp.scratch = NULL; + + comp.loc_handler = gcc_jit_function_new_local (comp.func, + NULL, + comp.handler_ptr_type, + "c"); + + comp.func_blocks_h = CALLN (Fmake_hash_table); + + /* Pre-declare all basic blocks to gcc. + The "entry" block must be declared as first. */ + declare_block (Qentry); + Lisp_Object blocks = CALL1I (comp-func-blocks, func); + Lisp_Object entry_block = Fgethash (Qentry, blocks, Qnil); + struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); + for (ptrdiff_t i = 0; i < ht->count; i++) + { + Lisp_Object block = HASH_VALUE (ht, i); + if (!EQ (block, entry_block)) + declare_block (HASH_KEY (ht, i)); + } + + for (ptrdiff_t i = 0; i < ht->count; i++) + { + Lisp_Object block_name = HASH_KEY (ht, i); + Lisp_Object block = HASH_VALUE (ht, i); + Lisp_Object insns = CALL1I (comp-block-insns, block); + if (NILP (block) || NILP (insns)) + xsignal1 (Qnative_ice, + build_string ("basic block is missing or empty")); + + comp.block = retrive_block (block_name); + while (CONSP (insns)) + { + Lisp_Object insn = XCAR (insns); + emit_limple_insn (insn); + insns = XCDR (insns); + } + } + const char *err = gcc_jit_context_get_first_error (comp.ctxt); + if (err) + xsignal3 (Qnative_ice, + build_string ("failing to compile function"), + CALL1I (comp-func-name, func), + build_string (err)); + + SAFE_FREE (); +} + + +/**********************************/ +/* Entry points exposed to lisp. */ +/**********************************/ + +DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, + 0, 0, 0, + doc: /* Initialize the native compiler context. Return t on success. */) + (void) +{ + if (comp.ctxt) + { + xsignal1 (Qnative_ice, + build_string ("compiler context already taken")); + return Qnil; + } + + if (NILP (comp.emitter_dispatcher)) + { + /* Move this into syms_of_comp the day will be dumpable. */ + comp.emitter_dispatcher = CALLN (Fmake_hash_table); + register_emitter (Qset_internal, emit_set_internal); + register_emitter (Qhelper_unbind_n, emit_simple_limple_call_lisp_ret); + register_emitter (Qhelper_unwind_protect, + emit_simple_limple_call_void_ret); + register_emitter (Qrecord_unwind_current_buffer, + emit_simple_limple_call_lisp_ret); + register_emitter (Qrecord_unwind_protect_excursion, + emit_simple_limple_call_void_ret); + register_emitter (Qhelper_save_restriction, + emit_simple_limple_call_void_ret); + /* Inliners. */ + register_emitter (Qadd1, emit_add1); + register_emitter (Qsub1, emit_sub1); + register_emitter (Qconsp, emit_consp); + register_emitter (Qcar, emit_car); + register_emitter (Qcdr, emit_cdr); + register_emitter (Qsetcar, emit_setcar); + register_emitter (Qsetcdr, emit_setcdr); + register_emitter (Qnegate, emit_negate); + register_emitter (Qnumberp, emit_numperp); + register_emitter (Qintegerp, emit_integerp); + } + + comp.ctxt = gcc_jit_context_acquire (); + + if (COMP_DEBUG) + { + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DEBUGINFO, + 1); + } + if (COMP_DEBUG > 1) + { + logfile = fopen ("libgccjit.log", "w"); + gcc_jit_context_set_logfile (comp.ctxt, + logfile, + 0, 0); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, + 1); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, + 1); + } + + comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); + comp.void_ptr_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + comp.bool_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_BOOL); + comp.char_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_CHAR); + comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); + comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt, + GCC_JIT_TYPE_UNSIGNED_INT); + comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG); + comp.unsigned_long_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG); + comp.long_long_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG); + comp.unsigned_long_long_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG); + comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type); + +#if EMACS_INT_MAX <= LONG_MAX + /* 32-bit builds without wide ints, 64-bit builds on Posix hosts. */ + comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.void_ptr_type, + "obj"); +#else + /* 64-bit builds on MS-Windows, 32-bit builds with wide ints. */ + comp.lisp_obj_as_ptr = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "obj"); +#endif + + comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (EMACS_INT), + true); + + comp.lisp_obj_as_num = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.emacs_int_type, + "num"); + + gcc_jit_field *lisp_obj_fields[] = { comp.lisp_obj_as_ptr, + comp.lisp_obj_as_num }; + comp.lisp_obj_type = gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "comp_Lisp_Object", + sizeof (lisp_obj_fields) + / sizeof (*lisp_obj_fields), + lisp_obj_fields); + comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); + + comp.most_positive_fixnum = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_int_type, + MOST_POSITIVE_FIXNUM); + comp.most_negative_fixnum = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_int_type, + MOST_NEGATIVE_FIXNUM); + comp.one = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_int_type, + 1); + comp.inttypebits = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_int_type, + INTTYPEBITS); + + comp.lisp_int0 = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_int_type, + Lisp_Int0); + + comp.ptrdiff_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (void *), + true); + + comp.uintptr_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (void *), + false); + + comp.exported_funcs_h = CALLN (Fmake_hash_table); + /* + Always reinitialize this cause old function definitions are garbage collected + by libgccjit when the ctxt is released. + */ + comp.imported_funcs_h = CALLN (Fmake_hash_table); + + /* Define data structures. */ + + define_lisp_cons (); + define_jmp_buf (); + define_handler_struct (); + define_thread_state_struct (); + define_cast_union (); + + return Qt; +} + +DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, + 0, 0, 0, + doc: /* Release the native compiler context. */) + (void) +{ + if (comp.ctxt) + gcc_jit_context_release (comp.ctxt); + + if (logfile) + fclose (logfile); + comp.ctxt = NULL; + + return Qt; +} + +DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, + Scomp__compile_ctxt_to_file, + 1, 1, 0, + doc: /* Compile as native code the current context to file. */) + (Lisp_Object ctxtname) +{ + CHECK_STRING (ctxtname); + + Frequire (Qadvice, Qnil, Qnil); + + gcc_jit_context_set_int_option (comp.ctxt, + GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, + SPEED); + /* Gcc doesn't like being interrupted at all. */ + block_input (); + sigset_t oldset; + sigset_t blocked; + sigemptyset (&blocked); + sigaddset (&blocked, SIGALRM); + sigaddset (&blocked, SIGINT); + sigaddset (&blocked, SIGIO); + pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + + emit_ctxt_code (); + + /* Define inline functions. */ + define_CAR_CDR (); + define_PSEUDOVECTORP (); + define_CHECK_TYPE (); + define_CHECK_IMPURE (); + define_bool_to_lisp_obj (); + define_setcar_setcdr (); + define_add1_sub1 (); + define_negate (); + + struct Lisp_Hash_Table *func_h + = XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt)); + for (ptrdiff_t i = 0; i < func_h->count; i++) + declare_function (HASH_VALUE (func_h, i)); + /* Compile all functions. Can't be done before because the + relocation structs has to be already defined. */ + for (ptrdiff_t i = 0; i < func_h->count; i++) + compile_function (HASH_VALUE (func_h, i)); + + if (COMP_DEBUG) + gcc_jit_context_dump_to_file (comp.ctxt, + format_string ("%s.c", SSDATA (ctxtname)), + 1); + if (COMP_DEBUG > 2) + gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); + + AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); + + Lisp_Object out_file = CALLN (Fconcat, ctxtname, dot_so); + + /* Remove the old eln before creating the new one to get a new inode and + prevent crashes in case the old one is currently loaded. */ + if (!NILP (Ffile_exists_p (out_file))) + Fdelete_file (out_file, Qnil); + + gcc_jit_context_compile_to_file (comp.ctxt, + GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, + SSDATA (out_file)); + + pthread_sigmask (SIG_SETMASK, &oldset, 0); + unblock_input (); + + return out_file; +} + + +/******************************************************************************/ +/* Helper functions called from the run-time. */ +/* These can't be statics till shared mechanism is used to solve relocations. */ +/* Note: this are all potentially definable directly to gcc and are here just */ +/* for laziness. Change this if a performance impact is measured. */ +/******************************************************************************/ + +Lisp_Object +helper_save_window_excursion (Lisp_Object v1) +{ + ptrdiff_t count1 = SPECPDL_INDEX (); + record_unwind_protect (restore_window_configuration, + Fcurrent_window_configuration (Qnil)); + v1 = Fprogn (v1); + unbind_to (count1, v1); + return v1; +} + +void +helper_unwind_protect (Lisp_Object handler) +{ + /* Support for a function here is new in 24.4. */ + record_unwind_protect (FUNCTIONP (handler) ? bcall0 : prog_ignore, + handler); +} + +Lisp_Object +helper_temp_output_buffer_setup (Lisp_Object x) +{ + CHECK_STRING (x); + temp_output_buffer_setup (SSDATA (x)); + return Vstandard_output; +} + +Lisp_Object +helper_unbind_n (Lisp_Object n) +{ + return unbind_to (SPECPDL_INDEX () - XFIXNUM (n), Qnil); +} + +void +helper_save_restriction (void) +{ + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); +} + +bool +helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) +{ + return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike, + union vectorlike_header), + code); +} + + +/**************************************/ +/* Functions used to load eln files. */ +/**************************************/ + +static Lisp_Object Vnative_elisp_refs_hash; +static Lisp_Object load_handle_stack; + +static void +prevent_gc (Lisp_Object obj) +{ + Fputhash (obj, Qt, Vnative_elisp_refs_hash); +} + +typedef char *(*comp_lit_str_func) (void); + +/* Deserialize read and return static object. */ +static Lisp_Object +load_static_obj (dynlib_handle_ptr handle, const char *name) +{ + static_obj_t *(*f)(void) = dynlib_sym (handle, name); + eassert (f); + static_obj_t *res = f (); + return Fread (make_string (res->data, res->len)); +} + +static void +load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) +{ + struct thread_state ***current_thread_reloc = + dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); + EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); + Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); + Lisp_Object (**f_relocs)(void) = dynlib_sym (handle, IMPORTED_FUNC_RELOC_SYM); + void (*top_level_run)(void) = dynlib_sym (handle, "top_level_run"); + + if (!(current_thread_reloc + && pure_reloc + && data_relocs + && f_relocs + && top_level_run)) + xsignal1 (Qnative_lisp_file_inconsistent, file); + + *current_thread_reloc = ¤t_thread; + *pure_reloc = (EMACS_INT **)&pure; + + /* Imported data. */ + Lisp_Object d_vec = load_static_obj (handle, TEXT_DATA_RELOC_SYM); + EMACS_INT d_vec_len = XFIXNUM (Flength (d_vec)); + + for (EMACS_INT i = 0; i < d_vec_len; i++) + { + data_relocs[i] = AREF (d_vec, i); + prevent_gc (data_relocs[i]); + } + + /* Imported functions. */ + Lisp_Object f_vec = + load_static_obj (handle, TEXT_IMPORTED_FUNC_RELOC_SYM); + EMACS_INT f_vec_len = XFIXNUM (Flength (f_vec)); + for (EMACS_INT i = 0; i < f_vec_len; i++) + { + Lisp_Object f_sym = AREF (f_vec, i); + char *f_str = SSDATA (SYMBOL_NAME (f_sym)); + Lisp_Object subr = Fsymbol_function (f_sym); + if (!NILP (subr)) + { + subr = symbol_subr (f_sym); + if (NILP (subr)) + /* FIXME: This is not robust in case of primitive + redefinition. */ + xsignal2 (Qnative_lisp_wrong_reloc, f_sym, file); + + f_relocs[i] = XSUBR (subr)->function.a0; + } + else if (!strcmp (f_str, "wrong_type_argument")) + f_relocs[i] = (void *) wrong_type_argument; + else if (!strcmp (f_str, "helper_PSEUDOVECTOR_TYPEP_XUNTAG")) + f_relocs[i] = (void *) helper_PSEUDOVECTOR_TYPEP_XUNTAG; + else if (!strcmp (f_str, "pure_write_error")) + f_relocs[i] = (void *) pure_write_error; + else if (!strcmp (f_str, "push_handler")) + f_relocs[i] = (void *) push_handler; + else if (!strcmp (f_str, SETJMP_NAME)) + f_relocs[i] = (void *) SETJMP; + else if (!strcmp (f_str, "record_unwind_protect_excursion")) + f_relocs[i] = (void *) record_unwind_protect_excursion; + else if (!strcmp (f_str, "helper_unbind_n")) + f_relocs[i] = (void *) helper_unbind_n; + else if (!strcmp (f_str, "helper_save_restriction")) + f_relocs[i] = (void *) helper_save_restriction; + else if (!strcmp (f_str, "record_unwind_current_buffer")) + f_relocs[i] = (void *) record_unwind_current_buffer; + else if (!strcmp (f_str, "set_internal")) + f_relocs[i] = (void *) set_internal; + else if (!strcmp (f_str, "helper_unwind_protect")) + f_relocs[i] = (void *) helper_unwind_protect; + else if (!strcmp (f_str, "specbind")) + f_relocs[i] = (void *) specbind; + else + xsignal2 (Qnative_lisp_wrong_reloc, f_sym, file); + } + + /* Executing this will perform all the expected environment modification. */ + top_level_run (); + + return; +} + +DEFUN ("comp--register-subr", Fcomp__register_subr, + Scomp__register_subr, + 5, 5, 0, + doc: /* This gets called by top_level_run during load phase to register + each exported subr. */) + (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc) +{ + dynlib_handle_ptr handle = xmint_pointer (XCAR (load_handle_stack)); + if (!handle) + xsignal0 (Qwrong_register_subr_call); + + void *func = dynlib_sym (handle, SSDATA (c_name)); + eassert (func); + + union Aligned_Lisp_Subr *x = xmalloc (sizeof (union Aligned_Lisp_Subr)); + x->s.header.size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS; + x->s.function.a0 = func; + x->s.min_args = XFIXNUM (minarg); + x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; + x->s.symbol_name = SSDATA (Fsymbol_name (name)); + x->s.intspec = NULL; + x->s.doc = 0; /* FIXME */ + x->s.native_elisp = true; + defsubr (x); + + return Qnil; +} + +/* Load related routines. */ +DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 1, 0, + doc: /* Load native elisp code FILE. */) + (Lisp_Object file) +{ + CHECK_STRING (file); + + Frequire (Qadvice, Qnil, Qnil); + + dynlib_handle_ptr handle = dynlib_open (SSDATA (file)); + load_handle_stack = Fcons (make_mint_ptr (handle), load_handle_stack); + if (!handle) + xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); + + load_comp_unit (handle, file); + + load_handle_stack = XCDR (load_handle_stack); + + return Qt; +} + + +void +syms_of_comp (void) +{ + /* Compiler control customizes. */ + DEFSYM (Qcomp_speed, "comp-speed"); + DEFSYM (Qcomp_debug, "comp-debug"); + + /* Limple instruction set. */ + DEFSYM (Qcomment, "comment"); + DEFSYM (Qjump, "jump"); + DEFSYM (Qcall, "call"); + DEFSYM (Qcallref, "callref"); + DEFSYM (Qdirect_call, "direct-call"); + DEFSYM (Qdirect_callref, "direct-callref"); + DEFSYM (Qsetimm, "setimm"); + DEFSYM (Qreturn, "return"); + DEFSYM (Qcomp_mvar, "comp-mvar"); + DEFSYM (Qcond_jump, "cond-jump"); + DEFSYM (Qphi, "phi"); + /* Ops in use for prologue emission. */ + DEFSYM (Qset_par_to_local, "set-par-to-local"); + DEFSYM (Qset_args_to_local, "set-args-to-local"); + DEFSYM (Qset_rest_args_to_local, "set-rest-args-to-local"); + DEFSYM (Qinc_args, "inc-args"); + DEFSYM (Qcond_jump_narg_leq, "cond-jump-narg-leq"); + /* Others. */ + DEFSYM (Qpush_handler, "push-handler"); + DEFSYM (Qpop_handler, "pop-handler"); + DEFSYM (Qfetch_handler, "fetch-handler"); + DEFSYM (Qcondition_case, "condition-case"); + /* call operands. */ + DEFSYM (Qcatcher, "catcher"); + DEFSYM (Qentry, "entry"); + DEFSYM (Qset_internal, "set_internal"); + DEFSYM (Qrecord_unwind_current_buffer, "record_unwind_current_buffer"); + DEFSYM (Qrecord_unwind_protect_excursion, "record_unwind_protect_excursion"); + DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); + DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); + DEFSYM (Qhelper_save_restriction, "helper_save_restriction"); + /* Inliners. */ + DEFSYM (Qadd1, "1+"); + DEFSYM (Qsub1, "1-"); + DEFSYM (Qconsp, "consp"); + DEFSYM (Qcar, "car"); + DEFSYM (Qcdr, "cdr"); + DEFSYM (Qsetcar, "setcar"); + DEFSYM (Qsetcdr, "setcdr"); + DEFSYM (Qnegate, "negate"); + DEFSYM (Qnumberp, "numberp"); + DEFSYM (Qintegerp, "integerp"); + + /* Others. */ + DEFSYM (Qfixnum, "fixnum"); + DEFSYM (Qadvice, "advice"); + + /* To be signaled. */ + + /* By the compiler. */ + DEFSYM (Qnative_compiler_error, "native-compiler-error"); + Fput (Qnative_compiler_error, Qerror_conditions, + pure_list (Qnative_compiler_error, Qerror)); + Fput (Qnative_compiler_error, Qerror_message, + build_pure_c_string ("Native compiler error")); + + DEFSYM (Qnative_ice, "native-ice"); + Fput (Qnative_ice, Qerror_conditions, + pure_list (Qnative_ice, Qnative_compiler_error, Qerror)); + Fput (Qnative_ice, Qerror_message, + build_pure_c_string ("Internal native compiler error")); + + /* By the load machinery. */ + DEFSYM (Qnative_lisp_load_failed, "native-lisp-load-failed"); + Fput (Qnative_lisp_load_failed, Qerror_conditions, + pure_list (Qnative_lisp_load_failed, Qerror)); + Fput (Qnative_lisp_load_failed, Qerror_message, + build_pure_c_string ("Native elisp load failed")); + + DEFSYM (Qnative_lisp_wrong_reloc, "native-lisp-wrong-reloc"); + Fput (Qnative_lisp_wrong_reloc, Qerror_conditions, + pure_list (Qnative_lisp_wrong_reloc, Qnative_lisp_load_failed, Qerror)); + Fput (Qnative_lisp_wrong_reloc, Qerror_message, + build_pure_c_string ("Primitive redefined or wrong relocation")); + + DEFSYM (Qwrong_register_subr_call, "wrong-register-subr-call"); + Fput (Qwrong_register_subr_call, Qerror_conditions, + pure_list (Qwrong_register_subr_call, Qnative_lisp_load_failed, Qerror)); + Fput (Qwrong_register_subr_call, Qerror_message, + build_pure_c_string ("comp--register-subr can only be called during " + "native lisp load phase.")); + + DEFSYM (Qnative_lisp_file_inconsistent, "native-lisp-file-inconsistent"); + Fput (Qnative_lisp_file_inconsistent, Qerror_conditions, + pure_list (Qnative_lisp_file_inconsistent, Qnative_lisp_load_failed, Qerror)); + Fput (Qnative_lisp_file_inconsistent, Qerror_message, + build_pure_c_string ("inconsistent eln file")); + + defsubr (&Scomp__init_ctxt); + defsubr (&Scomp__release_ctxt); + defsubr (&Scomp__compile_ctxt_to_file); + defsubr (&Scomp__register_subr); + defsubr (&Snative_elisp_load); + + staticpro (&comp.exported_funcs_h); + comp.exported_funcs_h = Qnil; + staticpro (&comp.imported_funcs_h); + comp.imported_funcs_h = Qnil; + staticpro (&comp.func_blocks_h); + staticpro (&comp.emitter_dispatcher); + comp.emitter_dispatcher = Qnil; + + DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, + doc: /* The compiler context. */); + Vcomp_ctxt = Qnil; + + /* Load mechanism. */ + staticpro (&Vnative_elisp_refs_hash); + Vnative_elisp_refs_hash + = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, + DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, + Qnil, false); + staticpro (&load_handle_stack); + load_handle_stack = Qnil; +} + +#endif /* HAVE_NATIVE_COMP */ diff --git a/src/data.c b/src/data.c index 26e8611..f379711 100644 --- a/src/data.c +++ b/src/data.c @@ -864,6 +864,16 @@ DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0, return build_string (name); } +#ifdef HAVE_NATIVE_COMP +DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, 0, + doc: /* Return t if the object is native compiled lisp function, +nil otherwise. */) + (Lisp_Object object) +{ + return (SUBRP (object) && XSUBR (object)->native_elisp) ? Qt : Qnil; +} +#endif + DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, doc: /* Return the interactive form of CMD or nil if none. If CMD is not a command, the return value is nil. @@ -3998,6 +4008,9 @@ #define PUT_ERROR(sym, tail, msg) \ defsubr (&Sbyteorder); defsubr (&Ssubr_arity); defsubr (&Ssubr_name); +#ifdef HAVE_NATIVE_COMP + defsubr (&Ssubr_native_elisp_p); +#endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); #endif diff --git a/src/emacs.c b/src/emacs.c index 8a6e34d..071d0cc 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1598,6 +1598,11 @@ main (int argc, char **argv) init_json (); #endif +#ifdef HAVE_NATIVE_COMP + if (!initialized) + syms_of_comp (); +#endif + no_loadup = argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args); diff --git a/src/eval.c b/src/eval.c index 4bc96f9..ca96424 100644 --- a/src/eval.c +++ b/src/eval.c @@ -219,8 +219,14 @@ backtrace_thread_next (struct thread_state *tstate, union specbinding *pdl) init_eval_once (void) { /* Don't forget to update docs (lispref node "Local Variables"). */ +#ifndef HAVE_NATIVE_COMP max_specpdl_size = 1600; /* 1500 is not enough for cl-generic.el. */ max_lisp_eval_depth = 800; +#else + /* Original values increased for comp.el. */ + max_specpdl_size = 2100; + max_lisp_eval_depth = 1400; +#endif Vrun_hooks = Qnil; pdumper_do_now_and_after_load (init_eval_once_for_pdumper); } diff --git a/src/lisp.h b/src/lisp.h index e0ae2c4..aa891bb 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2088,6 +2088,9 @@ CHAR_TABLE_SET (Lisp_Object ct, int idx, Lisp_Object val) const char *symbol_name; const char *intspec; EMACS_INT doc; +#ifdef HAVE_NATIVE_COMP + bool native_elisp; +#endif } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { @@ -4741,6 +4744,10 @@ maybe_disable_address_randomization (int argc, char **argv) extern void malloc_probe (size_t); extern void syms_of_profiler (void); +/* Defined in comp.c. */ +#ifdef HAVE_NATIVE_COMP +extern void syms_of_comp (void); +#endif /* HAVE_NATIVE_COMP */ #ifdef DOS_NT /* Defined in msdos.c, w32.c. */ diff --git a/src/lread.c b/src/lread.c index 4ea6202..92f90b2 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1273,6 +1273,11 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, bool is_module = false; #endif +#ifdef HAVE_NATIVE_COMP + bool is_native_elisp = suffix_p (found, NATIVE_ELISP_SUFFIX); +#else + bool is_native_elisp = false; +#endif /* Check if we're stuck in a recursive load cycle. 2000-09-21: It's not possible to just check for the file loaded @@ -1371,7 +1376,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, } /* !load_prefer_newer */ } } - else if (!is_module) + else if (!is_module && !is_native_elisp) { /* We are loading a source file (*.el). */ if (!NILP (Vload_source_file_function)) @@ -1398,7 +1403,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, stream = NULL; errno = EINVAL; } - else if (!is_module) + else if (!is_module && !is_native_elisp) { #ifdef WINDOWSNT emacs_close (fd); @@ -1414,7 +1419,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, might be accessed by the unbind_to call below. */ struct infile input; - if (is_module) + if (is_module || is_native_elisp) { /* `module-load' uses the file name, so we can close the stream now. */ @@ -1444,6 +1449,8 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, file, 1); else if (is_module) message_with_string ("Loading %s (module)...", file, 1); + else if (is_native_elisp) + message_with_string ("Loading %s (native compiled elisp)...", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...", file, 1); else if (newer) @@ -1469,6 +1476,18 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, emacs_abort (); #endif } + else if (is_native_elisp) + { +#ifdef HAVE_NATIVE_COMP + specbind (Qcurrent_load_list, Qnil); + LOADHIST_ATTACH (found); + Fnative_elisp_load (found); + build_load_history (found, true); +#else + /* This cannot happen. */ + emacs_abort (); +#endif + } else { if (lisp_file_lexically_bound_p (Qget_file_char)) @@ -1507,6 +1526,8 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, file, 1); else if (is_module) message_with_string ("Loading %s (module)...done", file, 1); + else if (is_native_elisp) + message_with_string ("Loading %s (native compiled elisp)...done", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...done", file, 1); else if (newer) @@ -4862,14 +4883,15 @@ syms_of_lread (void) This list should not include the empty string. `load' and related functions try to append these suffixes, in order, to the specified file name if a suffix is allowed or required. */); -#ifdef HAVE_MODULES - Vload_suffixes = list3 (build_pure_c_string (".elc"), - build_pure_c_string (".el"), - build_pure_c_string (MODULES_SUFFIX)); -#else Vload_suffixes = list2 (build_pure_c_string (".elc"), build_pure_c_string (".el")); +#ifdef HAVE_MODULES + Vload_suffixes = Fcons (build_pure_c_string (MODULES_SUFFIX), Vload_suffixes); #endif +#ifdef HAVE_NATIVE_COMP + Vload_suffixes = Fcons (build_pure_c_string (NATIVE_ELISP_SUFFIX), Vload_suffixes); +#endif + DEFVAR_LISP ("module-file-suffix", Vmodule_file_suffix, doc: /* Suffix of loadable module file, or nil if modules are not supported. */); #ifdef HAVE_MODULES diff --git a/src/pdumper.c b/src/pdumper.c index 74f198c..d998f5d 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2922,7 +2922,10 @@ dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v) static dump_off dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) { -#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_594AB72B54) +#if CHECK_STRUCTS && ((defined (HAVE_NATIVE_COMP) \ + && !defined (HASH_Lisp_Subr_D4F15794AF)) \ + || (!defined (HAVE_NATIVE_COMP) \ + && !defined (HASH_Lisp_Subr_594AB72B54))) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; @@ -2934,6 +2937,9 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); DUMP_FIELD_COPY (&out, subr, doc); +#ifdef HAVE_NATIVE_COMP + DUMP_FIELD_COPY (&out, subr, native_elisp); +#endif return dump_object_finish (ctx, &out, sizeof (out)); } diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el new file mode 100644 index 0000000..20d15ac --- /dev/null +++ b/test/src/comp-test-funcs.el @@ -0,0 +1,393 @@ +;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Author: Andrea Corallo + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(defvar comp-tests-var1 3) + +(defun comp-tests-varref-f () + comp-tests-var1) + +(defun comp-tests-list-f () + (list 1 2 3)) +(defun comp-tests-list2-f (a b c) + (list a b c)) +(defun comp-tests-car-f (x) + ;; Bcar + (car x)) +(defun comp-tests-cdr-f (x) + ;; Bcdr + (cdr x)) +(defun comp-tests-car-safe-f (x) + ;; Bcar_safe + (car-safe x)) +(defun comp-tests-cdr-safe-f (x) + ;; Bcdr_safe + (cdr-safe x)) + +(defun comp-tests-cons-car-f () + (car (cons 1 2))) +(defun comp-tests-cons-cdr-f (x) + (cdr (cons 'foo x))) + +(defun comp-tests-varset0-f () + (setq comp-tests-var1 55)) +(defun comp-tests-varset1-f () + (setq comp-tests-var1 66) + 4) + +(defun comp-tests-length-f () + (length '(1 2 3))) + +(defun comp-tests-aref-aset-f () + (let ((vec [1 2 3])) + (aset vec 2 100) + (aref vec 2))) + +(defvar comp-tests-var2 3) +(defun comp-tests-symbol-value-f () + (symbol-value 'comp-tests-var2)) + +(defun comp-tests-concat-f (x) + (concat "a" "b" "c" "d" + (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) + +(defun comp-tests-ffuncall-callee-f (x y z) + (list x y z)) + +(defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) + (list a b c d)) + +(defun comp-tests-ffuncall-callee-rest-f (a b &rest c) + (list a b c)) + +(defun comp-tests-ffuncall-callee-more8-f (p1 p2 p3 p4 p5 p6 p7 p8 p9 p10) + ;; More then 8 args. + (list p1 p2 p3 p4 p5 p6 p7 p8 p9 p10)) + +(defun comp-tests-ffuncall-callee-more8-rest-f (p1 p2 p3 p4 p5 p6 p7 p8 p9 &rest p10) + ;; More then 8 args. + (list p1 p2 p3 p4 p5 p6 p7 p8 p9 p10)) + +(defun comp-tests-ffuncall-native-f () + "Call a primitive with no dedicate op." + (make-vector 1 nil)) + +(defun comp-tests-ffuncall-native-rest-f () + "Call a primitive with no dedicate op with &rest." + (vector 1 2 3)) + +(defun comp-tests-ffuncall-apply-many-f (x) + (apply #'list x)) + +(defun comp-tests-ffuncall-lambda-f (x) + (let ((fun (lambda (x) + (1+ x)))) + (funcall fun x))) + +(defun comp-tests-jump-table-1-f (x) + (pcase x + ('x 'a) + ('y 'b) + (_ 'c))) + +(defun comp-tests-jump-table-2-f (x) + (pcase x + ("aaa" 'a) + ("bbb" 'b))) + +(defun comp-tests-conditionals-1-f (x) + ;; Generate goto-if-nil + (if x 1 2)) +(defun comp-tests-conditionals-2-f (x) + ;; Generate goto-if-nil-else-pop + (when x + 1340)) + +(defun comp-tests-fixnum-1-minus-f (x) + ;; Bsub1 + (1- x)) +(defun comp-tests-fixnum-1-plus-f (x) + ;; Badd1 + (1+ x)) +(defun comp-tests-fixnum-minus-f (x) + ;; Bnegate + (- x)) + +(defun comp-tests-eqlsign-f (x y) + ;; Beqlsign + (= x y)) +(defun comp-tests-gtr-f (x y) + ;; Bgtr + (> x y)) +(defun comp-tests-lss-f (x y) + ;; Blss + (< x y)) +(defun comp-tests-les-f (x y) + ;; Bleq + (<= x y)) +(defun comp-tests-geq-f (x y) + ;; Bgeq + (>= x y)) + +(defun comp-tests-setcar-f (x y) + (setcar x y) + x) +(defun comp-tests-setcdr-f (x y) + (setcdr x y) + x) + +(defun comp-bubble-sort-f (list) + (let ((i (length list))) + (while (> i 1) + (let ((b list)) + (while (cdr b) + (when (< (cadr b) (car b)) + (setcar b (prog1 (cadr b) + (setcdr b (cons (car b) (cddr b)))))) + (setq b (cdr b)))) + (setq i (1- i))) + list)) + +(defun comp-tests-consp-f (x) + ;; Bconsp + (consp x)) +(defun comp-tests-setcar2-f (x) + ;; Bsetcar + (setcar x 3)) + +(defun comp-tests-integerp-f (x) + ;; Bintegerp + (integerp x)) +(defun comp-tests-numberp-f (x) + ;; Bnumberp + (numberp x)) + +(defun comp-tests-discardn-f (x) + ;; BdiscardN + (1+ (let ((a 1) + (_b) + (_c)) + a))) +(defun comp-tests-insertn-f (a b c d) + ;; Binsert + (insert a b c d)) + +(defun comp-tests-err-arith-f () + (/ 1 0)) +(defun comp-tests-err-foo-f () + (error "foo")) + +(defun comp-tests-condition-case-0-f () + ;; Bpushhandler Bpophandler + (condition-case + err + (comp-tests-err-arith-f) + (arith-error (concat "arith-error " + (error-message-string err) + " catched")) + (error (concat "error " + (error-message-string err) + " catched")))) +(defun comp-tests-condition-case-1-f () + ;; Bpushhandler Bpophandler + (condition-case + err + (comp-tests-err-foo-f) + (arith-error (concat "arith-error " + (error-message-string err) + " catched")) + (error (concat "error " + (error-message-string err) + " catched")))) +(defun comp-tests-catch-f (f) + (catch 'foo + (funcall f))) +(defun comp-tests-throw-f (x) + (throw 'foo x)) + +(defun comp-tests-buff0-f () + (with-temp-buffer + (insert "foo") + (buffer-string))) + +(defun comp-tests-lambda-return-f () + (lambda (x) (1+ x))) + +(defun comp-tests-fib-f (n) + (cond ((= n 0) 0) + ((= n 1) 1) + (t (+ (comp-tests-fib-f (- n 1)) + (comp-tests-fib-f (- n 2)))))) + +(defmacro comp-tests-macro-m (x) + x) + +(defun comp-tests-string-trim-f (url) + (string-trim url)) + +(defun comp-tests-trampoline-removal-f () + (make-hash-table)) + +(defun comp-tests-signal-f () + (signal 'foo t)) + +(defun comp-tests-func-call-removal-f () + (let ((a 10) + (b 3)) + (% a b))) + + +;;;;;;;;;;;;;;;;;;;; +;; Tromey's tests ;; +;;;;;;;;;;;;;;;;;;;; + +;; Test Bconsp. +(defun comp-test-consp (x) (consp x)) + +;; Test Blistp. +(defun comp-test-listp (x) (listp x)) + +;; Test Bstringp. +(defun comp-test-stringp (x) (stringp x)) + +;; Test Bsymbolp. +(defun comp-test-symbolp (x) (symbolp x)) + +;; Test Bintegerp. +(defun comp-test-integerp (x) (integerp x)) + +;; Test Bnumberp. +(defun comp-test-numberp (x) (numberp x)) + +;; Test Badd1. +(defun comp-test-add1 (x) (1+ x)) + +;; Test Bsub1. +(defun comp-test-sub1 (x) (1- x)) + +;; Test Bneg. +(defun comp-test-negate (x) (- x)) + +;; Test Bnot. +(defun comp-test-not (x) (not x)) + +;; Test Bbobp, Beobp, Bpoint, Bpoint_min, Bpoint_max. +(defun comp-test-bobp () (bobp)) +(defun comp-test-eobp () (eobp)) +(defun comp-test-point () (point)) +(defun comp-test-point-min () (point-min)) +(defun comp-test-point-max () (point-max)) + +;; Test Bcar and Bcdr. +(defun comp-test-car (x) (car x)) +(defun comp-test-cdr (x) (cdr x)) + +;; Test Bcar_safe and Bcdr_safe. +(defun comp-test-car-safe (x) (car-safe x)) +(defun comp-test-cdr-safe (x) (cdr-safe x)) + +;; Test Beq. +(defun comp-test-eq (x y) (eq x y)) + +;; Test Bgotoifnil. +(defun comp-test-if (x y) (if x x y)) + +;; Test Bgotoifnilelsepop. +(defun comp-test-and (x y) (and x y)) + +;; Test Bgotoifnonnilelsepop. +(defun comp-test-or (x y) (or x y)) + +;; Test Bsave_excursion. +(defun comp-test-save-excursion () + (save-excursion + (insert "XYZ"))) + +;; Test Bcurrent_buffer. +(defun comp-test-current-buffer () (current-buffer)) + +;; Test Bgtr. +(defun comp-test-> (a b) + (> a b)) + +;; Test Bpushcatch. +(defun comp-test-catch (&rest l) + (catch 'done + (dolist (v l) + (when (> v 23) + (throw 'done v))))) + +;; Test Bmemq. +(defun comp-test-memq (val list) + (memq val list)) + +;; Test BlistN. +(defun comp-test-listN (x) + (list x x x x x x x x x x x x x x x x)) + +;; Test BconcatN. +(defun comp-test-concatN (x) + (concat x x x x x x)) + +;; Test optional and rest arguments. +(defun comp-test-opt-rest (a &optional b &rest c) + (list a b c)) + +;; Test for too many arguments. +(defun comp-test-opt (a &optional b) + (cons a b)) + +;; Test for unwind-protect. +(defvar comp-test-up-val nil) +(defun comp-test-unwind-protect (fun) + (setq comp-test-up-val nil) + (unwind-protect + (progn + (setq comp-test-up-val 23) + (funcall fun) + (setq comp-test-up-val 24)) + (setq comp-test-up-val 999))) + +;; Non tested functions that proved just to be difficult to compile. + +(defun comp-test-callee (_ __) t) +(defun comp-test-silly-frame1 (x) + ;; Check robustness against dead code. + (cl-case x + (0 (comp-test-callee + (pcase comp-tests-var1 + (1 1) + (2 2)) + 3)))) + +(defun comp-test-silly-frame2 (token) + ;; Check robustness against dead code. + (while c + (cl-case c + (?< 1) + (?> 2)))) + +(provide 'comp-test-funcs) + +;;; comp-test-funcs.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el new file mode 100644 index 0000000..570dcbd --- /dev/null +++ b/test/src/comp-tests.el @@ -0,0 +1,487 @@ +;;; comp-tests.el --- unit tests for src/comp.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Author: Andrea Corallo + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Unit tests for src/comp.c. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'comp) + +;; (setq comp-debug 1) +(setq comp-speed 0) + +(defconst comp-test-directory (file-name-directory (or load-file-name + buffer-file-name))) +(defconst comp-test-src + (concat comp-test-directory "comp-test-funcs.el")) + +(message "Compiling %s" comp-test-src) +(load (native-compile comp-test-src)) + +(ert-deftest comp-tests-bootstrap () + "Compile the compiler and load it to compile it-self. +Check that the resulting binaries do not differ." + (let* ((comp-src (concat comp-test-directory + "../../lisp/emacs-lisp/comp.el")) + (comp1-src (make-temp-file "stage1-" nil ".el")) + (comp2-src (make-temp-file "stage2-" nil ".el")) + (comp1 (concat comp1-src "n")) + (comp2 (concat comp2-src "n"))) + (copy-file comp-src comp1-src t) + (copy-file comp-src comp2-src t) + (load (concat comp-src "c") nil nil t t) + (should (null (subr-native-elisp-p (symbol-function #'native-compile)))) + (message "Compiling stage1...") + (load (native-compile comp1-src) nil nil t t) + (should (subr-native-elisp-p (symbol-function 'native-compile))) + (message "Compiling stage2...") + (native-compile comp2-src) + (message "Comparing %s %s" comp1 comp2) + (should (= (call-process "cmp" nil nil nil comp1 comp2) 0)))) + +(ert-deftest comp-tests-provide () + "Testing top level provide." + (should (featurep 'comp-test-funcs))) + +(ert-deftest comp-tests-varref () + "Testing varref." + (should (= (comp-tests-varref-f) 3))) + +(ert-deftest comp-tests-list () + "Testing cons car cdr." + (should (equal (comp-tests-list-f) '(1 2 3))) + (should (equal (comp-tests-list2-f 1 2 3) '(1 2 3))) + (should (= (comp-tests-car-f '(1 . 2)) 1)) + (should (null (comp-tests-car-f nil))) + (should-error (comp-tests-car-f 3) + :type 'wrong-type-argument) + (should (= (comp-tests-cdr-f '(1 . 2)) 2)) + (should (null (comp-tests-cdr-f nil))) + (should-error (comp-tests-cdr-f 3) + :type 'wrong-type-argument) + (should (= (comp-tests-car-safe-f '(1 . 2)) 1)) + (should (null (comp-tests-car-safe-f 'a))) + (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) + (should (null (comp-tests-cdr-safe-f 'a)))) + +(ert-deftest comp-tests-cons-car-cdr () + "Testing cons car cdr." + (should (= (comp-tests-cons-car-f) 1)) + (should (= (comp-tests-cons-cdr-f 3) 3))) + +(ert-deftest comp-tests-varset () + "Testing varset." + (comp-tests-varset0-f) + (should (= comp-tests-var1 55)) + + (should (= (comp-tests-varset1-f) 4)) + (should (= comp-tests-var1 66))) + +(ert-deftest comp-tests-length () + "Testing length." + (should (= (comp-tests-length-f) 3))) + +(ert-deftest comp-tests-aref-aset () + "Testing aref and aset." + (should (= (comp-tests-aref-aset-f) 100))) + +(ert-deftest comp-tests-symbol-value () + "Testing aref and aset." + (should (= (comp-tests-symbol-value-f) 3))) + +(ert-deftest comp-tests-concat () + "Testing concatX opcodes." + (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) + +(ert-deftest comp-tests-ffuncall () + "Test calling conventions." + + ;; (defun comp-tests-ffuncall-caller-f () + ;; (comp-tests-ffuncall-callee-f 1 2 3)) + + ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + + ;; ;; After it gets compiled + ;; (native-compile #'comp-tests-ffuncall-callee-f) + ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + + ;; ;; Recompiling the caller once with callee already compiled + ;; (defun comp-tests-ffuncall-caller-f () + ;; (comp-tests-ffuncall-callee-f 1 2 3)) + ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) + '(1 2 3 4))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) + '(1 2 3 nil))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) + '(1 2 nil nil))) + + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) + '(1 2 nil))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) + '(1 2 (3)))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) + '(1 2 (3 4)))) + + (should (equal (comp-tests-ffuncall-callee-more8-f 1 2 3 4 5 6 7 8 9 10) + '(1 2 3 4 5 6 7 8 9 10))) + + (should (equal (comp-tests-ffuncall-callee-more8-rest-f 1 2 3 4 5 6 7 8 9 10 11) + '(1 2 3 4 5 6 7 8 9 (10 11)))) + + (should (equal (comp-tests-ffuncall-native-f) [nil])) + + (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) + + (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) + '(1 2 3))) + + (should (= (comp-tests-ffuncall-lambda-f 1) 2))) + +(ert-deftest comp-tests-jump-table () + "Testing jump tables" + (should (eq (comp-tests-jump-table-1-f 'x) 'a)) + (should (eq (comp-tests-jump-table-1-f 'y) 'b)) + (should (eq (comp-tests-jump-table-1-f 'xxx) 'c)) + + ;; Jump table not with eq as test + (should (eq (comp-tests-jump-table-2-f "aaa") 'a)) + (should (eq (comp-tests-jump-table-2-f "bbb") 'b))) + +(ert-deftest comp-tests-conditionals () + "Testing conditionals." + (should (= (comp-tests-conditionals-1-f t) 1)) + (should (= (comp-tests-conditionals-1-f nil) 2)) + (should (= (comp-tests-conditionals-2-f t) 1340)) + (should (eq (comp-tests-conditionals-2-f nil) nil))) + +(ert-deftest comp-tests-fixnum () + "Testing some fixnum inline operation." + (should (= (comp-tests-fixnum-1-minus-f 10) 9)) + (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) + (1- most-negative-fixnum))) + (should-error (comp-tests-fixnum-1-minus-f 'a) + :type 'wrong-type-argument) + (should (= (comp-tests-fixnum-1-plus-f 10) 11)) + (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) + (1+ most-positive-fixnum))) + (should-error (comp-tests-fixnum-1-plus-f 'a) + :type 'wrong-type-argument) + (should (= (comp-tests-fixnum-minus-f 10) -10)) + (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) + (- most-negative-fixnum))) + (should-error (comp-tests-fixnum-minus-f 'a) + :type 'wrong-type-argument)) + +(ert-deftest comp-tests-arith-comp () + "Testing arithmetic comparisons." + (should (eq (comp-tests-eqlsign-f 4 3) nil)) + (should (eq (comp-tests-eqlsign-f 3 3) t)) + (should (eq (comp-tests-eqlsign-f 2 3) nil)) + (should (eq (comp-tests-gtr-f 4 3) t)) + (should (eq (comp-tests-gtr-f 3 3) nil)) + (should (eq (comp-tests-gtr-f 2 3) nil)) + (should (eq (comp-tests-lss-f 4 3) nil)) + (should (eq (comp-tests-lss-f 3 3) nil)) + (should (eq (comp-tests-lss-f 2 3) t)) + (should (eq (comp-tests-les-f 4 3) nil)) + (should (eq (comp-tests-les-f 3 3) t)) + (should (eq (comp-tests-les-f 2 3) t)) + (should (eq (comp-tests-geq-f 4 3) t)) + (should (eq (comp-tests-geq-f 3 3) t)) + (should (eq (comp-tests-geq-f 2 3) nil))) + +(ert-deftest comp-tests-setcarcdr () + "Testing setcar setcdr." + (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) + (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) + (should-error (comp-tests-setcar-f 3 10) + :type 'wrong-type-argument) + (should-error (comp-tests-setcdr-f 3 10) + :type 'wrong-type-argument)) + +(ert-deftest comp-tests-bubble-sort () + "Run bubble sort." + (let* ((list1 (mapcar #'random (make-list 1000 most-positive-fixnum))) + (list2 (copy-sequence list1))) + (should (equal (comp-bubble-sort-f list1) + (sort list2 #'<))))) + +(ert-deftest comp-test-apply () + "Test some inlined list functions." + (should (eq (comp-tests-consp-f '(1)) t)) + (should (eq (comp-tests-consp-f 1) nil)) + (let ((x (cons 1 2))) + (should (= (comp-tests-setcar2-f x) 3)) + (should (equal x '(3 . 2))))) + +(ert-deftest comp-tests-num-inline () + "Test some inlined number functions." + (should (eq (comp-tests-integerp-f 1) t)) + (should (eq (comp-tests-integerp-f '(1)) nil)) + (should (eq (comp-tests-integerp-f 3.5) nil)) + (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) + + (should (eq (comp-tests-numberp-f 1) t)) + (should (eq (comp-tests-numberp-f 'a) nil)) + (should (eq (comp-tests-numberp-f 3.5) t))) + +(ert-deftest comp-tests-stack () + "Test some stack operation." + (should (= (comp-tests-discardn-f 10) 2)) + (should (string= (with-temp-buffer + (comp-tests-insertn-f "a" "b" "c" "d") + (buffer-string)) + "abcd"))) + +(ert-deftest comp-tests-non-locals () + "Test non locals." + (let ((gc-cons-threshold most-positive-fixnum)) ;; FIXME!! + (should (string= (comp-tests-condition-case-0-f) + "arith-error Arithmetic error catched")) + (should (string= (comp-tests-condition-case-1-f) + "error foo catched")) + (should (= (comp-tests-catch-f + (lambda () (throw 'foo 3))) + 3)) + (should (= (catch 'foo + (comp-tests-throw-f 3)))))) + +(ert-deftest comp-tests-gc () + "Try to do some longer computation to let the gc kick in." + (dotimes (_ 100000) + (comp-tests-cons-cdr-f 3)) + (should (= (comp-tests-cons-cdr-f 3) 3))) + +(ert-deftest comp-tests-buffer () + (should (string= (comp-tests-buff0-f) "foo"))) + +(ert-deftest comp-tests-lambda-return () + (should (= (funcall (comp-tests-lambda-return-f) 3) 4))) + +(ert-deftest comp-tests-recursive () + (should (= (comp-tests-fib-f 10) 55))) + +(ert-deftest comp-tests-macro () + "Just check we can define macros" + (should (macrop (symbol-function 'comp-tests-macro-m)))) + +(ert-deftest comp-tests-string-trim () + (should (string= (comp-tests-string-trim-f "dsaf ") "dsaf"))) + +(ert-deftest comp-tests-trampoline-removal () + ;; This tests that we can can call primitives with no dedicated bytecode. + ;; At speed >= 2 the trampoline will not be used. + (should (hash-table-p (comp-tests-trampoline-removal-f)))) + +(ert-deftest comp-tests-signal () + (should (equal (condition-case err + (comp-tests-signal-f) + (t err)) + '(foo . t)))) + +(ert-deftest comp-tests-func-call-removal () + ;; See `comp-propagate-insn' `comp-function-call-remove'. + (should (= (comp-tests-func-call-removal-f) 1))) + +(ert-deftest comp-tests-free-fun () + "Check we are able to compile a single function." + (defun comp-tests-free-fun-f () + 3) + (load (native-compile #'comp-tests-free-fun-f)) + (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f))) + (should (= (comp-tests-free-fun-f) 3))) + + +;;;;;;;;;;;;;;;;;;;; +;; Tromey's tests ;; +;;;;;;;;;;;;;;;;;;;; + +(ert-deftest comp-consp () + (should-not (comp-test-consp 23)) + (should-not (comp-test-consp nil)) + (should (comp-test-consp '(1 . 2)))) + +(ert-deftest comp-listp () + (should-not (comp-test-listp 23)) + (should (comp-test-listp nil)) + (should (comp-test-listp '(1 . 2)))) + +(ert-deftest comp-stringp () + (should-not (comp-test-stringp 23)) + (should-not (comp-test-stringp nil)) + (should (comp-test-stringp "hi"))) + +(ert-deftest comp-symbolp () + (should-not (comp-test-symbolp 23)) + (should-not (comp-test-symbolp "hi")) + (should (comp-test-symbolp 'whatever))) + +(ert-deftest comp-integerp () + (should (comp-test-integerp 23)) + (should-not (comp-test-integerp 57.5)) + (should-not (comp-test-integerp "hi")) + (should-not (comp-test-integerp 'whatever))) + +(ert-deftest comp-numberp () + (should (comp-test-numberp 23)) + (should (comp-test-numberp 57.5)) + (should-not (comp-test-numberp "hi")) + (should-not (comp-test-numberp 'whatever))) + +(ert-deftest comp-add1 () + (should (eq (comp-test-add1 23) 24)) + (should (eq (comp-test-add1 -17) -16)) + (should (eql (comp-test-add1 1.0) 2.0)) + (should-error (comp-test-add1 nil) + :type 'wrong-type-argument)) + +(ert-deftest comp-sub1 () + (should (eq (comp-test-sub1 23) 22)) + (should (eq (comp-test-sub1 -17) -18)) + (should (eql (comp-test-sub1 1.0) 0.0)) + (should-error (comp-test-sub1 nil) + :type 'wrong-type-argument)) + +(ert-deftest comp-negate () + (should (eq (comp-test-negate 23) -23)) + (should (eq (comp-test-negate -17) 17)) + (should (eql (comp-test-negate 1.0) -1.0)) + (should-error (comp-test-negate nil) + :type 'wrong-type-argument)) + +(ert-deftest comp-not () + (should (eq (comp-test-not 23) nil)) + (should (eq (comp-test-not nil) t)) + (should (eq (comp-test-not t) nil))) + +(ert-deftest comp-bobp-and-eobp () + (with-temp-buffer + (should (comp-test-bobp)) + (should (comp-test-eobp)) + (insert "hi") + (goto-char (point-min)) + (should (eq (comp-test-point-min) (point-min))) + (should (eq (comp-test-point) (point-min))) + (should (comp-test-bobp)) + (should-not (comp-test-eobp)) + (goto-char (point-max)) + (should (eq (comp-test-point-max) (point-max))) + (should (eq (comp-test-point) (point-max))) + (should-not (comp-test-bobp)) + (should (comp-test-eobp)))) + +(ert-deftest comp-car-cdr () + (let ((pair '(1 . b))) + (should (eq (comp-test-car pair) 1)) + (should (eq (comp-test-car nil) nil)) + (should-error (comp-test-car 23) + :type 'wrong-type-argument) + (should (eq (comp-test-cdr pair) 'b)) + (should (eq (comp-test-cdr nil) nil)) + (should-error (comp-test-cdr 23) + :type 'wrong-type-argument))) + +(ert-deftest comp-car-cdr-safe () + (let ((pair '(1 . b))) + (should (eq (comp-test-car-safe pair) 1)) + (should (eq (comp-test-car-safe nil) nil)) + (should (eq (comp-test-car-safe 23) nil)) + (should (eq (comp-test-cdr-safe pair) 'b)) + (should (eq (comp-test-cdr-safe nil) nil)) + (should (eq (comp-test-cdr-safe 23) nil)))) + +(ert-deftest comp-eq () + (should (comp-test-eq 'a 'a)) + (should (comp-test-eq 5 5)) + (should-not (comp-test-eq 'a 'b)) + (should-not (comp-test-eq "x" "x"))) + +(ert-deftest comp-if () + (should (eq (comp-test-if 'a 'b) 'a)) + (should (eq (comp-test-if 0 23) 0)) + (should (eq (comp-test-if nil 'b) 'b))) + +(ert-deftest comp-and () + (should (eq (comp-test-and 'a 'b) 'b)) + (should (eq (comp-test-and 0 23) 23)) + (should (eq (comp-test-and nil 'b) nil))) + +(ert-deftest comp-or () + (should (eq (comp-test-or 'a 'b) 'a)) + (should (eq (comp-test-or 0 23) 0)) + (should (eq (comp-test-or nil 'b) 'b))) + +(ert-deftest comp-save-excursion () + (with-temp-buffer + (comp-test-save-excursion) + (should (eq (point) (point-min))) + (should (eq (comp-test-current-buffer) (current-buffer))))) + +(ert-deftest comp-> () + (should (eq (comp-test-> 0 23) nil)) + (should (eq (comp-test-> 23 0) t))) + +(ert-deftest comp-catch () + (should (eq (comp-test-catch 0 1 2 3 4) nil)) + (should (eq (comp-test-catch 20 21 22 23 24 25 26 27 28) 24))) + +(ert-deftest comp-memq () + (should (equal (comp-test-memq 0 '(5 4 3 2 1 0)) '(0))) + (should (eq (comp-test-memq 72 '(5 4 3 2 1 0)) nil))) + +(ert-deftest comp-listN () + (should (equal (comp-test-listN 57) + '(57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57)))) + +(ert-deftest comp-concatN () + (should (equal (comp-test-concatN "x") "xxxxxx"))) + +(ert-deftest comp-opt-rest () + (should (equal (comp-test-opt-rest 1) '(1 nil nil))) + (should (equal (comp-test-opt-rest 1 2) '(1 2 nil))) + (should (equal (comp-test-opt-rest 1 2 3) '(1 2 (3)))) + (should (equal (comp-test-opt-rest 1 2 56 57 58) + '(1 2 (56 57 58))))) + +(ert-deftest comp-opt () + (should (equal (comp-test-opt 23) '(23))) + (should (equal (comp-test-opt 23 24) '(23 . 24))) + (should-error (comp-test-opt) + :type 'wrong-number-of-arguments) + (should-error (comp-test-opt nil 24 97) + :type 'wrong-number-of-arguments)) + +(ert-deftest comp-unwind-protect () + (comp-test-unwind-protect 'ignore) + (should (eq comp-test-up-val 999)) + (condition-case nil + (comp-test-unwind-protect (lambda () (error "HI"))) + (error + nil)) + (should (eq comp-test-up-val 999))) + +;;; comp-tests.el ends here --=-=-=--