;;; comp-common.el --- common code -*- lexical-binding: t -*- ;; Copyright (C) 2023 Free Software Foundation, Inc. ;; Author: Andrea Corallo ;; 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 file holds common code required by comp.el and comp-run.el. ;;; Code: (eval-when-compile (require 'cl-lib)) (defgroup comp-common nil "Emacs Lisp native compiler common code." :group 'lisp) (defcustom native-comp-verbose 0 "Compiler verbosity for native compilation, a number between 0 and 3. This is intended for debugging the compiler itself. 0 no logging. 1 final LIMPLE is logged. 2 LAP, final LIMPLE, and some pass info are logged. 3 max verbosity." :type 'natnum :risky t :version "28.1") (defcustom native-comp-never-optimize-functions '(;; The following two are mandatory for Emacs to be working ;; correctly (see comment in `advice--add-function'). DO NOT ;; REMOVE. macroexpand rename-buffer) "Primitive functions to exclude from trampoline optimization. Primitive functions included in this list will not be called directly by the natively-compiled code, which makes trampolines for those primitives unnecessary in case of function redefinition/advice." :type '(repeat symbol) :version "28.1") (defcustom native-comp-async-env-modifier-form nil "Form evaluated before compilation by each asynchronous compilation subprocess. Used to modify the compiler environment." :type 'sexp :risky t :version "28.1") (defconst comp-limple-calls '(call callref direct-call direct-callref) "Limple operators used to call subrs.") (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 `(assume fetch-handler ,@comp-limple-sets) "Limple operators that clobber the first m-var argument.") (defconst comp-limple-branches '(jump cond-jump) "Limple operators used for conditional and unconditional branches.") (defconst comp-limple-ops `(,@comp-limple-calls ,@comp-limple-assignments ,@comp-limple-branches return) "All Limple operators.") (defconst comp-limple-lock-keywords `((,(rx bol "(comment" (1+ not-newline)) . font-lock-comment-face) (,(rx "#(" (group-n 1 "mvar")) (1 font-lock-function-name-face)) (,(rx bol "(" (group-n 1 "phi")) (1 font-lock-variable-name-face)) (,(rx bol "(" (group-n 1 (or "return" "unreachable"))) (1 font-lock-warning-face)) (,(rx (group-n 1 (or "entry" (seq (or "entry_" "entry_fallback_" "bb_") (1+ num) (? (or "_latch" (seq "_cstrs_" (1+ num)))))))) (1 font-lock-constant-face)) (,(rx-to-string `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops))))) (1 font-lock-keyword-face))) "Highlights used by `native-comp-limple-mode'.") (defconst comp-log-buffer-name "*Native-compile-Log*" "Name of the native-compiler log buffer.") (cl-defun comp-log (data &optional (level 1) quoted) "Log DATA at LEVEL. LEVEL is a number from 1-3, and defaults to 1; if it is less than `native-comp-verbose', do nothing. If `noninteractive', log with `message'. Otherwise, log with `comp-log-to-buffer'." (when (>= native-comp-verbose level) (if noninteractive (cl-typecase data (atom (message "%s" data)) (t (dolist (elem data) (message "%s" elem)))) (comp-log-to-buffer data quoted)))) (define-derived-mode native-comp-limple-mode fundamental-mode "LIMPLE" "Syntax-highlight LIMPLE IR." (setf font-lock-defaults '(comp-limple-lock-keywords))) (cl-defun comp-log-to-buffer (data &optional quoted) "Log DATA to `comp-log-buffer-name'." (let* ((print-f (if quoted #'prin1 #'princ)) (log-buffer (or (get-buffer comp-log-buffer-name) (with-current-buffer (get-buffer-create comp-log-buffer-name) (unless (derived-mode-p 'compilation-mode) (emacs-lisp-compilation-mode)) (current-buffer)))) (log-window (get-buffer-window log-buffer)) (inhibit-read-only t) at-end-p) (with-current-buffer log-buffer (unless (eq major-mode 'native-comp-limple-mode) (native-comp-limple-mode)) (when (= (point) (point-max)) (setf at-end-p t)) (save-excursion (goto-char (point-max)) (cl-typecase data (atom (funcall print-f data log-buffer)) (t (dolist (elem data) (funcall print-f elem log-buffer) (insert "\n")))) (insert "\n")) (when (and at-end-p log-window) ;; When log window's point is at the end, follow the tail. (with-selected-window log-window (goto-char (point-max))))))) (defun comp-ensure-native-compiler () "Make sure Emacs has native compiler support and libgccjit can be loaded. Signal an error otherwise. To be used by all entry points." (cond ((null (featurep 'native-compile)) (error "Emacs was not compiled with native compiler support (--with-native-compilation)")) ((null (native-comp-available-p)) (error "Cannot find libgccjit library")))) (defun comp-trampoline-filename (subr-name) "Given SUBR-NAME return the filename containing the trampoline." (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln")) (defun comp-eln-load-path-eff () "Return a list of effective eln load directories. Account for `native-comp-eln-load-path' and `comp-native-version-dir'." (mapcar (lambda (dir) (expand-file-name comp-native-version-dir (file-name-as-directory (expand-file-name dir invocation-directory)))) native-comp-eln-load-path)) (provide 'comp-common) ;;; comp-common.el ends here