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