2019-07-07 07:23:10 +00:00
|
|
|
|
;;; comp.el --- compilation of Lisp code into native code -*- lexical-binding: t -*-
|
|
|
|
|
|
2019-09-01 09:58:20 +00:00
|
|
|
|
;; Author: Andrea Corallo <akrl@sdf.com>
|
|
|
|
|
|
2020-02-16 17:14:35 +00:00
|
|
|
|
;; Copyright (C) 2019-2020 Free Software Foundation, Inc.
|
2019-07-07 07:23:10 +00:00
|
|
|
|
|
|
|
|
|
;; 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 <https://www.gnu.org/licenses/>.
|
|
|
|
|
|
2019-07-13 13:48:02 +00:00
|
|
|
|
;;; Commentary:
|
2019-07-14 12:39:29 +00:00
|
|
|
|
;; This code is an attempt to make the pig fly.
|
2019-09-23 10:45:06 +00:00
|
|
|
|
;; Or, to put it another way to make a 911 out of a turbocharged VW Bug.
|
2019-07-13 13:48:02 +00:00
|
|
|
|
|
2019-07-07 07:23:10 +00:00
|
|
|
|
;;; Code:
|
|
|
|
|
|
2019-07-07 10:30:03 +00:00
|
|
|
|
(require 'bytecomp)
|
2019-07-08 09:37:17 +00:00
|
|
|
|
(require 'cl-extra)
|
2020-03-15 10:26:31 +00:00
|
|
|
|
(require 'cl-lib)
|
2020-02-25 22:35:02 +00:00
|
|
|
|
(require 'cl-macs)
|
2020-03-22 09:35:55 +00:00
|
|
|
|
(require 'cl-seq)
|
2020-03-15 10:26:31 +00:00
|
|
|
|
(require 'gv)
|
|
|
|
|
(require 'rx)
|
2019-07-08 09:37:17 +00:00
|
|
|
|
(require 'subr-x)
|
2019-07-07 07:23:10 +00:00
|
|
|
|
|
|
|
|
|
(defgroup comp nil
|
|
|
|
|
"Emacs Lisp native compiler."
|
|
|
|
|
:group 'lisp)
|
|
|
|
|
|
2020-03-15 21:44:05 +00:00
|
|
|
|
(defcustom comp-deferred-compilation nil
|
2020-03-18 21:20:52 +00:00
|
|
|
|
"If t compile asyncronously all lexically bound .elc files being loaded.
|
|
|
|
|
Once compilation happened each function definition is updated to
|
|
|
|
|
the native compiled one."
|
2020-03-15 21:44:05 +00:00
|
|
|
|
:type 'boolean
|
|
|
|
|
:group 'comp)
|
|
|
|
|
|
2020-02-14 15:22:24 +00:00
|
|
|
|
(defcustom comp-speed 2
|
2019-11-10 17:50:34 +00:00
|
|
|
|
"Compiler optimization level. From 0 to 3.
|
2019-11-22 18:15:12 +00:00
|
|
|
|
- 0 no optimizations are performed, compile time is favored.
|
2019-11-10 17:50:34 +00:00
|
|
|
|
- 1 lite optimizations.
|
|
|
|
|
- 2 heavy optimizations.
|
|
|
|
|
- 3 max optimization level, to be used only when necessary.
|
2019-11-11 06:42:01 +00:00
|
|
|
|
Warning: the compiler is free to perform dangerous optimizations."
|
2019-11-10 13:43:47 +00:00
|
|
|
|
:type 'number
|
|
|
|
|
:group 'comp)
|
2019-11-10 13:51:38 +00:00
|
|
|
|
|
|
|
|
|
(defcustom comp-debug 0
|
|
|
|
|
"Compiler debug level. From 0 to 3.
|
2019-11-22 18:15:12 +00:00
|
|
|
|
This intended for debugging the compiler itself.
|
2019-11-10 17:50:34 +00:00
|
|
|
|
- 0 no debug facility.
|
2019-11-22 18:15:12 +00:00
|
|
|
|
This is the recommended value unless you are debugging the compiler itself.
|
2019-11-10 17:50:34 +00:00
|
|
|
|
- 1 emit debug symbols and dump pseudo C code.
|
|
|
|
|
- 2 dump gcc passes and libgccjit log file.
|
2019-11-10 19:01:48 +00:00
|
|
|
|
- 3 dump libgccjit reproducers."
|
2019-11-10 13:51:38 +00:00
|
|
|
|
:type 'number
|
|
|
|
|
:group 'comp)
|
|
|
|
|
|
2019-09-29 16:41:31 +00:00
|
|
|
|
(defcustom comp-verbose 0
|
2019-11-09 16:12:56 +00:00
|
|
|
|
"Compiler verbosity. From 0 to 3.
|
2019-11-22 18:15:12 +00:00
|
|
|
|
This intended for debugging the compiler itself.
|
2019-11-10 17:50:34 +00:00
|
|
|
|
- 0 no logging.
|
|
|
|
|
- 1 final limple is logged.
|
|
|
|
|
- 2 LAP and final limple and some pass info are logged.
|
|
|
|
|
- 3 max verbosity."
|
2019-09-29 15:54:10 +00:00
|
|
|
|
:type 'number
|
2019-08-11 09:59:31 +00:00
|
|
|
|
:group 'comp)
|
|
|
|
|
|
2019-11-10 19:01:48 +00:00
|
|
|
|
(defcustom comp-always-compile nil
|
|
|
|
|
"Unconditionally (re-)compile all files."
|
|
|
|
|
:type 'boolean
|
|
|
|
|
:group 'comp)
|
|
|
|
|
|
2020-05-09 12:52:30 +00:00
|
|
|
|
(defcustom comp-deferred-compilation-black-list
|
|
|
|
|
'()
|
|
|
|
|
"List of regexps to exclude files from deferred native compilation.
|
|
|
|
|
Skip if any is matching."
|
|
|
|
|
:type 'list
|
|
|
|
|
:group 'comp)
|
|
|
|
|
|
2020-05-06 17:55:33 +00:00
|
|
|
|
(defcustom comp-bootstrap-black-list
|
|
|
|
|
'("^leim/")
|
|
|
|
|
"List of regexps to exclude files from native compilation during bootstrap.
|
|
|
|
|
Skip if any is matching."
|
|
|
|
|
:type 'list
|
|
|
|
|
:group 'comp)
|
|
|
|
|
|
2019-12-29 13:10:19 +00:00
|
|
|
|
(defcustom comp-never-optimize-functions
|
2020-04-16 17:59:40 +00:00
|
|
|
|
'(;; Mandatory for Emacs to be working correctly
|
|
|
|
|
macroexpand scroll-down scroll-up narrow-to-region widen rename-buffer
|
|
|
|
|
make-indirect-buffer delete-file top-level abort-recursive-edit
|
|
|
|
|
;; For user convenience
|
2020-05-18 18:04:07 +00:00
|
|
|
|
yes-or-no-p
|
|
|
|
|
;; Make the Evil happy :/
|
|
|
|
|
read-key-sequence select-window set-window-buffer split-window-internal
|
|
|
|
|
use-global-map use-local-map)
|
2019-12-29 13:10:19 +00:00
|
|
|
|
"Primitive functions for which we do not perform trampoline optimization.
|
2020-04-16 18:03:54 +00:00
|
|
|
|
This is especially useful for primitives known to be advised or
|
|
|
|
|
redefined when compilation is performed at `comp-speed' > 0."
|
2019-12-29 13:10:19 +00:00
|
|
|
|
:type 'list
|
|
|
|
|
:group 'comp)
|
|
|
|
|
|
2020-03-15 20:17:15 +00:00
|
|
|
|
(defcustom comp-async-jobs-number 0
|
|
|
|
|
"Default number of processes used for async compilation.
|
|
|
|
|
When zero use half of the CPUs or at least one."
|
2020-03-19 18:37:32 +00:00
|
|
|
|
:type 'number
|
2020-03-15 19:37:51 +00:00
|
|
|
|
:group 'comp)
|
|
|
|
|
|
2020-02-23 14:49:46 +00:00
|
|
|
|
(defcustom comp-async-cu-done-hook nil
|
|
|
|
|
"This hook is run whenever an asyncronous native compilation
|
2020-02-24 09:32:51 +00:00
|
|
|
|
finishes compiling a single compilation unit.
|
2020-02-23 14:49:46 +00:00
|
|
|
|
The argument FILE passed to the function is the filename used as
|
|
|
|
|
compilation input."
|
|
|
|
|
:type 'hook
|
|
|
|
|
:group 'comp)
|
|
|
|
|
|
|
|
|
|
(defcustom comp-async-all-done-hook nil
|
|
|
|
|
"This hook is run whenever the asyncronous native compilation
|
2020-02-24 09:32:51 +00:00
|
|
|
|
finishes compiling all input files."
|
2020-02-23 14:49:46 +00:00
|
|
|
|
:type 'hook
|
|
|
|
|
:group 'comp)
|
|
|
|
|
|
2020-05-18 19:45:29 +00:00
|
|
|
|
(defcustom comp-async-env-modifier-form nil
|
|
|
|
|
"Form to be evaluated by each asyncronous compilation worker
|
|
|
|
|
before compilation. Usable to modify the compiler environment."
|
|
|
|
|
:type 'list
|
|
|
|
|
:group 'comp)
|
|
|
|
|
|
2020-02-16 10:31:46 +00:00
|
|
|
|
(defvar comp-dry-run nil
|
|
|
|
|
"When non nil run everything but the C back-end.")
|
|
|
|
|
|
2019-11-24 17:34:54 +00:00
|
|
|
|
(defconst comp-log-buffer-name "*Native-compile-Log*"
|
2019-11-24 17:42:40 +00:00
|
|
|
|
"Name of the native-compiler log buffer.")
|
2019-07-07 07:23:10 +00:00
|
|
|
|
|
2019-11-24 17:42:40 +00:00
|
|
|
|
(defconst comp-async-buffer-name "*Async-native-compile-log*"
|
|
|
|
|
"Name of the async compilation buffer log.")
|
2019-11-24 17:25:04 +00:00
|
|
|
|
|
2019-09-23 09:48:19 +00:00
|
|
|
|
(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.")
|
|
|
|
|
|
2019-07-21 13:20:39 +00:00
|
|
|
|
(defvar comp-pass nil
|
|
|
|
|
"Every pass has the right to bind what it likes here.")
|
|
|
|
|
|
2020-02-25 21:39:59 +00:00
|
|
|
|
(defvar comp-curr-allocation-class 'd-default
|
2020-02-25 22:35:02 +00:00
|
|
|
|
"Current allocation class.
|
2020-02-25 21:39:59 +00:00
|
|
|
|
Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.")
|
2020-02-21 14:28:05 +00:00
|
|
|
|
|
2019-07-21 13:20:39 +00:00
|
|
|
|
(defconst comp-passes '(comp-spill-lap
|
2019-09-07 06:57:07 +00:00
|
|
|
|
comp-limplify
|
2020-02-29 17:38:50 +00:00
|
|
|
|
comp-propagate
|
2019-09-18 09:30:23 +00:00
|
|
|
|
comp-call-optim
|
2020-02-29 17:38:50 +00:00
|
|
|
|
comp-propagate
|
2019-09-22 16:49:11 +00:00
|
|
|
|
comp-dead-code
|
2020-02-16 11:19:10 +00:00
|
|
|
|
comp-tco
|
2020-02-29 17:38:50 +00:00
|
|
|
|
comp-propagate-alloc
|
2020-05-25 19:27:46 +00:00
|
|
|
|
comp-remove-type-hints
|
2019-09-07 06:57:07 +00:00
|
|
|
|
comp-final)
|
2019-07-07 10:30:03 +00:00
|
|
|
|
"Passes to be executed in order.")
|
|
|
|
|
|
2019-09-15 12:43:30 +00:00
|
|
|
|
(defconst comp-known-ret-types '((cons . cons)
|
|
|
|
|
(1+ . number)
|
|
|
|
|
(1- . number)
|
|
|
|
|
(+ . number)
|
|
|
|
|
(- . number)
|
|
|
|
|
(* . number)
|
|
|
|
|
(/ . number)
|
2019-09-23 09:41:36 +00:00
|
|
|
|
(% . number)
|
2019-11-23 16:03:08 +00:00
|
|
|
|
;; Type hints
|
2019-09-23 09:41:36 +00:00
|
|
|
|
(comp-hint-fixnum . fixnum)
|
|
|
|
|
(comp-hint-cons . cons))
|
2019-07-21 13:20:39 +00:00
|
|
|
|
"Alist used for type propagation.")
|
2019-07-07 19:49:11 +00:00
|
|
|
|
|
2020-06-06 22:34:21 +00:00
|
|
|
|
(defconst comp-symbol-values-optimizable '(most-positive-fixnum
|
|
|
|
|
most-negative-fixnum)
|
|
|
|
|
"Symbol values we can resolve in the compile-time.")
|
|
|
|
|
|
2019-09-23 09:41:36 +00:00
|
|
|
|
(defconst comp-type-hints '(comp-hint-fixnum
|
|
|
|
|
comp-hint-cons)
|
|
|
|
|
"List of fake functions used to give compiler hints.")
|
|
|
|
|
|
2019-09-22 16:49:11 +00:00
|
|
|
|
(defconst comp-limple-sets '(set
|
|
|
|
|
setimm
|
|
|
|
|
set-par-to-local
|
|
|
|
|
set-args-to-local
|
|
|
|
|
set-rest-args-to-local)
|
|
|
|
|
"Limple set operators.")
|
|
|
|
|
|
2019-10-20 19:00:17 +00:00
|
|
|
|
(defconst comp-limple-assignments `(fetch-handler
|
2019-09-22 16:49:11 +00:00
|
|
|
|
,@comp-limple-sets)
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Limple operators that clobbers the first m-var argument.")
|
2019-09-14 10:39:53 +00:00
|
|
|
|
|
2019-09-22 16:49:11 +00:00
|
|
|
|
(defconst comp-limple-calls '(call
|
|
|
|
|
callref
|
|
|
|
|
direct-call
|
|
|
|
|
direct-callref)
|
|
|
|
|
"Limple operators use to call subrs.")
|
|
|
|
|
|
2019-12-29 14:56:49 +00:00
|
|
|
|
(define-error 'native-compiler-error-dyn-func
|
|
|
|
|
"can't native compile a non lexical scoped function"
|
|
|
|
|
'native-compiler-error)
|
|
|
|
|
(define-error 'native-compiler-error-empty-byte
|
|
|
|
|
"empty byte compiler output"
|
|
|
|
|
'native-compiler-error)
|
|
|
|
|
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(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."))
|
|
|
|
|
|
2020-01-12 10:47:50 +00:00
|
|
|
|
(cl-defstruct comp-data-container
|
|
|
|
|
"Data relocation container structure."
|
|
|
|
|
(l () :type list
|
|
|
|
|
:documentation "Constant objects used by functions.")
|
|
|
|
|
(idx (make-hash-table :test #'equal) :type hash-table
|
|
|
|
|
:documentation "Obj -> position into the previous field."))
|
|
|
|
|
|
2019-08-18 13:36:36 +00:00
|
|
|
|
(cl-defstruct comp-ctxt
|
2019-09-07 06:57:07 +00:00
|
|
|
|
"Lisp side of the compiler context."
|
2019-10-13 15:41:26 +00:00
|
|
|
|
(output nil :type string
|
2019-11-22 18:15:12 +00:00
|
|
|
|
:documentation "Target output file-name for the compilation.")
|
2019-11-02 16:32:42 +00:00
|
|
|
|
(top-level-forms () :type list
|
|
|
|
|
:documentation "List of spilled top level forms.")
|
2020-03-28 20:56:47 +00:00
|
|
|
|
(funcs-h (make-hash-table :test #'equal) :type hash-table
|
|
|
|
|
:documentation "c-name -> comp-func.")
|
|
|
|
|
(sym-to-c-name-h (make-hash-table :test #'eq) :type hash-table
|
|
|
|
|
:documentation "symbol-function -> c-name.
|
|
|
|
|
This is only for optimizing intra CU calls at speed 3.")
|
2020-05-02 16:29:11 +00:00
|
|
|
|
(byte-func-to-func-h (make-hash-table :test #'equal) :type hash-table
|
2020-05-01 16:32:39 +00:00
|
|
|
|
:documentation "byte-function -> comp-func.
|
|
|
|
|
Needed to replace immediate byte-compiled lambdas with the compiled reference.")
|
2020-05-02 16:29:11 +00:00
|
|
|
|
(lambda-fixups-h (make-hash-table :test #'equal) :type hash-table
|
|
|
|
|
:documentation "Hash table byte-func -> mvar to fixup.")
|
2020-04-26 08:11:33 +00:00
|
|
|
|
(function-docs (make-hash-table :test #'eql) :type (or hash-table vector)
|
2020-04-25 15:13:03 +00:00
|
|
|
|
:documentation "Documentation index -> documentation")
|
2020-02-25 21:39:59 +00:00
|
|
|
|
(d-default (make-comp-data-container) :type comp-data-container
|
2020-03-28 20:56:47 +00:00
|
|
|
|
:documentation "Standard data relocated in use by functions.")
|
2020-01-12 10:47:50 +00:00
|
|
|
|
(d-impure (make-comp-data-container) :type comp-data-container
|
2020-03-28 20:56:47 +00:00
|
|
|
|
:documentation "Relocated data that cannot be moved into pure space.
|
2020-02-25 22:35:02 +00:00
|
|
|
|
This is tipically for top-level forms other than defun.")
|
|
|
|
|
(d-ephemeral (make-comp-data-container) :type comp-data-container
|
2020-03-17 22:24:52 +00:00
|
|
|
|
:documentation "Relocated data not necessary after load.")
|
|
|
|
|
(with-late-load nil :type boolean
|
|
|
|
|
:documentation "When non nil support late load."))
|
2019-08-18 13:36:36 +00:00
|
|
|
|
|
2019-08-16 13:48:38 +00:00
|
|
|
|
(cl-defstruct comp-args-base
|
2019-07-08 13:29:32 +00:00
|
|
|
|
(min nil :type number
|
2019-08-11 12:54:13 +00:00
|
|
|
|
:documentation "Minimum number of arguments allowed."))
|
|
|
|
|
|
2019-08-16 13:48:38 +00:00
|
|
|
|
(cl-defstruct (comp-args (:include comp-args-base))
|
2019-08-11 12:54:13 +00:00
|
|
|
|
(max nil :type number
|
2019-07-21 13:20:39 +00:00
|
|
|
|
:documentation "Maximum number of arguments allowed.
|
2019-08-11 12:54:13 +00:00
|
|
|
|
To be used when ncall-conv is nil."))
|
|
|
|
|
|
2019-08-16 13:48:38 +00:00
|
|
|
|
(cl-defstruct (comp-nargs (:include comp-args-base))
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Describe args when the function signature is of kind:
|
2019-08-11 12:54:13 +00:00
|
|
|
|
(ptrdiff_t nargs, Lisp_Object *args)."
|
|
|
|
|
(nonrest nil :type number
|
2019-11-02 11:17:26 +00:00
|
|
|
|
:documentation "Number of non rest arguments.")
|
|
|
|
|
(rest nil :type boolean
|
|
|
|
|
:documentation "t if rest argument is present."))
|
2019-07-07 10:30:03 +00:00
|
|
|
|
|
2019-11-01 14:28:17 +00:00
|
|
|
|
(cl-defstruct (comp-block (:copier nil)
|
|
|
|
|
(:constructor make--comp-block
|
|
|
|
|
(addr sp name))) ; Positional
|
2019-07-14 15:21:34 +00:00
|
|
|
|
"A basic block."
|
2019-09-11 19:51:37 +00:00
|
|
|
|
(name nil :type symbol)
|
|
|
|
|
;; These two slots are used during limplification.
|
2019-10-13 08:36:22 +00:00
|
|
|
|
(sp nil :type number
|
2019-07-21 13:20:39 +00:00
|
|
|
|
:documentation "When non nil indicates the sp value while entering
|
2019-07-14 18:54:53 +00:00
|
|
|
|
into it.")
|
2019-10-13 08:36:22 +00:00
|
|
|
|
(addr nil :type number
|
|
|
|
|
:documentation "Start block LAP address.")
|
2019-07-21 13:20:39 +00:00
|
|
|
|
(insns () :type list
|
2019-09-13 18:56:24 +00:00
|
|
|
|
:documentation "List of instructions.")
|
2019-10-20 14:04:29 +00:00
|
|
|
|
(closed nil :type boolean
|
|
|
|
|
:documentation "t if closed.")
|
2019-09-14 08:13:38 +00:00
|
|
|
|
;; All the followings are for SSA and CGF analysis.
|
2020-02-29 17:14:43 +00:00
|
|
|
|
;; Keep in sync with `comp-clean-ssa'!!
|
2019-09-13 18:56:24 +00:00
|
|
|
|
(in-edges () :type list
|
|
|
|
|
:documentation "List of incoming edges.")
|
|
|
|
|
(out-edges () :type list
|
2019-11-22 18:15:12 +00:00
|
|
|
|
:documentation "List of out-coming edges.")
|
2019-09-13 18:56:24 +00:00
|
|
|
|
(dom nil :type comp-block
|
|
|
|
|
:documentation "Immediate dominator.")
|
2019-09-14 08:13:38 +00:00
|
|
|
|
(df (make-hash-table) :type hash-table
|
2019-09-14 10:39:53 +00:00
|
|
|
|
:documentation "Dominance frontier set. Block-name -> block")
|
2019-09-13 18:56:24 +00:00
|
|
|
|
(post-num nil :type number
|
2019-09-16 23:01:34 +00:00
|
|
|
|
: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."))
|
2019-07-14 15:21:34 +00:00
|
|
|
|
|
2019-09-13 15:55:16 +00:00
|
|
|
|
(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."))
|
|
|
|
|
|
2019-09-13 18:56:24 +00:00
|
|
|
|
(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)))
|
|
|
|
|
|
2019-09-13 15:55:16 +00:00
|
|
|
|
(defun comp-gen-counter ()
|
|
|
|
|
"Return a sequential number generator."
|
|
|
|
|
(let ((n -1))
|
|
|
|
|
(lambda ()
|
|
|
|
|
(cl-incf n))))
|
|
|
|
|
|
2019-07-07 10:30:03 +00:00
|
|
|
|
(cl-defstruct (comp-func (:copier nil))
|
2019-07-21 13:20:39 +00:00
|
|
|
|
"LIMPLE representation of a function."
|
2019-11-24 14:07:54 +00:00
|
|
|
|
(name nil :type symbol
|
2020-05-01 16:32:39 +00:00
|
|
|
|
:documentation "Function symbol name. Nil indicates anonymous.")
|
2019-11-24 14:07:54 +00:00
|
|
|
|
(c-name nil :type string
|
|
|
|
|
:documentation "The function name in the native world.")
|
2019-07-07 10:30:03 +00:00
|
|
|
|
(byte-func nil
|
2019-07-14 18:54:53 +00:00
|
|
|
|
:documentation "Byte compiled version.")
|
2019-11-02 16:33:55 +00:00
|
|
|
|
(doc nil :type string
|
|
|
|
|
:documentation "Doc string.")
|
2019-12-07 16:38:08 +00:00
|
|
|
|
(int-spec nil :type list
|
|
|
|
|
:documentation "Interactive form.")
|
2019-07-21 13:20:39 +00:00
|
|
|
|
(lap () :type list
|
2019-09-22 07:58:20 +00:00
|
|
|
|
:documentation "LAP assembly representation.")
|
2020-02-29 17:14:43 +00:00
|
|
|
|
(ssa-status nil :type symbol
|
|
|
|
|
:documentation "SSA status either: 'nil', 'dirty' or 't'.
|
|
|
|
|
Once in SSA form this *must* be set to 'dirty' every time the topology of the
|
|
|
|
|
CFG is mutated by a pass.")
|
2019-08-18 08:34:18 +00:00
|
|
|
|
(args nil :type comp-args-base)
|
|
|
|
|
(frame-size nil :type number)
|
|
|
|
|
(blocks (make-hash-table) :type hash-table
|
2019-07-14 15:21:34 +00:00
|
|
|
|
:documentation "Key is the basic block symbol value is a comp-block
|
2019-07-14 18:54:53 +00:00
|
|
|
|
structure.")
|
2019-08-18 08:34:18 +00:00
|
|
|
|
(lap-block (make-hash-table :test #'equal) :type hash-table
|
2019-09-22 07:58:20 +00:00
|
|
|
|
:documentation "LAP lable -> LIMPLE basic block name.")
|
2019-09-11 21:13:13 +00:00
|
|
|
|
(edges () :type list
|
|
|
|
|
:documentation "List of edges connecting basic blocks.")
|
2019-09-22 07:58:20 +00:00
|
|
|
|
(block-cnt-gen (funcall #'comp-gen-counter) :type function
|
|
|
|
|
:documentation "Generates block numbers.")
|
2019-09-14 10:39:53 +00:00
|
|
|
|
(edge-cnt-gen (funcall #'comp-gen-counter) :type function
|
2019-09-22 07:58:20 +00:00
|
|
|
|
:documentation "Generates edges numbers.")
|
2019-12-28 10:39:29 +00:00
|
|
|
|
(has-non-local nil :type boolean
|
2020-02-09 15:17:21 +00:00
|
|
|
|
:documentation "t if non local jumps are present.")
|
|
|
|
|
(array-h (make-hash-table) :type hash-table
|
|
|
|
|
:documentation "array idx -> array length."))
|
2019-07-07 10:30:03 +00:00
|
|
|
|
|
2019-11-09 15:22:07 +00:00
|
|
|
|
(cl-defstruct (comp-mvar (:constructor make--comp-mvar))
|
2019-07-07 19:49:11 +00:00
|
|
|
|
"A meta-variable being a slot in the meta-stack."
|
2019-09-14 16:12:16 +00:00
|
|
|
|
(id nil :type (or null number)
|
2020-02-20 09:14:57 +00:00
|
|
|
|
:documentation "Unique id when in SSA form.")
|
|
|
|
|
;; The following two are allocation info.
|
|
|
|
|
(array-idx 0 :type fixnum
|
|
|
|
|
:documentation "The array where the m-var gets allocated.")
|
|
|
|
|
(slot nil :type (or fixnum symbol)
|
|
|
|
|
:documentation "Slot number in the array if a number or
|
|
|
|
|
'scratch' for scratch slot.")
|
2019-09-15 12:43:30 +00:00
|
|
|
|
(const-vld nil :type boolean
|
2019-07-14 18:54:53 +00:00
|
|
|
|
:documentation "Valid signal for the following slot.")
|
2019-07-07 10:30:03 +00:00
|
|
|
|
(constant nil
|
2019-11-22 18:15:12 +00:00
|
|
|
|
:documentation "When const-vld non nil this is used for holding
|
|
|
|
|
a value known at compile time.")
|
2020-02-20 09:14:57 +00:00
|
|
|
|
(type nil :type symbol
|
2019-11-26 23:23:56 +00:00
|
|
|
|
:documentation "When non nil indicates the type when known at compile
|
2020-02-29 15:53:42 +00:00
|
|
|
|
time."))
|
2019-07-07 10:30:03 +00:00
|
|
|
|
|
2019-09-14 13:25:11 +00:00
|
|
|
|
;; Special vars used by some passes
|
|
|
|
|
(defvar comp-func)
|
|
|
|
|
|
2019-08-18 13:36:36 +00:00
|
|
|
|
|
2019-09-15 12:43:30 +00:00
|
|
|
|
|
2019-12-30 23:20:35 +00:00
|
|
|
|
(defsubst comp-set-op-p (op)
|
2019-09-22 16:49:11 +00:00
|
|
|
|
"Assignment predicate for OP."
|
2020-01-20 19:30:24 +00:00
|
|
|
|
(when (memq op comp-limple-sets) t))
|
2019-09-22 16:49:11 +00:00
|
|
|
|
|
2019-12-30 23:20:35 +00:00
|
|
|
|
(defsubst comp-assign-op-p (op)
|
2019-09-14 15:00:16 +00:00
|
|
|
|
"Assignment predicate for OP."
|
2020-01-20 19:30:24 +00:00
|
|
|
|
(when (memq op comp-limple-assignments) t))
|
2019-09-14 15:00:16 +00:00
|
|
|
|
|
2019-12-30 23:20:35 +00:00
|
|
|
|
(defsubst comp-limple-insn-call-p (insn)
|
2019-09-22 16:49:11 +00:00
|
|
|
|
"Limple INSN call predicate."
|
2020-01-20 19:30:24 +00:00
|
|
|
|
(when (memq (car-safe insn) comp-limple-calls) t))
|
2019-09-22 16:49:11 +00:00
|
|
|
|
|
2019-12-30 23:20:35 +00:00
|
|
|
|
(defsubst comp-type-hint-p (func)
|
2019-09-23 09:41:36 +00:00
|
|
|
|
"Type hint predicate for function name FUNC."
|
2020-01-20 19:30:24 +00:00
|
|
|
|
(when (memq func comp-type-hints) t))
|
2019-09-23 09:41:36 +00:00
|
|
|
|
|
2020-06-06 14:53:34 +00:00
|
|
|
|
(defun comp-func-unique-in-cu-p (func)
|
|
|
|
|
"Return t if FUNC is know to be unique in the current compilation unit."
|
|
|
|
|
(if (symbolp func)
|
|
|
|
|
(cl-loop with h = (make-hash-table :test #'eq)
|
|
|
|
|
for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt)
|
|
|
|
|
for name = (comp-func-name f)
|
|
|
|
|
when (gethash name h)
|
|
|
|
|
return nil
|
|
|
|
|
do (puthash name t h)
|
|
|
|
|
finally return t)
|
|
|
|
|
t))
|
|
|
|
|
|
2020-02-25 22:35:02 +00:00
|
|
|
|
(defsubst comp-alloc-class-to-container (alloc-class)
|
|
|
|
|
"Given ALLOC-CLASS return the data container for the current context.
|
2020-02-25 21:39:59 +00:00
|
|
|
|
Assume allocaiton class 'd-default as default."
|
|
|
|
|
(cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt))
|
2020-02-25 22:35:02 +00:00
|
|
|
|
|
2020-02-29 15:53:42 +00:00
|
|
|
|
(defsubst comp-add-const-to-relocs (obj)
|
|
|
|
|
"Keep track of OBJ into the ctxt relocations."
|
|
|
|
|
(puthash obj t (comp-data-container-idx (comp-alloc-class-to-container
|
|
|
|
|
comp-curr-allocation-class))))
|
2019-08-18 13:36:36 +00:00
|
|
|
|
|
2020-03-15 10:19:22 +00:00
|
|
|
|
(cl-defun comp-log (data &optional (level 1))
|
|
|
|
|
"Log DATA at LEVEL.
|
|
|
|
|
LEVEL is a number from 1-3; if it is less than `comp-verbose', do
|
|
|
|
|
nothing. If `noninteractive', log with `message'. Otherwise,
|
|
|
|
|
log with `comp-log-to-buffer'."
|
|
|
|
|
(when (>= comp-verbose level)
|
2019-11-09 15:56:55 +00:00
|
|
|
|
(if noninteractive
|
2020-03-15 10:19:22 +00:00
|
|
|
|
(cl-typecase data
|
|
|
|
|
(atom (message "%s" data))
|
|
|
|
|
(t (dolist (elem data)
|
|
|
|
|
(message "%s" elem))))
|
|
|
|
|
(comp-log-to-buffer data))))
|
|
|
|
|
|
|
|
|
|
(cl-defun comp-log-to-buffer (data)
|
|
|
|
|
"Log DATA to `comp-log-buffer-name'."
|
|
|
|
|
(let* ((log-buffer
|
|
|
|
|
(or (get-buffer comp-log-buffer-name)
|
|
|
|
|
(with-current-buffer (get-buffer-create comp-log-buffer-name)
|
|
|
|
|
(setf buffer-read-only t)
|
|
|
|
|
(current-buffer))))
|
|
|
|
|
(log-window (get-buffer-window log-buffer))
|
|
|
|
|
(inhibit-read-only t)
|
|
|
|
|
at-end-p)
|
|
|
|
|
(with-current-buffer log-buffer
|
|
|
|
|
(when (= (point) (point-max))
|
|
|
|
|
(setf at-end-p t))
|
|
|
|
|
(save-excursion
|
|
|
|
|
(goto-char (point-max))
|
|
|
|
|
(cl-typecase data
|
|
|
|
|
(atom (princ data log-buffer))
|
|
|
|
|
(t (dolist (elem data)
|
|
|
|
|
(princ 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)))))))
|
2019-11-09 15:56:55 +00:00
|
|
|
|
|
|
|
|
|
(defun comp-log-func (func verbosity)
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Log function FUNC.
|
|
|
|
|
VERBOSITY is a number between 0 and 3."
|
2019-11-09 15:56:55 +00:00
|
|
|
|
(when (>= comp-verbose verbosity)
|
2019-11-24 14:07:54 +00:00
|
|
|
|
(comp-log (format "\nFunction: %s\n" (comp-func-name func)) verbosity)
|
2019-11-09 15:56:55 +00:00
|
|
|
|
(cl-loop for block-name being each hash-keys of (comp-func-blocks func)
|
|
|
|
|
using (hash-value bb)
|
2019-11-25 19:33:47 +00:00
|
|
|
|
do (comp-log (concat "<" (symbol-name block-name) ">") verbosity)
|
2019-11-09 15:56:55 +00:00
|
|
|
|
(comp-log (comp-block-insns bb) verbosity))))
|
2019-07-21 13:20:39 +00:00
|
|
|
|
|
2019-09-11 21:13:13 +00:00
|
|
|
|
(defun comp-log-edges (func)
|
|
|
|
|
"Log edges in FUNC."
|
|
|
|
|
(let ((edges (comp-func-edges func)))
|
2019-11-24 18:50:15 +00:00
|
|
|
|
(comp-log (format "\nEdges in function: %s\n"
|
|
|
|
|
(comp-func-name func))
|
|
|
|
|
2)
|
2019-09-11 21:13:13 +00:00
|
|
|
|
(mapc (lambda (e)
|
2019-11-24 18:50:15 +00:00
|
|
|
|
(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))
|
2019-09-11 21:13:13 +00:00
|
|
|
|
edges)))
|
|
|
|
|
|
2020-05-03 13:35:50 +00:00
|
|
|
|
(defun comp-output-directory (src)
|
|
|
|
|
"Return the compilation direcotry for source SRC."
|
|
|
|
|
(let* ((src (if (symbolp src) (symbol-name src) src))
|
|
|
|
|
(expanded-filename (expand-file-name src)))
|
|
|
|
|
(file-name-as-directory
|
|
|
|
|
(concat (file-name-directory expanded-filename)
|
|
|
|
|
comp-native-path-postfix))))
|
|
|
|
|
|
2020-03-18 19:52:36 +00:00
|
|
|
|
(defun comp-output-base-filename (src)
|
|
|
|
|
"Output filename sans extention for SRC file being native compiled."
|
2020-03-29 10:09:02 +00:00
|
|
|
|
(let* ((src (if (symbolp src) (symbol-name src) src))
|
|
|
|
|
(expanded-filename (expand-file-name src))
|
2020-05-03 13:35:50 +00:00
|
|
|
|
(output-dir (comp-output-directory src))
|
2020-03-18 19:52:36 +00:00
|
|
|
|
(output-filename
|
|
|
|
|
(file-name-sans-extension
|
|
|
|
|
(file-name-nondirectory expanded-filename))))
|
|
|
|
|
(expand-file-name output-filename output-dir)))
|
|
|
|
|
|
|
|
|
|
(defun comp-output-filename (src)
|
|
|
|
|
"Output filename for SRC file being native compiled."
|
|
|
|
|
(concat (comp-output-base-filename src) ".eln"))
|
|
|
|
|
|
2020-06-03 21:06:26 +00:00
|
|
|
|
(defmacro comp-loop-insn-in-block (basic-block &rest body)
|
|
|
|
|
"Loop over all insns in BASIC-BLOCK executning BODY.
|
|
|
|
|
Inside BODY `insn' can be used to read or set the current
|
|
|
|
|
instruction."
|
|
|
|
|
(declare (debug (form body))
|
|
|
|
|
(indent defun))
|
|
|
|
|
(let ((sym-cell (gensym "cell-")))
|
|
|
|
|
`(cl-symbol-macrolet ((insn (car ,sym-cell)))
|
|
|
|
|
(cl-loop for ,sym-cell on (comp-block-insns ,basic-block)
|
|
|
|
|
do ,@body))))
|
2019-07-21 13:20:39 +00:00
|
|
|
|
|
|
|
|
|
;;; spill-lap pass specific code.
|
2019-07-09 16:09:47 +00:00
|
|
|
|
|
2020-05-15 10:43:31 +00:00
|
|
|
|
(defsubst comp-lex-byte-func-p (f)
|
|
|
|
|
"Return t if F is a lexical scoped byte compiled function."
|
|
|
|
|
(and (byte-code-function-p f)
|
|
|
|
|
(fixnump (aref f 0))))
|
|
|
|
|
|
2019-12-23 10:51:33 +00:00
|
|
|
|
(defun comp-c-func-name (name prefix)
|
|
|
|
|
"Given NAME return a name suitable for the native code.
|
2019-08-21 10:17:56 +00:00
|
|
|
|
Put PREFIX in front of it."
|
2019-07-08 10:11:34 +00:00
|
|
|
|
;; Unfortunatelly not all symbol names are valid as C function names...
|
2019-07-21 13:20:39 +00:00
|
|
|
|
;; Nassi's algorithm here:
|
2019-12-23 10:51:33 +00:00
|
|
|
|
(let* ((orig-name (if (symbolp name) (symbol-name name) name))
|
2019-07-08 10:11:34 +00:00
|
|
|
|
(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))
|
2019-10-14 20:08:24 +00:00
|
|
|
|
(aset str (1+ j) (aref byte 1))
|
2019-07-08 10:11:34 +00:00
|
|
|
|
finally return str))
|
|
|
|
|
(human-readable (replace-regexp-in-string
|
2019-07-10 19:29:32 +00:00
|
|
|
|
"-" "_" orig-name))
|
|
|
|
|
(human-readable (replace-regexp-in-string
|
2019-07-14 19:10:56 +00:00
|
|
|
|
(rx (not (any "0-9a-z_"))) "" human-readable)))
|
2020-04-06 19:03:34 +00:00
|
|
|
|
(if comp-ctxt
|
|
|
|
|
;; Prevent C namespace conflicts.
|
|
|
|
|
(cl-loop
|
|
|
|
|
with h = (comp-ctxt-funcs-h comp-ctxt)
|
|
|
|
|
for i from 0
|
|
|
|
|
for c-sym = (concat prefix crypted "_" human-readable "_"
|
|
|
|
|
(number-to-string i))
|
|
|
|
|
unless (gethash c-sym h)
|
|
|
|
|
return c-sym)
|
|
|
|
|
;; When called out of a compilation context (ex disassembling)
|
|
|
|
|
;; pick the first one.
|
|
|
|
|
(concat prefix crypted "_" human-readable "_0"))))
|
2019-07-08 10:11:34 +00:00
|
|
|
|
|
2019-12-29 14:56:49 +00:00
|
|
|
|
(defun comp-decrypt-arg-list (x function-name)
|
|
|
|
|
"Decript argument list X for FUNCTION-NAME."
|
2019-09-07 09:17:02 +00:00
|
|
|
|
(unless (fixnump x)
|
2019-12-29 14:56:49 +00:00
|
|
|
|
(signal 'native-compiler-error-dyn-func function-name))
|
2019-07-08 13:29:32 +00:00
|
|
|
|
(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)
|
2019-08-11 12:54:13 +00:00
|
|
|
|
(make-comp-nargs :min mandatory
|
2019-11-02 11:17:26 +00:00
|
|
|
|
:nonrest nonrest
|
|
|
|
|
:rest rest))))
|
2019-07-07 10:30:03 +00:00
|
|
|
|
|
2019-11-24 15:21:43 +00:00
|
|
|
|
(defsubst comp-byte-frame-size (byte-compiled-func)
|
2019-09-29 19:43:57 +00:00
|
|
|
|
"Given BYTE-COMPILED-FUNC return the frame size to be allocated."
|
2019-11-24 15:21:43 +00:00
|
|
|
|
(aref byte-compiled-func 3))
|
2019-09-29 19:43:57 +00:00
|
|
|
|
|
2020-03-28 20:56:47 +00:00
|
|
|
|
(defun comp-add-func-to-ctxt (func)
|
|
|
|
|
"Add FUNC to the current compiler contex."
|
|
|
|
|
(let ((name (comp-func-name func))
|
|
|
|
|
(c-name (comp-func-c-name func)))
|
|
|
|
|
(puthash name c-name (comp-ctxt-sym-to-c-name-h comp-ctxt))
|
|
|
|
|
(puthash c-name func (comp-ctxt-funcs-h comp-ctxt))))
|
|
|
|
|
|
2019-11-23 16:03:08 +00:00
|
|
|
|
(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))
|
2019-09-07 09:17:02 +00:00
|
|
|
|
"Byte compile FUNCTION-NAME spilling data from the byte compiler."
|
2020-04-26 18:55:26 +00:00
|
|
|
|
(let* ((f (symbol-function function-name))
|
2020-03-28 20:56:47 +00:00
|
|
|
|
(c-name (comp-c-func-name function-name "F"))
|
2019-11-24 14:07:54 +00:00
|
|
|
|
(func (make-comp-func :name function-name
|
2020-03-28 20:56:47 +00:00
|
|
|
|
:c-name c-name
|
2019-12-08 19:52:34 +00:00
|
|
|
|
:doc (documentation f)
|
|
|
|
|
:int-spec (interactive-form f))))
|
2019-11-23 16:03:08 +00:00
|
|
|
|
(when (byte-code-function-p f)
|
|
|
|
|
(signal 'native-compiler-error
|
|
|
|
|
"can't native compile an already bytecompiled function"))
|
|
|
|
|
(setf (comp-func-byte-func func)
|
2019-11-24 14:07:54 +00:00
|
|
|
|
(byte-compile (comp-func-name func)))
|
2020-05-01 16:32:39 +00:00
|
|
|
|
(let ((lap (byte-to-native-lambda-lap
|
|
|
|
|
(gethash (aref (comp-func-byte-func func) 1)
|
|
|
|
|
byte-to-native-lambdas-h))))
|
2019-11-23 16:03:08 +00:00
|
|
|
|
(cl-assert lap)
|
2019-11-24 18:49:25 +00:00
|
|
|
|
(comp-log lap 2)
|
2019-12-07 16:31:54 +00:00
|
|
|
|
(let ((arg-list (aref (comp-func-byte-func func) 0)))
|
2019-11-23 16:03:08 +00:00
|
|
|
|
(setf (comp-func-args func)
|
2019-12-29 14:56:49 +00:00
|
|
|
|
(comp-decrypt-arg-list arg-list function-name)
|
2019-11-24 15:21:43 +00:00
|
|
|
|
(comp-func-lap func)
|
|
|
|
|
lap
|
2019-11-23 16:03:08 +00:00
|
|
|
|
(comp-func-frame-size func)
|
|
|
|
|
(comp-byte-frame-size (comp-func-byte-func func))))
|
2019-11-24 15:18:51 +00:00
|
|
|
|
(setf (comp-ctxt-top-level-forms comp-ctxt)
|
2020-05-01 16:32:39 +00:00
|
|
|
|
(list (make-byte-to-native-func-def :name function-name
|
2020-03-29 10:21:55 +00:00
|
|
|
|
:c-name c-name)))
|
2020-02-09 15:17:21 +00:00
|
|
|
|
;; Create the default array.
|
|
|
|
|
(puthash 0 (comp-func-frame-size func) (comp-func-array-h func))
|
2020-03-28 20:56:47 +00:00
|
|
|
|
(comp-add-func-to-ctxt func))))
|
2019-11-23 16:03:08 +00:00
|
|
|
|
|
2020-05-03 14:11:07 +00:00
|
|
|
|
(defun comp-intern-func-in-ctxt (_ obj)
|
|
|
|
|
"Given OBJ of type `byte-to-native-lambda' create a function in `comp-ctxt'."
|
|
|
|
|
(when-let ((byte-func (byte-to-native-lambda-byte-func obj)))
|
|
|
|
|
(let* ((byte-func (byte-to-native-lambda-byte-func obj))
|
|
|
|
|
(lap (byte-to-native-lambda-lap obj))
|
|
|
|
|
(top-l-form (cl-loop
|
|
|
|
|
for form in (comp-ctxt-top-level-forms comp-ctxt)
|
|
|
|
|
when (and (byte-to-native-func-def-p form)
|
|
|
|
|
(eq (byte-to-native-func-def-byte-func form)
|
|
|
|
|
byte-func))
|
|
|
|
|
return form))
|
|
|
|
|
(name (when top-l-form
|
2020-05-15 10:43:31 +00:00
|
|
|
|
(byte-to-native-func-def-name top-l-form))))
|
|
|
|
|
;; Do not refuse to compile if a dynamic byte-compiled lambda
|
|
|
|
|
;; leaks here (advice).
|
|
|
|
|
(when (or name (comp-lex-byte-func-p byte-func))
|
|
|
|
|
(let* ((c-name (comp-c-func-name (or name "anonymous-lambda") "F"))
|
|
|
|
|
(func (make-comp-func :name name
|
|
|
|
|
:byte-func byte-func
|
|
|
|
|
:doc (documentation byte-func)
|
|
|
|
|
:int-spec (interactive-form byte-func)
|
|
|
|
|
:c-name c-name
|
|
|
|
|
:args (comp-decrypt-arg-list (aref byte-func 0)
|
|
|
|
|
name)
|
|
|
|
|
:lap lap
|
|
|
|
|
:frame-size (comp-byte-frame-size byte-func))))
|
|
|
|
|
;; Store the c-name to have it retrivable from
|
|
|
|
|
;; `comp-ctxt-top-level-forms'.
|
|
|
|
|
(when top-l-form
|
|
|
|
|
(setf (byte-to-native-func-def-c-name top-l-form) c-name))
|
|
|
|
|
(unless name
|
|
|
|
|
(puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt)))
|
|
|
|
|
;; Create the default array.
|
|
|
|
|
(puthash 0 (comp-func-frame-size func) (comp-func-array-h func))
|
|
|
|
|
(comp-add-func-to-ctxt func)
|
|
|
|
|
(comp-log (format "Function %s:\n" name) 1)
|
|
|
|
|
(comp-log lap 1))))))
|
2020-05-03 14:11:07 +00:00
|
|
|
|
|
2019-11-23 16:03:08 +00:00
|
|
|
|
(cl-defgeneric comp-spill-lap-function ((filename string))
|
2019-09-07 09:17:02 +00:00
|
|
|
|
"Byte compile FILENAME spilling data from the byte compiler."
|
|
|
|
|
(byte-compile-file filename)
|
2019-11-13 20:25:00 +00:00
|
|
|
|
(unless byte-to-native-top-level-forms
|
2019-12-29 14:56:49 +00:00
|
|
|
|
(signal 'native-compiler-error-empty-byte filename))
|
2019-12-29 19:12:17 +00:00
|
|
|
|
(setf (comp-ctxt-top-level-forms comp-ctxt)
|
|
|
|
|
(reverse byte-to-native-top-level-forms))
|
2020-05-03 14:11:07 +00:00
|
|
|
|
(maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))
|
2019-09-07 09:17:02 +00:00
|
|
|
|
|
2019-09-07 06:18:08 +00:00
|
|
|
|
(defun comp-spill-lap (input)
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Byte compile and spill the LAP representation for INPUT.
|
2019-09-07 06:18:08 +00:00
|
|
|
|
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."
|
2019-09-06 17:33:16 +00:00
|
|
|
|
(let ((byte-native-compiling t)
|
2020-05-01 16:32:39 +00:00
|
|
|
|
(byte-to-native-lambdas-h (make-hash-table :test #'eq))
|
2019-09-07 14:35:07 +00:00
|
|
|
|
(byte-to-native-top-level-forms ()))
|
2019-11-23 16:03:08 +00:00
|
|
|
|
(comp-spill-lap-function input)))
|
2019-07-08 05:56:37 +00:00
|
|
|
|
|
2019-07-21 13:20:39 +00:00
|
|
|
|
|
|
|
|
|
;;; Limplification pass specific code.
|
|
|
|
|
|
2019-10-05 15:08:48 +00:00
|
|
|
|
(cl-defstruct (comp-limplify (:copier nil))
|
|
|
|
|
"Support structure used during function limplification."
|
|
|
|
|
(frame nil :type vector
|
|
|
|
|
:documentation "Meta-stack used to flat LAP.")
|
2019-10-13 08:36:22 +00:00
|
|
|
|
(curr-block nil :type comp-block
|
2019-11-22 18:15:12 +00:00
|
|
|
|
:documentation "Current block being limplified.")
|
2019-10-20 07:32:57 +00:00
|
|
|
|
(sp -1 :type number
|
|
|
|
|
:documentation "Current stack pointer while walking LAP.
|
|
|
|
|
Points to the next slot to be filled.")
|
2019-10-13 08:36:22 +00:00
|
|
|
|
(pc 0 :type number
|
|
|
|
|
:documentation "Current program counter while walking LAP.")
|
2019-10-13 15:41:26 +00:00
|
|
|
|
(label-to-addr nil :type hash-table
|
|
|
|
|
:documentation "LAP hash table -> address.")
|
2019-10-13 08:36:22 +00:00
|
|
|
|
(pending-blocks () :type list
|
2020-02-21 14:28:05 +00:00
|
|
|
|
:documentation "List of blocks waiting for limplification."))
|
2019-10-13 08:36:22 +00:00
|
|
|
|
|
|
|
|
|
(defconst comp-lap-eob-ops
|
|
|
|
|
'(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop
|
2019-10-19 14:31:02 +00:00
|
|
|
|
byte-goto-if-not-nil-else-pop byte-return byte-pushcatch
|
2019-10-20 08:39:59 +00:00
|
|
|
|
byte-switch byte-pushconditioncase)
|
2019-10-13 08:36:22 +00:00
|
|
|
|
"LAP end of basic blocks op codes.")
|
|
|
|
|
|
|
|
|
|
(defsubst comp-lap-eob-p (inst)
|
|
|
|
|
"Return t if INST closes the current basic blocks, nil otherwise."
|
2020-01-20 19:30:24 +00:00
|
|
|
|
(when (memq (car inst) comp-lap-eob-ops)
|
2019-10-13 08:36:22 +00:00
|
|
|
|
t))
|
2019-10-05 15:08:48 +00:00
|
|
|
|
|
2019-10-19 09:20:15 +00:00
|
|
|
|
(defsubst comp-lap-fall-through-p (inst)
|
2019-10-19 14:31:02 +00:00
|
|
|
|
"Return t if INST fall through, nil otherwise."
|
2020-01-20 19:30:24 +00:00
|
|
|
|
(when (not (memq (car inst) '(byte-goto byte-return)))
|
2019-10-19 09:20:15 +00:00
|
|
|
|
t))
|
|
|
|
|
|
2019-10-05 15:08:48 +00:00
|
|
|
|
(defsubst comp-sp ()
|
2019-09-18 22:07:10 +00:00
|
|
|
|
"Current stack pointer."
|
2019-10-05 15:08:48 +00:00
|
|
|
|
(comp-limplify-sp comp-pass))
|
|
|
|
|
(gv-define-setter comp-sp (value)
|
|
|
|
|
`(setf (comp-limplify-sp comp-pass) ,value))
|
2019-09-18 22:07:10 +00:00
|
|
|
|
|
|
|
|
|
(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))))
|
|
|
|
|
|
2019-10-05 15:08:48 +00:00
|
|
|
|
(defsubst comp-slot-n (n)
|
2019-09-18 22:07:10 +00:00
|
|
|
|
"Slot N into the meta-stack."
|
2019-10-05 15:08:48 +00:00
|
|
|
|
(aref (comp-limplify-frame comp-pass) n))
|
2019-09-18 22:07:10 +00:00
|
|
|
|
|
2019-10-05 15:08:48 +00:00
|
|
|
|
(defsubst comp-slot ()
|
2019-09-18 22:07:10 +00:00
|
|
|
|
"Current slot into the meta-stack pointed by sp."
|
2019-10-05 15:08:48 +00:00
|
|
|
|
(comp-slot-n (comp-sp)))
|
2019-09-18 22:07:10 +00:00
|
|
|
|
|
2019-10-05 15:08:48 +00:00
|
|
|
|
(defsubst comp-slot+1 ()
|
2019-09-18 22:07:10 +00:00
|
|
|
|
"Slot into the meta-stack pointed by sp + 1."
|
2019-10-05 15:08:48 +00:00
|
|
|
|
(comp-slot-n (1+ (comp-sp))))
|
2019-07-08 09:37:17 +00:00
|
|
|
|
|
2019-10-13 16:58:46 +00:00
|
|
|
|
(defsubst comp-label-to-addr (label)
|
|
|
|
|
"Find the address of LABEL."
|
|
|
|
|
(or (gethash label (comp-limplify-label-to-addr comp-pass))
|
2019-11-21 15:09:30 +00:00
|
|
|
|
(signal 'native-ice (list "label not found" label))))
|
2019-10-13 16:58:46 +00:00
|
|
|
|
|
2019-11-10 16:02:55 +00:00
|
|
|
|
(defsubst comp-mark-curr-bb-closed ()
|
|
|
|
|
"Mark the current basic block as closed."
|
|
|
|
|
(setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t))
|
|
|
|
|
|
2019-11-01 14:28:17 +00:00
|
|
|
|
(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
|
2019-11-21 15:09:30 +00:00
|
|
|
|
(unless (or (null sp) (= sp (comp-block-sp bb)))
|
|
|
|
|
(signal 'native-ice (list "incoherent stack pointers"
|
|
|
|
|
sp (comp-block-sp bb))))
|
2019-11-01 14:28:17 +00:00
|
|
|
|
bb)
|
|
|
|
|
(car (push (make--comp-block lap-addr sp (comp-new-block-sym))
|
2019-10-20 19:00:17 +00:00
|
|
|
|
(comp-limplify-pending-blocks comp-pass))))))
|
2019-10-13 08:36:22 +00:00
|
|
|
|
|
2019-12-15 14:31:03 +00:00
|
|
|
|
(defsubst comp-call (func &rest args)
|
2019-08-21 10:17:56 +00:00
|
|
|
|
"Emit a call for function FUNC with ARGS."
|
2019-08-21 19:20:27 +00:00
|
|
|
|
`(call ,func ,@args))
|
2019-08-19 15:59:20 +00:00
|
|
|
|
|
2019-11-16 14:24:35 +00:00
|
|
|
|
(defun comp-callref (func nargs stack-off)
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Emit a call using narg abi for FUNC.
|
2019-11-16 14:24:35 +00:00
|
|
|
|
NARGS is the number of arguments.
|
|
|
|
|
STACK-OFF is the index of the first slot frame involved."
|
|
|
|
|
`(callref ,func ,@(cl-loop repeat nargs
|
|
|
|
|
for sp from stack-off
|
2019-09-15 13:41:42 +00:00
|
|
|
|
collect (comp-slot-n sp))))
|
2019-08-19 15:59:20 +00:00
|
|
|
|
|
2020-02-21 14:28:05 +00:00
|
|
|
|
(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type)
|
2019-09-14 16:12:16 +00:00
|
|
|
|
(when const-vld
|
2020-02-21 14:28:05 +00:00
|
|
|
|
(comp-add-const-to-relocs constant))
|
2019-09-14 16:12:16 +00:00
|
|
|
|
(make--comp-mvar :slot slot :const-vld const-vld :constant constant
|
2020-02-29 15:53:42 +00:00
|
|
|
|
:type type))
|
2019-09-14 16:12:16 +00:00
|
|
|
|
|
2019-09-15 10:08:22 +00:00
|
|
|
|
(defun comp-new-frame (size &optional ssa)
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Return a clean frame of meta variables of size SIZE.
|
|
|
|
|
If SSA non nil populate it of m-var in ssa form."
|
2019-09-11 19:56:26 +00:00
|
|
|
|
(cl-loop with v = (make-vector size nil)
|
|
|
|
|
for i below size
|
2019-10-24 20:20:38 +00:00
|
|
|
|
for mvar = (if ssa
|
|
|
|
|
(make-comp-ssa-mvar :slot i)
|
|
|
|
|
(make-comp-mvar :slot i))
|
2019-09-15 10:08:22 +00:00
|
|
|
|
do (aset v i mvar)
|
2019-11-02 13:34:31 +00:00
|
|
|
|
finally return v))
|
2019-07-08 07:06:58 +00:00
|
|
|
|
|
2019-10-21 09:30:39 +00:00
|
|
|
|
(defsubst comp-emit (insn)
|
|
|
|
|
"Emit INSN into basic block BB."
|
|
|
|
|
(let ((bb (comp-limplify-curr-block comp-pass)))
|
2019-10-20 19:00:17 +00:00
|
|
|
|
(cl-assert (not (comp-block-closed bb)))
|
|
|
|
|
(push insn (comp-block-insns bb))))
|
2019-07-13 14:34:59 +00:00
|
|
|
|
|
2019-10-24 20:20:38 +00:00
|
|
|
|
(defsubst comp-emit-set-call (call)
|
2019-07-13 15:08:15 +00:00
|
|
|
|
"Emit CALL assigning the result the the current slot frame.
|
2019-08-11 17:03:06 +00:00
|
|
|
|
If the callee function is known to have a return type propagate it."
|
2019-07-13 09:33:15 +00:00
|
|
|
|
(cl-assert call)
|
2019-07-13 14:34:59 +00:00
|
|
|
|
(comp-emit (list 'set (comp-slot) call)))
|
2019-07-13 09:33:15 +00:00
|
|
|
|
|
2019-07-20 17:26:30 +00:00
|
|
|
|
(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."
|
2019-11-21 15:09:30 +00:00
|
|
|
|
(comp-with-sp (or dst-n (comp-sp))
|
2019-07-20 17:26:30 +00:00
|
|
|
|
(let ((src-slot (comp-slot-n src-n)))
|
|
|
|
|
(cl-assert src-slot)
|
2019-09-14 10:39:53 +00:00
|
|
|
|
(comp-emit `(set ,(comp-slot) ,src-slot)))))
|
2019-07-08 07:06:58 +00:00
|
|
|
|
|
2019-10-24 20:20:38 +00:00
|
|
|
|
(defsubst comp-emit-annotation (str)
|
2019-07-10 16:55:19 +00:00
|
|
|
|
"Emit annotation STR."
|
2019-07-13 14:34:59 +00:00
|
|
|
|
(comp-emit `(comment ,str)))
|
2019-07-10 16:55:19 +00:00
|
|
|
|
|
2020-02-29 15:53:42 +00:00
|
|
|
|
(defsubst comp-emit-setimm (val)
|
2019-07-13 16:28:00 +00:00
|
|
|
|
"Set constant VAL to current slot."
|
2020-02-29 15:53:42 +00:00
|
|
|
|
(comp-add-const-to-relocs val)
|
|
|
|
|
;; Leave relocation index nil on purpose, will be fixed-up in final
|
|
|
|
|
;; by `comp-finalize-relocs'.
|
2020-03-01 14:42:41 +00:00
|
|
|
|
(comp-emit `(setimm ,(comp-slot) ,val)))
|
2019-07-08 15:04:33 +00:00
|
|
|
|
|
2019-10-19 14:31:02 +00:00
|
|
|
|
(defun comp-make-curr-block (block-name entry-sp &optional addr)
|
2019-10-13 08:36:22 +00:00
|
|
|
|
"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."
|
2019-11-01 14:28:17 +00:00
|
|
|
|
(let ((bb (make--comp-block addr entry-sp block-name)))
|
2019-11-22 18:20:05 +00:00
|
|
|
|
(setf (comp-limplify-curr-block comp-pass) bb
|
|
|
|
|
(comp-limplify-pc comp-pass) addr
|
|
|
|
|
(comp-limplify-sp comp-pass) (comp-block-sp bb))
|
2019-10-13 08:36:22 +00:00
|
|
|
|
(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."
|
2019-10-13 18:45:14 +00:00
|
|
|
|
(cl-destructuring-bind (label-num . stack-depth) lap-label
|
2019-10-24 20:13:29 +00:00
|
|
|
|
(when stack-depth
|
|
|
|
|
(cl-assert (= (1- stack-depth) (comp-sp))))
|
2019-11-01 14:28:17 +00:00
|
|
|
|
(let ((target (comp-bb-maybe-add (comp-label-to-addr label-num)
|
|
|
|
|
(comp-sp))))
|
|
|
|
|
(comp-emit `(jump ,(comp-block-name target)))
|
2019-11-10 16:02:55 +00:00
|
|
|
|
(comp-mark-curr-bb-closed))))
|
2019-07-14 16:36:57 +00:00
|
|
|
|
|
2019-08-03 15:08:55 +00:00
|
|
|
|
(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.
|
2019-07-21 07:48:52 +00:00
|
|
|
|
TARGET-OFFSET is the positive offset on the SP when branching to the target
|
|
|
|
|
block.
|
2019-10-19 14:31:02 +00:00
|
|
|
|
If NEGATED non null negate the tested condition.
|
|
|
|
|
Return value is the fall through block name."
|
2019-10-20 08:39:59 +00:00
|
|
|
|
(cl-destructuring-bind (label-num . label-sp) lap-label
|
2019-11-01 14:28:17 +00:00
|
|
|
|
(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))))
|
2019-10-20 12:42:06 +00:00
|
|
|
|
(when label-sp
|
|
|
|
|
(cl-assert (= (1- label-sp) (+ target-offset (comp-sp)))))
|
2019-10-13 18:45:14 +00:00
|
|
|
|
(comp-emit (if negated
|
|
|
|
|
(list 'cond-jump a b target bb)
|
2019-10-19 14:31:02 +00:00
|
|
|
|
(list 'cond-jump a b bb target)))
|
2019-11-10 16:02:55 +00:00
|
|
|
|
(comp-mark-curr-bb-closed)
|
2019-10-19 14:31:02 +00:00
|
|
|
|
bb)))
|
2019-10-13 18:45:14 +00:00
|
|
|
|
|
|
|
|
|
(defun comp-emit-handler (lap-label handler-type)
|
|
|
|
|
"Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE."
|
2019-10-20 08:39:59 +00:00
|
|
|
|
(cl-destructuring-bind (label-num . label-sp) lap-label
|
2019-10-20 19:00:17 +00:00
|
|
|
|
(cl-assert (= (- label-sp 2) (comp-sp)))
|
2019-12-28 10:39:29 +00:00
|
|
|
|
(setf (comp-func-has-non-local comp-func) t)
|
2019-11-01 14:28:17 +00:00
|
|
|
|
(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)
|
2019-11-10 16:02:55 +00:00
|
|
|
|
(1+ (comp-sp))))
|
|
|
|
|
(pop-bb (make--comp-block nil (comp-sp) (comp-new-block-sym))))
|
2019-10-13 18:45:14 +00:00
|
|
|
|
(comp-emit (list 'push-handler
|
|
|
|
|
handler-type
|
2019-10-20 19:00:17 +00:00
|
|
|
|
(comp-slot+1)
|
2019-11-10 16:02:55 +00:00
|
|
|
|
(comp-block-name pop-bb)
|
2019-11-01 14:28:17 +00:00
|
|
|
|
(comp-block-name guarded-bb)))
|
2019-11-10 16:02:55 +00:00
|
|
|
|
(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))))
|
2019-07-14 12:39:29 +00:00
|
|
|
|
|
2019-07-08 07:15:09 +00:00
|
|
|
|
(defun comp-limplify-listn (n)
|
2019-07-08 07:29:13 +00:00
|
|
|
|
"Limplify list N."
|
2019-08-03 17:42:57 +00:00
|
|
|
|
(comp-with-sp (+ (comp-sp) n -1)
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(comp-emit-set-call (comp-call 'cons
|
2019-08-19 15:59:20 +00:00
|
|
|
|
(comp-slot)
|
|
|
|
|
(make-comp-mvar :constant nil))))
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp)
|
|
|
|
|
do (comp-with-sp sp
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(comp-emit-set-call (comp-call 'cons
|
2019-08-19 15:59:20 +00:00
|
|
|
|
(comp-slot)
|
2019-09-08 14:57:40 +00:00
|
|
|
|
(comp-slot+1))))))
|
2019-07-14 07:53:06 +00:00
|
|
|
|
|
2019-07-14 12:39:29 +00:00
|
|
|
|
(defun comp-new-block-sym ()
|
2019-09-22 07:59:14 +00:00
|
|
|
|
"Return a unique symbol naming the next new basic block."
|
|
|
|
|
(intern (format "bb_%s" (funcall (comp-func-block-cnt-gen comp-func)))))
|
2019-07-14 12:39:29 +00:00
|
|
|
|
|
2019-10-13 15:41:26 +00:00
|
|
|
|
(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
|
2019-10-13 16:58:46 +00:00
|
|
|
|
(`(TAG ,label . ,_)
|
2019-10-13 15:41:26 +00:00
|
|
|
|
(puthash label addr (comp-limplify-label-to-addr comp-pass))))))
|
|
|
|
|
|
2020-05-07 07:10:50 +00:00
|
|
|
|
(defun comp-jump-table-optimizable (jmp-table)
|
|
|
|
|
"Return t if JMP-TABLE can be optimized out."
|
|
|
|
|
(cl-loop
|
|
|
|
|
with labels = (cl-loop for target-label being each hash-value of jmp-table
|
|
|
|
|
collect target-label)
|
|
|
|
|
with x = (car labels)
|
|
|
|
|
for l in (cdr-safe labels)
|
|
|
|
|
unless (= l x)
|
|
|
|
|
return nil
|
|
|
|
|
finally return t))
|
|
|
|
|
|
2019-09-16 17:47:49 +00:00
|
|
|
|
(defun comp-emit-switch (var last-insn)
|
|
|
|
|
"Emit a limple for a lap jump table given VAR and LAST-INSN."
|
2019-11-22 18:15:12 +00:00
|
|
|
|
;; FIXME this not efficient for big jump tables. We should have a second
|
2019-11-17 23:05:55 +00:00
|
|
|
|
;; strategy for this case.
|
2019-09-16 17:47:49 +00:00
|
|
|
|
(pcase last-insn
|
2020-03-01 14:42:41 +00:00
|
|
|
|
(`(setimm ,_ ,jmp-table)
|
2020-05-07 07:10:50 +00:00
|
|
|
|
(unless (comp-jump-table-optimizable 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
|
2019-11-17 23:05:55 +00:00
|
|
|
|
;; Store the result of the comparison into the scratch slot before
|
|
|
|
|
;; emitting the conditional jump.
|
2020-05-07 07:10:50 +00:00
|
|
|
|
do (comp-emit (list 'set (make-comp-mvar :slot 'scratch)
|
|
|
|
|
(comp-call test-func var m-test)))
|
|
|
|
|
(comp-emit (list 'cond-jump
|
|
|
|
|
(make-comp-mvar :slot 'scratch)
|
|
|
|
|
(make-comp-mvar :constant nil)
|
|
|
|
|
target-name ff-bb-name))
|
|
|
|
|
unless last
|
|
|
|
|
;; All fall through are artificially created here except the last one.
|
|
|
|
|
do (puthash ff-bb-name ff-bb (comp-func-blocks comp-func))
|
|
|
|
|
(setf (comp-limplify-curr-block comp-pass) ff-bb))))
|
2019-11-21 15:09:30 +00:00
|
|
|
|
(_ (signal 'native-ice
|
|
|
|
|
"missing previous setimm while creating a switch"))))
|
2019-08-03 15:08:55 +00:00
|
|
|
|
|
2019-10-05 14:20:57 +00:00
|
|
|
|
(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))))
|
2019-11-21 15:09:30 +00:00
|
|
|
|
(unless (subrp subr)
|
|
|
|
|
(signal 'native-ice (list "not a subr" subr)))
|
2019-10-05 14:20:57 +00:00
|
|
|
|
(let* ((arity (subr-arity subr))
|
|
|
|
|
(minarg (car arity))
|
|
|
|
|
(maxarg (cdr arity)))
|
2019-11-21 15:09:30 +00:00
|
|
|
|
(when (eq maxarg 'unevalled)
|
|
|
|
|
(signal 'native-ice (list "subr contains unevalled args" subr-name)))
|
2019-10-05 14:20:57 +00:00
|
|
|
|
(if (eq maxarg 'many)
|
|
|
|
|
;; callref case.
|
|
|
|
|
(comp-emit-set-call (comp-callref subr-name nargs (comp-sp)))
|
|
|
|
|
;; Normal call.
|
2019-11-21 15:09:30 +00:00
|
|
|
|
(unless (and (>= maxarg nargs) (<= minarg nargs))
|
|
|
|
|
(signal 'native-ice
|
|
|
|
|
(list "incoherent stack adjustment" nargs maxarg minarg)))
|
2019-10-05 14:20:57 +00:00
|
|
|
|
(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.
|
2019-11-22 18:15:12 +00:00
|
|
|
|
When BODY is auto guess function name form the LAP byte-code
|
|
|
|
|
name. Otherwise expect lname fnname."
|
2019-10-05 14:20:57 +00:00
|
|
|
|
(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))))
|
|
|
|
|
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(defmacro comp-op-case (&rest cases)
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Expand CASES into the corresponding `pcase' expansion.
|
2019-07-14 19:02:01 +00:00
|
|
|
|
This is responsible for generating the proper stack adjustment when known and
|
|
|
|
|
the annotation emission."
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(declare (debug (body))
|
|
|
|
|
(indent defun))
|
2019-10-05 14:20:57 +00:00
|
|
|
|
`(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)))
|
2019-10-19 16:15:00 +00:00
|
|
|
|
`(cl-incf (comp-sp) ,sp-delta))
|
2019-10-05 14:20:57 +00:00
|
|
|
|
,@(comp-body-eff body op-name sp-delta))
|
|
|
|
|
else
|
2019-11-21 15:09:30 +00:00
|
|
|
|
collect `(',op (signal 'native-ice
|
|
|
|
|
(list "unsupported LAP op" ',op-name))))
|
|
|
|
|
(_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op))))))
|
2019-07-08 07:15:09 +00:00
|
|
|
|
|
2019-07-22 09:08:53 +00:00
|
|
|
|
(defun comp-limplify-lap-inst (insn)
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Limplify LAP instruction INSN pushing it in the proper basic block."
|
2019-07-22 09:08:53 +00:00
|
|
|
|
(let ((op (car insn))
|
|
|
|
|
(arg (if (consp (cdr insn))
|
|
|
|
|
(cadr insn)
|
|
|
|
|
(cdr insn))))
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(comp-op-case
|
2019-07-14 12:39:29 +00:00
|
|
|
|
(TAG
|
2019-10-24 20:19:14 +00:00
|
|
|
|
(cl-destructuring-bind (_TAG label-num . label-sp) insn
|
2019-10-20 12:42:06 +00:00
|
|
|
|
;; Paranoid?
|
|
|
|
|
(when label-sp
|
2019-10-24 20:19:14 +00:00
|
|
|
|
(cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass))))
|
|
|
|
|
(comp-emit-annotation (format "LAP TAG %d" label-num))))
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(byte-stack-ref
|
2019-07-20 17:26:30 +00:00
|
|
|
|
(comp-copy-slot (- (comp-sp) arg 1)))
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(byte-varref
|
2019-09-02 16:08:59 +00:00
|
|
|
|
(comp-emit-set-call (comp-call 'symbol-value (make-comp-mvar
|
2019-08-19 16:22:26 +00:00
|
|
|
|
:constant arg))))
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(byte-varset
|
2019-08-19 15:59:20 +00:00
|
|
|
|
(comp-emit (comp-call 'set_internal
|
|
|
|
|
(make-comp-mvar :constant arg)
|
2019-09-08 14:57:40 +00:00
|
|
|
|
(comp-slot+1))))
|
2019-08-11 12:41:35 +00:00
|
|
|
|
(byte-varbind ;; Verify
|
2019-08-19 15:59:20 +00:00
|
|
|
|
(comp-emit (comp-call 'specbind
|
|
|
|
|
(make-comp-mvar :constant arg)
|
2019-09-08 14:57:40 +00:00
|
|
|
|
(comp-slot+1))))
|
2019-07-14 09:15:18 +00:00
|
|
|
|
(byte-call
|
2019-10-19 16:15:00 +00:00
|
|
|
|
(cl-incf (comp-sp) (- arg))
|
2019-09-18 09:55:25 +00:00
|
|
|
|
(comp-emit-set-call (comp-callref 'funcall (1+ arg) (comp-sp))))
|
2019-07-14 19:26:20 +00:00
|
|
|
|
(byte-unbind
|
2019-08-19 15:59:20 +00:00
|
|
|
|
(comp-emit (comp-call 'helper_unbind_n
|
|
|
|
|
(make-comp-mvar :constant arg))))
|
2019-07-21 09:38:26 +00:00
|
|
|
|
(byte-pophandler
|
|
|
|
|
(comp-emit '(pop-handler)))
|
|
|
|
|
(byte-pushconditioncase
|
2019-10-13 18:45:14 +00:00
|
|
|
|
(comp-emit-handler (cddr insn) 'condition-case))
|
2019-07-22 09:08:53 +00:00
|
|
|
|
(byte-pushcatch
|
2019-10-13 18:45:14 +00:00
|
|
|
|
(comp-emit-handler (cddr insn) 'catcher))
|
2019-07-14 22:58:03 +00:00
|
|
|
|
(byte-nth auto)
|
|
|
|
|
(byte-symbolp auto)
|
|
|
|
|
(byte-consp auto)
|
2019-07-14 21:35:04 +00:00
|
|
|
|
(byte-stringp auto)
|
|
|
|
|
(byte-listp auto)
|
|
|
|
|
(byte-eq auto)
|
|
|
|
|
(byte-memq auto)
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(byte-not null)
|
2019-07-14 21:35:04 +00:00
|
|
|
|
(byte-car auto)
|
|
|
|
|
(byte-cdr auto)
|
|
|
|
|
(byte-cons auto)
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(byte-list1
|
|
|
|
|
(comp-limplify-listn 1))
|
|
|
|
|
(byte-list2
|
|
|
|
|
(comp-limplify-listn 2))
|
|
|
|
|
(byte-list3
|
|
|
|
|
(comp-limplify-listn 3))
|
|
|
|
|
(byte-list4
|
|
|
|
|
(comp-limplify-listn 4))
|
2019-07-14 21:35:04 +00:00
|
|
|
|
(byte-length auto)
|
|
|
|
|
(byte-aref auto)
|
|
|
|
|
(byte-aset auto)
|
|
|
|
|
(byte-symbol-value auto)
|
2019-07-14 22:58:03 +00:00
|
|
|
|
(byte-symbol-function auto)
|
2019-07-14 21:35:04 +00:00
|
|
|
|
(byte-set auto)
|
|
|
|
|
(byte-fset auto)
|
|
|
|
|
(byte-get auto)
|
2019-07-20 14:34:37 +00:00
|
|
|
|
(byte-substring auto)
|
2019-07-14 08:57:46 +00:00
|
|
|
|
(byte-concat2
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(comp-emit-set-call (comp-callref 'concat 2 (comp-sp))))
|
2019-07-14 08:57:46 +00:00
|
|
|
|
(byte-concat3
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(comp-emit-set-call (comp-callref 'concat 3 (comp-sp))))
|
2019-07-14 08:57:46 +00:00
|
|
|
|
(byte-concat4
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(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 -)
|
2019-08-15 19:06:07 +00:00
|
|
|
|
(byte-negate
|
2019-08-19 15:59:20 +00:00
|
|
|
|
(comp-emit-set-call (comp-call 'negate (comp-slot))))
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(byte-plus +)
|
2019-07-20 14:34:37 +00:00
|
|
|
|
(byte-max auto)
|
|
|
|
|
(byte-min auto)
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(byte-mult *)
|
2019-07-14 22:58:03 +00:00
|
|
|
|
(byte-point auto)
|
2019-07-14 21:35:04 +00:00
|
|
|
|
(byte-goto-char auto)
|
2019-07-20 14:34:37 +00:00
|
|
|
|
(byte-insert auto)
|
2019-07-14 22:58:03 +00:00
|
|
|
|
(byte-point-max auto)
|
|
|
|
|
(byte-point-min auto)
|
2019-07-20 14:34:37 +00:00
|
|
|
|
(byte-char-after auto)
|
2019-07-14 21:35:04 +00:00
|
|
|
|
(byte-following-char auto)
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(byte-preceding-char preceding-char)
|
2019-07-14 22:58:03 +00:00
|
|
|
|
(byte-current-column auto)
|
2019-08-15 20:23:32 +00:00
|
|
|
|
(byte-indent-to
|
2019-10-27 14:55:08 +00:00
|
|
|
|
(comp-emit-set-call (comp-call 'indent-to
|
2019-08-19 15:59:20 +00:00
|
|
|
|
(comp-slot)
|
|
|
|
|
(make-comp-mvar :constant nil))))
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(byte-scan-buffer-OBSOLETE)
|
2019-07-14 22:58:03 +00:00
|
|
|
|
(byte-eolp auto)
|
|
|
|
|
(byte-eobp auto)
|
|
|
|
|
(byte-bolp auto)
|
|
|
|
|
(byte-bobp auto)
|
|
|
|
|
(byte-current-buffer auto)
|
|
|
|
|
(byte-set-buffer auto)
|
2019-08-08 15:35:25 +00:00
|
|
|
|
(byte-save-current-buffer
|
2019-08-19 15:59:20 +00:00
|
|
|
|
(comp-emit (comp-call 'record_unwind_current_buffer)))
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(byte-set-mark-OBSOLETE)
|
|
|
|
|
(byte-interactive-p-OBSOLETE)
|
2019-07-20 14:34:37 +00:00
|
|
|
|
(byte-forward-char auto)
|
|
|
|
|
(byte-forward-word auto)
|
|
|
|
|
(byte-skip-chars-forward auto)
|
|
|
|
|
(byte-skip-chars-backward auto)
|
|
|
|
|
(byte-forward-line auto)
|
2019-07-14 22:58:03 +00:00
|
|
|
|
(byte-char-syntax auto)
|
|
|
|
|
(byte-buffer-substring auto)
|
|
|
|
|
(byte-delete-region auto)
|
2019-08-11 10:37:21 +00:00
|
|
|
|
(byte-narrow-to-region
|
2019-10-27 14:55:08 +00:00
|
|
|
|
(comp-emit-set-call (comp-call 'narrow-to-region
|
2019-08-19 15:59:20 +00:00
|
|
|
|
(comp-slot)
|
2019-09-08 14:57:40 +00:00
|
|
|
|
(comp-slot+1))))
|
2019-08-11 10:37:21 +00:00
|
|
|
|
(byte-widen
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(comp-emit-set-call (comp-call 'widen)))
|
2019-07-20 14:34:37 +00:00
|
|
|
|
(byte-end-of-line auto)
|
2019-10-13 08:36:22 +00:00
|
|
|
|
(byte-constant2) ; TODO
|
|
|
|
|
;; Branches.
|
2019-07-14 12:39:29 +00:00
|
|
|
|
(byte-goto
|
2019-10-13 18:45:14 +00:00
|
|
|
|
(comp-emit-uncond-jump (cddr insn)))
|
2019-07-14 12:39:29 +00:00
|
|
|
|
(byte-goto-if-nil
|
2019-09-08 14:57:40 +00:00
|
|
|
|
(comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0
|
2019-10-13 18:45:14 +00:00
|
|
|
|
(cddr insn) nil))
|
2019-07-14 12:39:29 +00:00
|
|
|
|
(byte-goto-if-not-nil
|
2019-09-08 14:57:40 +00:00
|
|
|
|
(comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0
|
2019-10-13 18:45:14 +00:00
|
|
|
|
(cddr insn) t))
|
2019-07-14 12:39:29 +00:00
|
|
|
|
(byte-goto-if-nil-else-pop
|
2019-09-08 14:57:40 +00:00
|
|
|
|
(comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1
|
2019-10-13 18:45:14 +00:00
|
|
|
|
(cddr insn) nil))
|
2019-07-14 12:39:29 +00:00
|
|
|
|
(byte-goto-if-not-nil-else-pop
|
2019-09-08 14:57:40 +00:00
|
|
|
|
(comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1
|
2019-10-13 18:45:14 +00:00
|
|
|
|
(cddr insn) t))
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(byte-return
|
2019-10-13 08:36:22 +00:00
|
|
|
|
(comp-emit `(return ,(comp-slot+1))))
|
2019-07-14 21:35:04 +00:00
|
|
|
|
(byte-discard 'pass)
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(byte-dup
|
2019-07-20 17:26:30 +00:00
|
|
|
|
(comp-copy-slot (1- (comp-sp))))
|
2019-08-11 10:24:15 +00:00
|
|
|
|
(byte-save-excursion
|
2019-08-19 15:59:20 +00:00
|
|
|
|
(comp-emit (comp-call 'record_unwind_protect_excursion)))
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(byte-save-window-excursion-OBSOLETE)
|
2019-08-11 12:10:57 +00:00
|
|
|
|
(byte-save-restriction
|
2019-11-09 10:43:16 +00:00
|
|
|
|
(comp-emit (comp-call 'helper_save_restriction)))
|
2019-08-11 12:10:57 +00:00
|
|
|
|
(byte-catch) ;; Obsolete
|
2019-08-08 15:35:25 +00:00
|
|
|
|
(byte-unwind-protect
|
2019-09-08 14:57:40 +00:00
|
|
|
|
(comp-emit (comp-call 'helper_unwind_protect (comp-slot+1))))
|
2019-08-11 12:10:57 +00:00
|
|
|
|
(byte-condition-case) ;; Obsolete
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(byte-temp-output-buffer-setup-OBSOLETE)
|
|
|
|
|
(byte-temp-output-buffer-show-OBSOLETE)
|
2019-08-11 12:10:57 +00:00
|
|
|
|
(byte-unbind-all) ;; Obsolete
|
2019-07-20 14:34:37 +00:00
|
|
|
|
(byte-set-marker auto)
|
|
|
|
|
(byte-match-beginning auto)
|
|
|
|
|
(byte-match-end auto)
|
|
|
|
|
(byte-upcase auto)
|
|
|
|
|
(byte-downcase auto)
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(byte-string= string-equal)
|
|
|
|
|
(byte-string< string-lessp)
|
2019-07-20 14:34:37 +00:00
|
|
|
|
(byte-equal auto)
|
2019-07-14 22:58:03 +00:00
|
|
|
|
(byte-nthcdr auto)
|
|
|
|
|
(byte-elt auto)
|
|
|
|
|
(byte-member auto)
|
|
|
|
|
(byte-assq auto)
|
|
|
|
|
(byte-nreverse auto)
|
|
|
|
|
(byte-setcar auto)
|
|
|
|
|
(byte-setcdr auto)
|
2019-07-20 15:35:57 +00:00
|
|
|
|
(byte-car-safe auto)
|
|
|
|
|
(byte-cdr-safe auto)
|
2019-07-20 14:34:37 +00:00
|
|
|
|
(byte-nconc auto)
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(byte-quo /)
|
|
|
|
|
(byte-rem %)
|
2019-07-14 22:58:03 +00:00
|
|
|
|
(byte-numberp auto)
|
|
|
|
|
(byte-integerp auto)
|
2019-07-20 16:50:41 +00:00
|
|
|
|
(byte-listN
|
2019-10-19 16:15:00 +00:00
|
|
|
|
(cl-incf (comp-sp) (- 1 arg))
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(comp-emit-set-call (comp-callref 'list arg (comp-sp))))
|
2019-07-14 08:57:46 +00:00
|
|
|
|
(byte-concatN
|
2019-10-19 16:15:00 +00:00
|
|
|
|
(cl-incf (comp-sp) (- 1 arg))
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(comp-emit-set-call (comp-callref 'concat arg (comp-sp))))
|
2019-07-20 16:50:41 +00:00
|
|
|
|
(byte-insertN
|
2019-10-19 16:15:00 +00:00
|
|
|
|
(cl-incf (comp-sp) (- 1 arg))
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(comp-emit-set-call (comp-callref 'insert arg (comp-sp))))
|
2019-07-20 17:26:30 +00:00
|
|
|
|
(byte-stack-set
|
2019-11-21 15:09:30 +00:00
|
|
|
|
(comp-copy-slot (1+ (comp-sp)) (- (comp-sp) arg -1)))
|
2019-09-08 16:48:29 +00:00
|
|
|
|
(byte-stack-set2 (cl-assert nil)) ;; TODO
|
2019-07-20 17:26:30 +00:00
|
|
|
|
(byte-discardN
|
2019-10-19 16:15:00 +00:00
|
|
|
|
(cl-incf (comp-sp) (- arg)))
|
2019-08-03 15:08:55 +00:00
|
|
|
|
(byte-switch
|
2019-09-16 17:47:49 +00:00
|
|
|
|
;; Assume to follow the emission of a setimm.
|
|
|
|
|
;; This is checked into comp-emit-switch.
|
2019-10-13 08:36:22 +00:00
|
|
|
|
(comp-emit-switch (comp-slot+1)
|
|
|
|
|
(cl-second (comp-block-insns
|
|
|
|
|
(comp-limplify-curr-block comp-pass)))))
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(byte-constant
|
2020-02-29 14:12:21 +00:00
|
|
|
|
(comp-emit-setimm arg))
|
2019-07-20 16:50:41 +00:00
|
|
|
|
(byte-discardN-preserve-tos
|
2019-10-19 16:15:00 +00:00
|
|
|
|
(cl-incf (comp-sp) (- arg))
|
2019-07-20 17:26:30 +00:00
|
|
|
|
(comp-copy-slot (+ arg (comp-sp)))))))
|
2019-07-07 10:30:03 +00:00
|
|
|
|
|
2019-11-02 11:17:26 +00:00
|
|
|
|
(defun comp-emit-narg-prologue (minarg nonrest rest)
|
2019-08-11 14:44:12 +00:00
|
|
|
|
"Emit the prologue for a narg function."
|
2019-08-11 17:03:06 +00:00
|
|
|
|
(cl-loop for i below minarg
|
2019-10-14 20:08:24 +00:00
|
|
|
|
do (comp-emit `(set-args-to-local ,(comp-slot-n i)))
|
|
|
|
|
(comp-emit '(inc-args)))
|
2019-08-11 17:03:06 +00:00
|
|
|
|
(cl-loop for i from minarg below nonrest
|
2019-08-11 14:44:12 +00:00
|
|
|
|
for bb = (intern (format "entry_%s" i))
|
|
|
|
|
for fallback = (intern (format "entry_fallback_%s" i))
|
2019-10-14 20:08:24 +00:00
|
|
|
|
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))
|
2019-10-27 16:13:03 +00:00
|
|
|
|
finally (comp-emit '(jump entry_rest_args)))
|
2019-10-20 09:10:22 +00:00
|
|
|
|
(when (not (= minarg nonrest))
|
|
|
|
|
(cl-loop for i from minarg below nonrest
|
2019-10-27 16:13:03 +00:00
|
|
|
|
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))))
|
2019-10-20 09:10:22 +00:00
|
|
|
|
do (comp-with-sp i
|
2019-10-27 16:13:03 +00:00
|
|
|
|
(comp-make-curr-block bb (comp-sp))
|
2020-02-29 14:12:21 +00:00
|
|
|
|
(comp-emit-setimm nil)
|
2019-10-27 16:13:03 +00:00
|
|
|
|
(comp-emit `(jump ,next-bb)))))
|
2019-10-13 08:36:22 +00:00
|
|
|
|
(comp-make-curr-block 'entry_rest_args (comp-sp))
|
2019-11-02 11:17:26 +00:00
|
|
|
|
(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))))
|
2019-08-11 14:44:12 +00:00
|
|
|
|
|
2019-09-07 14:35:07 +00:00
|
|
|
|
(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))))
|
2019-11-09 15:56:55 +00:00
|
|
|
|
(comp-log-func func 2)
|
2019-09-07 14:35:07 +00:00
|
|
|
|
func)
|
|
|
|
|
|
2020-03-17 21:35:11 +00:00
|
|
|
|
(cl-defgeneric comp-emit-for-top-level (form for-late-load)
|
2019-11-03 14:27:57 +00:00
|
|
|
|
"Emit the limple code for top level FORM.")
|
|
|
|
|
|
2020-05-01 16:32:39 +00:00
|
|
|
|
(cl-defmethod comp-emit-for-top-level ((form byte-to-native-func-def)
|
2020-03-23 15:57:48 +00:00
|
|
|
|
for-late-load)
|
2020-05-01 16:32:39 +00:00
|
|
|
|
(let* ((name (byte-to-native-func-def-name form))
|
|
|
|
|
(c-name (byte-to-native-func-def-c-name form))
|
2020-03-28 20:56:47 +00:00
|
|
|
|
(f (gethash c-name (comp-ctxt-funcs-h comp-ctxt)))
|
2019-12-07 17:19:00 +00:00
|
|
|
|
(args (comp-func-args f)))
|
2019-11-03 14:27:57 +00:00
|
|
|
|
(cl-assert (and name f))
|
2020-03-23 15:57:48 +00:00
|
|
|
|
(comp-emit (comp-call (if for-late-load
|
|
|
|
|
'comp--late-register-subr
|
|
|
|
|
'comp--register-subr)
|
2019-11-03 14:27:57 +00:00
|
|
|
|
(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))
|
2020-03-28 20:56:47 +00:00
|
|
|
|
(make-comp-mvar :constant c-name)
|
2020-04-25 15:13:03 +00:00
|
|
|
|
(make-comp-mvar
|
|
|
|
|
:constant
|
2020-04-26 08:11:33 +00:00
|
|
|
|
(let* ((h (comp-ctxt-function-docs comp-ctxt))
|
2020-04-25 15:13:03 +00:00
|
|
|
|
(i (hash-table-count h)))
|
|
|
|
|
(puthash i (comp-func-doc f) h)
|
|
|
|
|
i))
|
2019-12-07 17:19:00 +00:00
|
|
|
|
(make-comp-mvar :constant
|
2019-12-22 08:13:46 +00:00
|
|
|
|
(comp-func-int-spec f))
|
|
|
|
|
;; This is the compilation unit it-self passed as
|
|
|
|
|
;; parameter.
|
|
|
|
|
(make-comp-mvar :slot 0)))))
|
2019-11-03 14:27:57 +00:00
|
|
|
|
|
2020-03-17 21:35:11 +00:00
|
|
|
|
(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)
|
|
|
|
|
for-late-load)
|
|
|
|
|
(unless for-late-load
|
|
|
|
|
(let ((form (byte-to-native-top-level-form form)))
|
|
|
|
|
(comp-emit (comp-call 'eval
|
|
|
|
|
(let ((comp-curr-allocation-class 'd-impure))
|
|
|
|
|
(make-comp-mvar :constant form))
|
|
|
|
|
(make-comp-mvar :constant t))))))
|
2019-11-03 14:27:57 +00:00
|
|
|
|
|
2020-05-02 16:29:11 +00:00
|
|
|
|
(defun comp-emit-lambda-for-top-level (func)
|
|
|
|
|
"Emit the creation of subrs for lambda FUNC.
|
|
|
|
|
These are stored in the reloc data array."
|
|
|
|
|
(let ((args (comp-func-args func)))
|
|
|
|
|
(let ((comp-curr-allocation-class 'd-impure))
|
|
|
|
|
(comp-add-const-to-relocs (comp-func-byte-func func)))
|
|
|
|
|
(comp-emit
|
|
|
|
|
(comp-call 'comp--register-lambda
|
|
|
|
|
;; mvar to be fixed-up when containers are
|
|
|
|
|
;; finalized.
|
|
|
|
|
(or (gethash (comp-func-byte-func func)
|
|
|
|
|
(comp-ctxt-lambda-fixups-h comp-ctxt))
|
|
|
|
|
(puthash (comp-func-byte-func func)
|
|
|
|
|
(make-comp-mvar :constant nil)
|
|
|
|
|
(comp-ctxt-lambda-fixups-h comp-ctxt)))
|
|
|
|
|
(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 (comp-func-c-name func))
|
|
|
|
|
(make-comp-mvar
|
|
|
|
|
:constant (let* ((h (comp-ctxt-function-docs comp-ctxt))
|
|
|
|
|
(i (hash-table-count h)))
|
|
|
|
|
(puthash i (comp-func-doc func) h)
|
|
|
|
|
i))
|
|
|
|
|
(make-comp-mvar :constant (comp-func-int-spec func))
|
|
|
|
|
;; This is the compilation unit it-self passed as
|
|
|
|
|
;; parameter.
|
|
|
|
|
(make-comp-mvar :slot 0)))))
|
|
|
|
|
|
2020-03-17 21:35:11 +00:00
|
|
|
|
(defun comp-limplify-top-level (for-late-load)
|
|
|
|
|
"Create a limple function to modify the global environment at load.
|
|
|
|
|
When FOR-LATE-LOAD is non nil the emitted function modifies only
|
|
|
|
|
function definition.
|
2019-12-22 08:13:46 +00:00
|
|
|
|
|
|
|
|
|
Synthesize a function called 'top_level_run' that gets one single
|
|
|
|
|
parameter (the compilation unit it-self). To define native
|
|
|
|
|
functions 'top_level_run' will call back `comp--register-subr'
|
|
|
|
|
into the C code forwarding the compilation unit."
|
2020-02-21 14:28:05 +00:00
|
|
|
|
;; Once an .eln is loaded and Emacs is dumped 'top_level_run' has no
|
|
|
|
|
;; reasons to be execute ever again. Therefore all objects can be
|
2020-03-09 17:35:07 +00:00
|
|
|
|
;; just ephemeral.
|
|
|
|
|
(let* ((comp-curr-allocation-class 'd-ephemeral)
|
2020-03-17 21:35:11 +00:00
|
|
|
|
(func (make-comp-func :name (if for-late-load
|
|
|
|
|
'late-top-level-run
|
|
|
|
|
'top-level-run)
|
|
|
|
|
:c-name (if for-late-load
|
|
|
|
|
"late_top_level_run"
|
|
|
|
|
"top_level_run")
|
2019-12-22 08:13:46 +00:00
|
|
|
|
:args (make-comp-args :min 1 :max 1)
|
|
|
|
|
:frame-size 1))
|
2019-09-07 14:35:07 +00:00
|
|
|
|
(comp-func func)
|
|
|
|
|
(comp-pass (make-comp-limplify
|
2019-11-01 14:28:17 +00:00
|
|
|
|
:curr-block (make--comp-block -1 0 'top-level)
|
2019-12-22 08:13:46 +00:00
|
|
|
|
:frame (comp-new-frame 1))))
|
2019-10-13 08:36:22 +00:00
|
|
|
|
(comp-make-curr-block 'entry (comp-sp))
|
2020-03-17 21:35:11 +00:00
|
|
|
|
(comp-emit-annotation (if for-late-load
|
|
|
|
|
"Late top level"
|
|
|
|
|
"Top level"))
|
2019-12-22 08:13:46 +00:00
|
|
|
|
;; Assign the compilation unit incoming as parameter to the slot frame 0.
|
|
|
|
|
(comp-emit `(set-par-to-local ,(comp-slot-n 0) 0))
|
2020-05-01 16:32:39 +00:00
|
|
|
|
(maphash (lambda (_ func)
|
|
|
|
|
(comp-emit-lambda-for-top-level func))
|
|
|
|
|
(comp-ctxt-byte-func-to-func-h comp-ctxt))
|
2020-03-17 21:35:11 +00:00
|
|
|
|
(mapc (lambda (x) (comp-emit-for-top-level x for-late-load))
|
|
|
|
|
(comp-ctxt-top-level-forms comp-ctxt))
|
2019-11-03 14:27:57 +00:00
|
|
|
|
(comp-emit `(return ,(make-comp-mvar :constant t)))
|
2020-02-09 15:17:21 +00:00
|
|
|
|
(puthash 0 (comp-func-frame-size func) (comp-func-array-h func))
|
2019-09-07 14:35:07 +00:00
|
|
|
|
(comp-limplify-finalize-function func)))
|
|
|
|
|
|
2019-10-13 16:58:46 +00:00
|
|
|
|
(defun comp-addr-to-bb-name (addr)
|
|
|
|
|
"Search for a block starting at ADDR into pending or limplified blocks."
|
2019-11-22 18:15:12 +00:00
|
|
|
|
;; FIXME Actually we could have another hash for this.
|
2019-10-13 16:58:46 +00:00
|
|
|
|
(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)
|
2019-11-02 13:34:31 +00:00
|
|
|
|
return (comp-block-name bb)))))
|
2019-10-13 16:58:46 +00:00
|
|
|
|
|
2019-10-13 08:36:22 +00:00
|
|
|
|
(defun comp-limplify-block (bb)
|
|
|
|
|
"Limplify basic-block BB and add it to the current function."
|
2019-11-22 18:20:05 +00:00
|
|
|
|
(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))
|
2019-10-19 14:31:02 +00:00
|
|
|
|
(puthash (comp-block-name bb) bb (comp-func-blocks comp-func))
|
|
|
|
|
(cl-loop
|
2019-10-27 15:57:29 +00:00
|
|
|
|
for inst-cell on (nthcdr (comp-limplify-pc comp-pass)
|
2019-10-19 14:31:02 +00:00
|
|
|
|
(comp-func-lap comp-func))
|
2019-10-27 15:57:29 +00:00
|
|
|
|
for inst = (car inst-cell)
|
|
|
|
|
for next-inst = (car-safe (cdr inst-cell))
|
2019-10-19 14:31:02 +00:00
|
|
|
|
do (comp-limplify-lap-inst inst)
|
|
|
|
|
(cl-incf (comp-limplify-pc comp-pass))
|
2019-10-27 15:57:29 +00:00
|
|
|
|
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)))
|
2019-11-01 14:28:17 +00:00
|
|
|
|
(next-bb (comp-block-name (comp-bb-maybe-add (comp-limplify-pc comp-pass) stack-depth))))
|
2019-10-27 15:57:29 +00:00
|
|
|
|
(unless (comp-block-closed bb)
|
|
|
|
|
(comp-emit `(jump ,next-bb))))
|
|
|
|
|
(cl-return)))
|
2019-10-19 14:31:02 +00:00
|
|
|
|
until (comp-lap-eob-p inst)))
|
2019-10-13 08:36:22 +00:00
|
|
|
|
|
2019-09-07 14:35:07 +00:00
|
|
|
|
(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)))
|
2019-11-02 11:17:26 +00:00
|
|
|
|
(args (comp-func-args func)))
|
2019-10-13 15:41:26 +00:00
|
|
|
|
(comp-fill-label-h)
|
2019-09-07 14:35:07 +00:00
|
|
|
|
;; Prologue
|
2019-10-13 08:36:22 +00:00
|
|
|
|
(comp-make-curr-block 'entry (comp-sp))
|
2019-09-07 14:35:07 +00:00
|
|
|
|
(comp-emit-annotation (concat "Lisp function: "
|
2019-11-24 14:07:54 +00:00
|
|
|
|
(symbol-name (comp-func-name func))))
|
2019-09-07 14:35:07 +00:00
|
|
|
|
(if (comp-args-p args)
|
|
|
|
|
(cl-loop for i below (comp-args-max args)
|
|
|
|
|
do (cl-incf (comp-sp))
|
2019-10-14 20:08:24 +00:00
|
|
|
|
(comp-emit `(set-par-to-local ,(comp-slot) ,i)))
|
2019-11-02 11:17:26 +00:00
|
|
|
|
(comp-emit-narg-prologue (comp-args-base-min args)
|
|
|
|
|
(comp-nargs-nonrest args)
|
|
|
|
|
(comp-nargs-rest args)))
|
2019-10-13 08:36:22 +00:00
|
|
|
|
(comp-emit '(jump bb_0))
|
2019-09-07 14:35:07 +00:00
|
|
|
|
;; Body
|
2019-11-01 14:28:17 +00:00
|
|
|
|
(comp-bb-maybe-add 0 (comp-sp))
|
2019-10-13 08:36:22 +00:00
|
|
|
|
(cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass))
|
|
|
|
|
while next-bb
|
|
|
|
|
do (comp-limplify-block next-bb))
|
2019-10-27 17:14:33 +00:00
|
|
|
|
;; 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)
|
2019-11-01 14:28:17 +00:00
|
|
|
|
when addr
|
|
|
|
|
do (cl-assert (null (gethash addr addr-h)))
|
|
|
|
|
(puthash addr t addr-h))
|
2019-09-07 14:35:07 +00:00
|
|
|
|
(comp-limplify-finalize-function func)))
|
|
|
|
|
|
2020-03-28 20:56:47 +00:00
|
|
|
|
(defun comp-limplify (_)
|
|
|
|
|
"Compute LIMPLE IR for forms in `comp-ctxt'."
|
|
|
|
|
(maphash (lambda (_ f) (comp-limplify-function f))
|
|
|
|
|
(comp-ctxt-funcs-h comp-ctxt))
|
2020-03-17 21:35:11 +00:00
|
|
|
|
(comp-add-func-to-ctxt (comp-limplify-top-level nil))
|
2020-03-17 22:24:52 +00:00
|
|
|
|
(when (comp-ctxt-with-late-load comp-ctxt)
|
|
|
|
|
(comp-add-func-to-ctxt (comp-limplify-top-level t))))
|
2019-07-07 07:23:10 +00:00
|
|
|
|
|
2019-09-11 21:13:13 +00:00
|
|
|
|
|
|
|
|
|
;;; SSA pass specific code.
|
2019-09-14 08:52:57 +00:00
|
|
|
|
;; 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.
|
2019-09-14 16:12:16 +00:00
|
|
|
|
;; Because the number of phis placed is (supposed) to be the minimum necessary
|
2019-09-14 08:52:57 +00:00
|
|
|
|
;; this form is called 'minimal SSA form'.
|
2019-11-22 18:15:12 +00:00
|
|
|
|
;; This pass should be run every time basic blocks or m-var are shuffled.
|
2019-09-13 18:56:24 +00:00
|
|
|
|
|
2020-02-29 15:53:42 +00:00
|
|
|
|
(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type)
|
2020-02-16 08:46:30 +00:00
|
|
|
|
(let ((mvar (make--comp-mvar :slot slot
|
|
|
|
|
:const-vld const-vld
|
|
|
|
|
:constant constant
|
2020-02-29 15:53:42 +00:00
|
|
|
|
:type type)))
|
2020-02-16 08:46:30 +00:00
|
|
|
|
(setf (comp-mvar-id mvar) (sxhash-eq mvar))
|
|
|
|
|
mvar))
|
2019-09-14 16:12:16 +00:00
|
|
|
|
|
2020-02-29 17:14:43 +00:00
|
|
|
|
(defun comp-clean-ssa (f)
|
|
|
|
|
"Clean-up SSA for funtion F."
|
|
|
|
|
(setf (comp-func-edges f) ())
|
|
|
|
|
(cl-loop
|
|
|
|
|
for b being each hash-value of (comp-func-blocks f)
|
|
|
|
|
do (setf (comp-block-in-edges b) ()
|
|
|
|
|
(comp-block-out-edges b) ()
|
|
|
|
|
(comp-block-dom b) nil
|
|
|
|
|
(comp-block-df b) (make-hash-table)
|
|
|
|
|
(comp-block-post-num b) nil
|
|
|
|
|
(comp-block-final-frame b) nil
|
|
|
|
|
;; Prune all phis.
|
|
|
|
|
(comp-block-insns b) (cl-loop for insn in (comp-block-insns b)
|
|
|
|
|
unless (eq 'phi (car insn))
|
|
|
|
|
collect insn))))
|
|
|
|
|
|
2019-09-13 18:56:24 +00:00
|
|
|
|
(defun comp-compute-edges ()
|
|
|
|
|
"Compute the basic block edges for the current function."
|
2019-09-14 08:52:57 +00:00
|
|
|
|
(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)))
|
2019-11-10 09:17:24 +00:00
|
|
|
|
for (op first second third forth) = last-insn
|
2019-09-21 17:13:11 +00:00
|
|
|
|
do (cl-case op
|
2019-09-14 08:52:57 +00:00
|
|
|
|
(jump
|
2019-09-16 18:11:05 +00:00
|
|
|
|
(edge-add :src bb :dst (gethash first blocks)))
|
2019-09-14 08:52:57 +00:00
|
|
|
|
(cond-jump
|
2019-09-16 18:11:05 +00:00
|
|
|
|
(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
|
2019-11-10 09:17:24 +00:00
|
|
|
|
(edge-add :src bb :dst (gethash third blocks))
|
|
|
|
|
(edge-add :src bb :dst (gethash forth blocks)))
|
2019-09-21 17:13:11 +00:00
|
|
|
|
(return)
|
|
|
|
|
(otherwise
|
2019-11-21 15:09:30 +00:00
|
|
|
|
(signal 'native-ice
|
|
|
|
|
(list "block does not end with a branch"
|
|
|
|
|
bb
|
2019-11-24 14:07:54 +00:00
|
|
|
|
(comp-func-name comp-func)))))
|
2019-11-22 18:15:55 +00:00
|
|
|
|
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))))
|
2019-09-13 18:56:24 +00:00
|
|
|
|
|
|
|
|
|
(defun comp-collect-rev-post-order (basic-block)
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Walk BASIC-BLOCK children and return their name in reversed post-order."
|
2019-09-13 18:56:24 +00:00
|
|
|
|
(let ((visited (make-hash-table))
|
|
|
|
|
(acc ()))
|
|
|
|
|
(cl-labels ((collect-rec (bb)
|
2019-09-14 08:13:38 +00:00
|
|
|
|
(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)))))
|
2019-09-13 18:56:24 +00:00
|
|
|
|
(collect-rec basic-block)
|
|
|
|
|
acc)))
|
|
|
|
|
|
|
|
|
|
(defun comp-compute-dominator-tree ()
|
|
|
|
|
"Compute immediate dominators for each basic block in current function."
|
2019-09-14 12:51:43 +00:00
|
|
|
|
;; Originally based on: "A Simple, Fast Dominance Algorithm"
|
2019-09-13 18:56:24 +00:00
|
|
|
|
;; 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)
|
2019-11-22 18:20:05 +00:00
|
|
|
|
(setf b1 (comp-block-dom b1)
|
|
|
|
|
finger1 (comp-block-post-num b1)))
|
2019-09-13 18:56:24 +00:00
|
|
|
|
(while (< finger2 finger1)
|
2019-11-22 18:20:05 +00:00
|
|
|
|
(setf b2 (comp-block-dom b2)
|
|
|
|
|
finger2 (comp-block-post-num b2))))
|
2019-09-13 18:56:24 +00:00
|
|
|
|
b1))
|
|
|
|
|
(first-processed (l)
|
|
|
|
|
(if-let ((p (cl-find-if (lambda (p) (comp-block-dom p)) l)))
|
|
|
|
|
p
|
2019-11-21 15:09:30 +00:00
|
|
|
|
(signal 'native-ice "cant't find first preprocessed"))))
|
2019-09-14 10:39:53 +00:00
|
|
|
|
|
2019-09-13 18:56:24 +00:00
|
|
|
|
(when-let ((blocks (comp-func-blocks comp-func))
|
|
|
|
|
(entry (gethash 'entry blocks))
|
2019-09-14 08:52:57 +00:00
|
|
|
|
;; No point to go on if the only bb is 'entry'.
|
2019-09-16 20:18:19 +00:00
|
|
|
|
(bb1 (gethash 'bb_1 blocks)))
|
2019-09-13 18:56:24 +00:00
|
|
|
|
(cl-loop with rev-bb-list = (comp-collect-rev-post-order entry)
|
|
|
|
|
with changed = t
|
|
|
|
|
while changed
|
|
|
|
|
initially (progn
|
2019-11-09 15:56:55 +00:00
|
|
|
|
(comp-log "Computing dominator tree...\n" 2)
|
2019-09-13 18:56:24 +00:00
|
|
|
|
(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)
|
2019-09-14 08:13:38 +00:00
|
|
|
|
for new-idom = (first-processed preds)
|
2019-09-13 18:56:24 +00:00
|
|
|
|
initially (setf changed nil)
|
2019-09-14 08:13:38 +00:00
|
|
|
|
do (cl-loop for p in (delq new-idom preds)
|
2019-09-13 18:56:24 +00:00
|
|
|
|
when (comp-block-dom p)
|
2019-11-11 20:03:48 +00:00
|
|
|
|
do (setf new-idom (intersect p new-idom)))
|
2019-09-14 08:13:38 +00:00
|
|
|
|
unless (eq (comp-block-dom b) new-idom)
|
2019-11-22 18:20:05 +00:00
|
|
|
|
do (setf (comp-block-dom b) new-idom
|
|
|
|
|
changed t))))))
|
2019-09-14 08:13:38 +00:00
|
|
|
|
|
|
|
|
|
(defun comp-compute-dominator-frontiers ()
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Compute the dominator frontier for each basic block in `comp-func'."
|
2019-09-14 12:51:43 +00:00
|
|
|
|
;; Originally based on: "A Simple, Fast Dominance Algorithm"
|
2019-09-14 08:13:38 +00:00
|
|
|
|
;; 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."
|
2019-09-13 18:56:24 +00:00
|
|
|
|
(maphash (lambda (name bb)
|
2019-09-14 08:52:57 +00:00
|
|
|
|
(let ((dom (comp-block-dom bb))
|
|
|
|
|
(df (comp-block-df bb)))
|
2019-11-09 15:56:55 +00:00
|
|
|
|
(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)))
|
2019-09-13 18:56:24 +00:00
|
|
|
|
(comp-func-blocks comp-func)))
|
2019-09-11 21:13:13 +00:00
|
|
|
|
|
2019-09-14 10:39:53 +00:00
|
|
|
|
(defun comp-place-phis ()
|
|
|
|
|
"Place phi insns into the current function."
|
2019-09-14 12:51:43 +00:00
|
|
|
|
;; Originally based on: Static Single Assignment Book
|
2019-09-14 10:39:53 +00:00
|
|
|
|
;; 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)
|
2019-12-28 10:39:29 +00:00
|
|
|
|
for op = (car insn)
|
|
|
|
|
when (or (and (comp-assign-op-p op)
|
|
|
|
|
(eql slot-n (comp-mvar-slot (cadr insn))))
|
|
|
|
|
;; fetch-handler is after a non local
|
|
|
|
|
;; therefore clobbers all frame!!!
|
|
|
|
|
(eq op 'fetch-handler))
|
2019-11-02 13:34:31 +00:00
|
|
|
|
return t)))
|
2019-09-14 10:39:53 +00:00
|
|
|
|
|
|
|
|
|
(cl-loop for i from 0 below (comp-func-frame-size comp-func)
|
|
|
|
|
;; List of blocks with a definition of mvar i
|
2019-09-16 23:01:34 +00:00
|
|
|
|
for defs-v = (cl-loop with blocks = (comp-func-blocks comp-func)
|
2019-09-14 10:39:53 +00:00
|
|
|
|
for b being each hash-value of blocks
|
|
|
|
|
when (slot-assigned-p i b)
|
|
|
|
|
collect b)
|
|
|
|
|
;; Set of basic blocks where phi is added.
|
2019-09-16 23:01:34 +00:00
|
|
|
|
for f = ()
|
2019-09-14 10:39:53 +00:00
|
|
|
|
;; Worklist, set of basic blocks that contain definitions of v.
|
2019-09-16 23:01:34 +00:00
|
|
|
|
for w = defs-v
|
2019-09-14 10:39:53 +00:00
|
|
|
|
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)
|
2019-10-14 20:08:24 +00:00
|
|
|
|
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))))))))
|
2019-09-14 10:39:53 +00:00
|
|
|
|
|
2019-09-14 15:55:03 +00:00
|
|
|
|
(defun comp-dom-tree-walker (bb pre-lambda post-lambda)
|
2019-09-14 12:51:43 +00:00
|
|
|
|
"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))
|
2019-09-14 15:00:16 +00:00
|
|
|
|
;; Current block is the immediate dominator then recur.
|
2019-09-14 15:55:03 +00:00
|
|
|
|
do (comp-dom-tree-walker child pre-lambda post-lambda)))
|
2019-09-14 12:51:43 +00:00
|
|
|
|
(when post-lambda
|
|
|
|
|
(funcall post-lambda bb)))
|
|
|
|
|
|
2019-09-14 15:00:16 +00:00
|
|
|
|
(cl-defstruct (comp-ssa (:copier nil))
|
|
|
|
|
"Support structure used while SSA renaming."
|
2019-09-15 10:07:04 +00:00
|
|
|
|
(frame (comp-new-frame (comp-func-frame-size comp-func) t) :type vector
|
2019-11-22 18:15:12 +00:00
|
|
|
|
:documentation "Vector of m-vars."))
|
2019-09-14 15:00:16 +00:00
|
|
|
|
|
2019-09-16 20:18:58 +00:00
|
|
|
|
(defun comp-ssa-rename-insn (insn frame)
|
|
|
|
|
(dotimes (slot-n (comp-func-frame-size comp-func))
|
2019-09-23 09:41:36 +00:00
|
|
|
|
(cl-flet ((targetp (x)
|
2019-09-16 20:18:58 +00:00
|
|
|
|
;; 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)))
|
2019-11-22 18:20:05 +00:00
|
|
|
|
(setf (aref frame slot-n) mvar
|
|
|
|
|
(cadr insn) mvar))))
|
2019-09-16 20:18:58 +00:00
|
|
|
|
(pcase insn
|
2019-09-23 09:41:36 +00:00
|
|
|
|
(`(,(pred comp-assign-op-p) ,(pred targetp) . ,_)
|
2019-09-16 20:18:58 +00:00
|
|
|
|
(let ((mvar (aref frame slot-n)))
|
2019-09-23 09:41:36 +00:00
|
|
|
|
(setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn))))
|
2019-09-16 20:18:58 +00:00
|
|
|
|
(new-lvalue))
|
2019-12-28 10:39:29 +00:00
|
|
|
|
(`(fetch-handler . ,_)
|
|
|
|
|
;; Clobber all no matter what!
|
|
|
|
|
(setf (aref frame slot-n) (make-comp-ssa-mvar :slot slot-n)))
|
2019-09-16 20:18:58 +00:00
|
|
|
|
(`(phi ,n)
|
|
|
|
|
(when (equal n slot-n)
|
|
|
|
|
(new-lvalue)))
|
|
|
|
|
(_
|
|
|
|
|
(let ((mvar (aref frame slot-n)))
|
2019-09-23 09:41:36 +00:00
|
|
|
|
(setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn)))))))))
|
2019-09-16 20:18:58 +00:00
|
|
|
|
|
|
|
|
|
(defun comp-ssa-rename ()
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Entry point to rename into SSA within the current function."
|
2019-11-09 15:56:55 +00:00
|
|
|
|
(comp-log "Renaming\n" 2)
|
2019-09-16 20:18:58 +00:00
|
|
|
|
(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))
|
2019-09-16 23:01:34 +00:00
|
|
|
|
(setf (comp-block-final-frame bb)
|
|
|
|
|
(copy-sequence in-frame))
|
2019-09-16 20:18:58 +00:00
|
|
|
|
(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)))))
|
2019-09-14 15:55:03 +00:00
|
|
|
|
|
|
|
|
|
(defun comp-finalize-phis ()
|
|
|
|
|
"Fixup r-values into phis in all basic blocks."
|
|
|
|
|
(cl-flet ((finalize-phi (args b)
|
2019-11-22 18:15:12 +00:00
|
|
|
|
;; Concatenate into args all incoming m-vars for this phi.
|
2019-09-14 15:55:03 +00:00
|
|
|
|
(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)
|
2019-11-11 16:46:34 +00:00
|
|
|
|
collect (aref in-frame slot-n)))))
|
2019-09-14 15:55:03 +00:00
|
|
|
|
|
|
|
|
|
(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)
|
2020-02-29 17:14:43 +00:00
|
|
|
|
do (finalize-phi args b)))))
|
2019-09-14 15:00:16 +00:00
|
|
|
|
|
2020-02-29 17:38:50 +00:00
|
|
|
|
(defun comp-ssa ()
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Port all functions into mininal SSA form."
|
2019-09-22 13:42:49 +00:00
|
|
|
|
(maphash (lambda (_ f)
|
2020-02-29 17:14:43 +00:00
|
|
|
|
(let* ((comp-func f)
|
|
|
|
|
(ssa-status (comp-func-ssa-status f)))
|
|
|
|
|
(unless (eq ssa-status t)
|
|
|
|
|
(when (eq ssa-status 'dirty)
|
|
|
|
|
(comp-clean-ssa f))
|
|
|
|
|
(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)
|
|
|
|
|
(setf (comp-func-ssa-status f) t))))
|
2019-09-22 13:42:49 +00:00
|
|
|
|
(comp-ctxt-funcs-h comp-ctxt)))
|
2019-09-15 10:31:44 +00:00
|
|
|
|
|
2019-09-15 12:43:30 +00:00
|
|
|
|
|
|
|
|
|
;;; propagate pass specific code.
|
|
|
|
|
;; A very basic propagation pass follows.
|
2019-11-22 18:15:12 +00:00
|
|
|
|
;; 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
|
2019-11-18 18:35:44 +00:00
|
|
|
|
;; possible.
|
2019-09-15 12:43:30 +00:00
|
|
|
|
|
2020-01-20 21:16:10 +00:00
|
|
|
|
(defvar comp-propagate-classes '(byte-optimize-associative-math
|
|
|
|
|
byte-optimize-binary-predicate
|
|
|
|
|
byte-optimize-concat
|
|
|
|
|
byte-optimize-equal
|
|
|
|
|
byte-optimize-identity
|
|
|
|
|
byte-optimize-member
|
|
|
|
|
byte-optimize-memq
|
|
|
|
|
byte-optimize-predicate)
|
|
|
|
|
"We optimize functions with 'byte-optimizer' property set to
|
|
|
|
|
one of these symbols. See byte-opt.el.")
|
|
|
|
|
|
2019-09-30 15:13:07 +00:00
|
|
|
|
(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)))
|
|
|
|
|
|
2019-11-09 15:22:07 +00:00
|
|
|
|
(defun comp-copy-insn (insn)
|
|
|
|
|
"Deep copy INSN."
|
2019-11-10 13:25:17 +00:00
|
|
|
|
;; 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)))
|
2019-11-22 18:20:05 +00:00
|
|
|
|
(setf newcar (comp-copy-insn (car insn))))
|
2019-11-10 13:25:17 +00:00
|
|
|
|
(push newcar result))
|
2019-11-22 18:20:05 +00:00
|
|
|
|
(setf insn (cdr insn)))
|
2019-11-10 13:25:17 +00:00
|
|
|
|
(nconc (nreverse result)
|
|
|
|
|
(if (comp-mvar-p insn) (comp-copy-insn insn) insn)))
|
|
|
|
|
(if (comp-mvar-p insn)
|
|
|
|
|
(copy-comp-mvar insn)
|
|
|
|
|
insn)))
|
2019-11-09 15:22:07 +00:00
|
|
|
|
|
2020-02-09 15:17:21 +00:00
|
|
|
|
(defun comp-ref-args-to-array (args)
|
|
|
|
|
"Given ARGS assign them to a dedicated array."
|
2020-02-14 14:54:36 +00:00
|
|
|
|
(when args
|
2020-02-09 15:17:21 +00:00
|
|
|
|
(cl-loop with array-h = (comp-func-array-h comp-func)
|
|
|
|
|
with arr-idx = (hash-table-count array-h)
|
|
|
|
|
for i from 0
|
|
|
|
|
for arg in args
|
|
|
|
|
initially
|
|
|
|
|
(puthash arr-idx (length args) array-h)
|
|
|
|
|
do
|
2020-02-14 14:54:36 +00:00
|
|
|
|
;; We are not supposed to rename arrays more then once.
|
|
|
|
|
;; This because we do only one final back propagation
|
|
|
|
|
;; and arrays are used only once.
|
|
|
|
|
|
|
|
|
|
;; Note: this last is just a property of the code generated
|
|
|
|
|
;; by the byte-compiler.
|
2020-02-09 15:17:21 +00:00
|
|
|
|
(cl-assert (= (comp-mvar-array-idx arg) 0))
|
2020-02-16 17:14:35 +00:00
|
|
|
|
(setf (comp-mvar-slot arg) i
|
|
|
|
|
(comp-mvar-array-idx arg) arr-idx))))
|
2020-02-09 15:17:21 +00:00
|
|
|
|
|
2020-02-14 14:54:36 +00:00
|
|
|
|
(defun comp-propagate-prologue (backward)
|
2020-02-09 15:17:21 +00:00
|
|
|
|
"Prologue for the propagate pass.
|
|
|
|
|
Here goes everything that can be done not iteratively (read once).
|
2020-02-14 14:54:36 +00:00
|
|
|
|
- Forward propagate immediate involed in assignments.
|
|
|
|
|
- Backward propagate array layout when BACKWARD is non nil."
|
2019-09-30 15:13:07 +00:00
|
|
|
|
(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
|
2020-02-09 15:17:21 +00:00
|
|
|
|
(`(set ,_lval (,(or 'callref 'direct-callref) ,_f . ,args))
|
2020-02-14 14:54:36 +00:00
|
|
|
|
(when backward
|
|
|
|
|
(comp-ref-args-to-array args)))
|
2020-02-09 15:17:21 +00:00
|
|
|
|
(`(,(or 'callref 'direct-callref) ,_f . ,args)
|
2020-02-14 14:54:36 +00:00
|
|
|
|
(when backward
|
|
|
|
|
(comp-ref-args-to-array args)))
|
2020-03-01 14:42:41 +00:00
|
|
|
|
(`(setimm ,lval ,v)
|
2019-11-18 18:35:44 +00:00
|
|
|
|
(setf (comp-mvar-const-vld lval) t
|
|
|
|
|
(comp-mvar-constant lval) v
|
|
|
|
|
(comp-mvar-type lval) (comp-strict-type-of v)))))))
|
2019-09-15 12:43:30 +00:00
|
|
|
|
|
2019-09-16 20:18:58 +00:00
|
|
|
|
(defsubst comp-mvar-propagate (lval rval)
|
|
|
|
|
"Propagate into LVAL properties of RVAL."
|
2019-11-18 18:35:44 +00:00
|
|
|
|
(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)))
|
|
|
|
|
|
2020-01-20 21:16:10 +00:00
|
|
|
|
;; Here should fall most of (defun byte-optimize-* equivalents.
|
|
|
|
|
(defsubst comp-function-optimizable (f args)
|
|
|
|
|
"Given function F called with ARGS return non nil when optimizable."
|
|
|
|
|
(when (cl-every #'comp-mvar-const-vld args)
|
|
|
|
|
(or (get f 'pure)
|
|
|
|
|
(memq (get f 'byte-optimizer) comp-propagate-classes)
|
|
|
|
|
(let ((values (mapcar #'comp-mvar-constant args)))
|
|
|
|
|
(pcase f
|
|
|
|
|
;; Simple integer operation.
|
|
|
|
|
;; Note: byte-opt uses `byte-opt--portable-numberp'
|
|
|
|
|
;; instead of just`fixnump'.
|
|
|
|
|
((or '+ '- '* '1+ '-1) (and (cl-every #'fixnump values)
|
|
|
|
|
(fixnump (apply f values))))
|
|
|
|
|
('/ (and (cl-every #'fixnump values)
|
|
|
|
|
(not (= (car (last values)) 0)))))))))
|
|
|
|
|
|
2020-02-09 14:12:51 +00:00
|
|
|
|
(defsubst comp-function-call-maybe-remove (insn f args)
|
2019-11-18 18:35:44 +00:00
|
|
|
|
"Given INSN when F is pure if all ARGS are known remove the function call."
|
2020-06-06 22:34:21 +00:00
|
|
|
|
(cl-flet ((rewrite-insn-as-setimm (insn value)
|
|
|
|
|
;; See `comp-emit-setimm'.
|
|
|
|
|
(comp-add-const-to-relocs value)
|
|
|
|
|
(setf (car insn) 'setimm
|
|
|
|
|
(cddr insn) `(,value))))
|
|
|
|
|
(cond
|
|
|
|
|
((eq f 'symbol-value)
|
|
|
|
|
(when-let* ((arg0 (car args))
|
|
|
|
|
(const (comp-mvar-const-vld arg0))
|
|
|
|
|
(ok-to-optim (member (comp-mvar-constant arg0)
|
|
|
|
|
comp-symbol-values-optimizable)))
|
|
|
|
|
(rewrite-insn-as-setimm insn (symbol-value (comp-mvar-constant
|
|
|
|
|
(car args))))))
|
|
|
|
|
((comp-function-optimizable f args)
|
|
|
|
|
(ignore-errors
|
|
|
|
|
;; No point to complain here because we should do basic block
|
|
|
|
|
;; pruning in order to be sure that this is not dead-code. This
|
|
|
|
|
;; is now left to gcc, to be implemented only if we want a
|
|
|
|
|
;; reliable diagnostic here.
|
|
|
|
|
(rewrite-insn-as-setimm insn
|
|
|
|
|
(apply f
|
|
|
|
|
(mapcar #'comp-mvar-constant args))))))))
|
2019-09-16 20:18:58 +00:00
|
|
|
|
|
2019-09-15 12:43:30 +00:00
|
|
|
|
(defun comp-propagate-insn (insn)
|
2019-11-09 15:22:07 +00:00
|
|
|
|
"Propagate within INSN."
|
2019-09-15 12:43:30 +00:00
|
|
|
|
(pcase insn
|
|
|
|
|
(`(set ,lval ,rval)
|
|
|
|
|
(pcase rval
|
2020-06-06 11:30:59 +00:00
|
|
|
|
(`(,(or 'call 'callref) ,f . ,args)
|
2019-09-15 12:43:30 +00:00
|
|
|
|
(setf (comp-mvar-type lval)
|
2019-11-18 18:35:44 +00:00
|
|
|
|
(alist-get f comp-known-ret-types))
|
2020-02-09 14:12:51 +00:00
|
|
|
|
(comp-function-call-maybe-remove insn f args))
|
2020-06-06 11:30:59 +00:00
|
|
|
|
(`(,(or 'direct-call 'direct-callref) ,f . ,args)
|
|
|
|
|
(let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt)))))
|
|
|
|
|
(setf (comp-mvar-type lval)
|
|
|
|
|
(alist-get f comp-known-ret-types))
|
|
|
|
|
(comp-function-call-maybe-remove insn f args)))
|
2019-09-15 12:43:30 +00:00
|
|
|
|
(_
|
|
|
|
|
(comp-mvar-propagate lval rval))))
|
|
|
|
|
(`(phi ,lval . ,rest)
|
2020-02-09 15:17:21 +00:00
|
|
|
|
;; Forward const prop here.
|
2019-11-25 20:27:11 +00:00
|
|
|
|
(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))
|
2020-02-09 15:17:21 +00:00
|
|
|
|
;; Forward type propagation.
|
2019-09-15 12:43:30 +00:00
|
|
|
|
;; FIXME: checking for type equality is not sufficient cause does not
|
2019-11-25 20:27:11 +00:00
|
|
|
|
;; 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))
|
2020-02-09 15:17:21 +00:00
|
|
|
|
;; Backward propagate array index and slot.
|
|
|
|
|
(let ((arr-idx (comp-mvar-array-idx lval)))
|
|
|
|
|
(when (> arr-idx 0)
|
|
|
|
|
(cl-loop with slot = (comp-mvar-slot lval)
|
|
|
|
|
for arg in rest
|
|
|
|
|
do
|
2020-02-16 17:14:35 +00:00
|
|
|
|
(setf (comp-mvar-array-idx arg) arr-idx
|
|
|
|
|
(comp-mvar-slot arg) slot)))))))
|
2019-09-15 12:43:30 +00:00
|
|
|
|
|
|
|
|
|
(defun comp-propagate* ()
|
2019-11-09 15:22:07 +00:00
|
|
|
|
"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)
|
2019-09-15 12:43:30 +00:00
|
|
|
|
do (cl-loop for insn in (comp-block-insns b)
|
2019-11-09 15:22:07 +00:00
|
|
|
|
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))
|
2019-11-19 19:50:18 +00:00
|
|
|
|
finally return modified))
|
2019-09-15 12:43:30 +00:00
|
|
|
|
|
2020-02-29 17:38:50 +00:00
|
|
|
|
(defun comp-propagate1 (backward)
|
|
|
|
|
(comp-ssa)
|
2019-11-25 19:33:17 +00:00
|
|
|
|
(when (>= comp-speed 2)
|
|
|
|
|
(maphash (lambda (_ f)
|
2019-12-28 12:51:46 +00:00
|
|
|
|
;; FIXME remove the following condition when tested.
|
|
|
|
|
(unless (comp-func-has-non-local f)
|
|
|
|
|
(let ((comp-func f))
|
2020-02-14 14:54:36 +00:00
|
|
|
|
(comp-propagate-prologue backward)
|
2019-12-28 12:51:46 +00:00
|
|
|
|
(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))))
|
2019-11-25 19:33:17 +00:00
|
|
|
|
(comp-ctxt-funcs-h comp-ctxt))))
|
2019-09-11 21:13:13 +00:00
|
|
|
|
|
2020-02-29 17:38:50 +00:00
|
|
|
|
(defun comp-propagate (_)
|
2020-02-14 14:54:36 +00:00
|
|
|
|
"Forward propagate types and consts within the lattice."
|
2020-02-29 17:38:50 +00:00
|
|
|
|
(comp-propagate1 nil))
|
2020-02-14 14:54:36 +00:00
|
|
|
|
|
2020-02-29 17:38:50 +00:00
|
|
|
|
(defun comp-propagate-alloc (_)
|
2020-02-14 14:54:36 +00:00
|
|
|
|
"Forward propagate types and consts within the lattice.
|
|
|
|
|
Backward propagate array placement properties."
|
2020-02-29 17:38:50 +00:00
|
|
|
|
(comp-propagate1 t))
|
2020-02-14 14:54:36 +00:00
|
|
|
|
|
2019-09-18 09:30:23 +00:00
|
|
|
|
|
|
|
|
|
;;; Call optimizer pass specific code.
|
2019-09-23 07:13:46 +00:00
|
|
|
|
;; 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.
|
2019-09-18 09:30:23 +00:00
|
|
|
|
|
2020-06-06 12:49:01 +00:00
|
|
|
|
(defun comp-func-in-unit (func)
|
|
|
|
|
"Given FUNC return the `comp-fun' definition in the current context.
|
|
|
|
|
FUNCTION can be a function-name or byte compiled function."
|
|
|
|
|
(if (symbolp func)
|
|
|
|
|
(gethash (gethash func
|
|
|
|
|
(comp-ctxt-sym-to-c-name-h comp-ctxt))
|
|
|
|
|
(comp-ctxt-funcs-h comp-ctxt))
|
|
|
|
|
(cl-assert (byte-code-function-p func))
|
|
|
|
|
(gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt))))
|
|
|
|
|
|
2020-05-18 19:51:46 +00:00
|
|
|
|
(defun comp-call-optim-form-call (callee args)
|
2019-09-18 21:25:37 +00:00
|
|
|
|
""
|
2019-09-21 09:38:40 +00:00
|
|
|
|
(cl-flet ((fill-args (args total)
|
|
|
|
|
;; Fill missing args to reach TOTAL
|
|
|
|
|
(append args (cl-loop repeat (- total (length args))
|
2020-02-09 15:17:21 +00:00
|
|
|
|
collect (make-comp-mvar :constant nil)))))
|
2020-06-06 12:49:01 +00:00
|
|
|
|
(when (and (or (symbolp callee)
|
|
|
|
|
(gethash callee (comp-ctxt-byte-func-to-func-h comp-ctxt)))
|
2020-01-20 19:30:24 +00:00
|
|
|
|
(not (memq callee comp-never-optimize-functions)))
|
2020-06-06 12:49:01 +00:00
|
|
|
|
(let* ((f (if (symbolp callee)
|
|
|
|
|
(symbol-function callee)
|
|
|
|
|
(cl-assert (byte-code-function-p callee))
|
|
|
|
|
callee))
|
2019-09-21 09:38:40 +00:00
|
|
|
|
(subrp (subrp f))
|
2020-06-06 12:49:01 +00:00
|
|
|
|
(comp-func-callee (comp-func-in-unit callee)))
|
2019-09-23 08:51:40 +00:00
|
|
|
|
(cond
|
2019-09-26 10:11:13 +00:00
|
|
|
|
((and subrp (not (subr-native-elisp-p f)))
|
2019-09-23 08:51:40 +00:00
|
|
|
|
;; Trampoline removal.
|
2019-12-29 18:16:53 +00:00
|
|
|
|
(let* ((callee (intern (subr-name f))) ; Fix aliased names.
|
|
|
|
|
(maxarg (cdr (subr-arity f)))
|
2019-09-23 08:51:40 +00:00
|
|
|
|
(call-type (if (if subrp
|
|
|
|
|
(not (numberp maxarg))
|
2020-06-06 11:30:59 +00:00
|
|
|
|
(comp-nargs-p comp-func-callee))
|
2019-09-23 08:51:40 +00:00
|
|
|
|
'callref
|
|
|
|
|
'call))
|
|
|
|
|
(args (if (eq call-type 'callref)
|
|
|
|
|
args
|
|
|
|
|
(fill-args args maxarg))))
|
2020-02-09 15:17:21 +00:00
|
|
|
|
`(,call-type ,callee ,@args)))
|
2019-09-23 08:51:40 +00:00
|
|
|
|
;; Intra compilation unit procedure call optimization.
|
2020-05-18 18:04:07 +00:00
|
|
|
|
;; Attention speed 3 triggers this for non self calls too!!
|
2020-06-06 12:49:01 +00:00
|
|
|
|
((and comp-func-callee
|
2020-06-06 14:53:34 +00:00
|
|
|
|
(or (and (>= comp-speed 3)
|
|
|
|
|
(comp-func-unique-in-cu-p callee))
|
2020-06-06 12:49:01 +00:00
|
|
|
|
(and (>= comp-speed 2)
|
|
|
|
|
;; Anonymous lambdas can't be redefined so are
|
|
|
|
|
;; always safe to optimize.
|
|
|
|
|
(byte-code-function-p callee))))
|
2020-06-06 11:30:59 +00:00
|
|
|
|
(let* ((func-args (comp-func-args comp-func-callee))
|
2019-09-23 08:51:40 +00:00
|
|
|
|
(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)))))
|
2020-06-06 11:30:59 +00:00
|
|
|
|
`(,call-type ,(comp-func-c-name comp-func-callee) ,@args)))
|
2019-09-23 09:41:36 +00:00
|
|
|
|
((comp-type-hint-p callee)
|
|
|
|
|
`(call ,callee ,@args)))))))
|
2019-09-18 21:25:37 +00:00
|
|
|
|
|
2019-09-22 13:42:49 +00:00
|
|
|
|
(defun comp-call-optim-func ()
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Perform the trampoline call optimization for the current function."
|
2019-09-18 09:30:23 +00:00
|
|
|
|
(cl-loop
|
2019-11-24 14:07:54 +00:00
|
|
|
|
with self = (comp-func-name comp-func)
|
2019-09-22 13:42:49 +00:00
|
|
|
|
for b being each hash-value of (comp-func-blocks comp-func)
|
2020-05-11 18:21:01 +00:00
|
|
|
|
when self ;; FIXME add proper anonymous lambda support.
|
2020-06-03 21:06:26 +00:00
|
|
|
|
do (comp-loop-insn-in-block b
|
|
|
|
|
(pcase insn
|
|
|
|
|
(`(set ,lval (callref funcall ,f . ,rest))
|
|
|
|
|
(when-let ((new-form (comp-call-optim-form-call
|
|
|
|
|
(comp-mvar-constant f) rest)))
|
|
|
|
|
(setf insn `(set ,lval ,new-form))))
|
|
|
|
|
(`(callref funcall ,f . ,rest)
|
|
|
|
|
(when-let ((new-form (comp-call-optim-form-call
|
|
|
|
|
(comp-mvar-constant f) rest)))
|
|
|
|
|
(setf insn new-form)))))))
|
2019-09-22 13:42:49 +00:00
|
|
|
|
|
|
|
|
|
(defun comp-call-optim (_)
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Try to optimize out funcall trampoline usage when possible."
|
2019-09-22 13:42:49 +00:00
|
|
|
|
(when (>= comp-speed 2)
|
|
|
|
|
(maphash (lambda (_ f)
|
|
|
|
|
(let ((comp-func f))
|
|
|
|
|
(comp-call-optim-func)))
|
|
|
|
|
(comp-ctxt-funcs-h comp-ctxt))))
|
2019-09-18 09:30:23 +00:00
|
|
|
|
|
2019-09-22 16:49:11 +00:00
|
|
|
|
|
|
|
|
|
;;; 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
|
2019-11-22 18:15:12 +00:00
|
|
|
|
;; in the hope of removing memory references.
|
2019-09-23 09:41:36 +00:00
|
|
|
|
;;
|
2019-09-22 16:49:11 +00:00
|
|
|
|
;; This pass can be run as last optim.
|
|
|
|
|
|
|
|
|
|
(defun comp-collect-mvar-ids (insn)
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Collect the m-var unique identifiers into INSN."
|
2019-09-22 16:49:11 +00:00
|
|
|
|
(cl-loop for x in insn
|
|
|
|
|
if (consp x)
|
2019-11-19 19:27:27 +00:00
|
|
|
|
append (comp-collect-mvar-ids x)
|
2019-09-22 16:49:11 +00:00
|
|
|
|
else
|
2019-11-19 19:27:27 +00:00
|
|
|
|
when (comp-mvar-p x)
|
|
|
|
|
collect (comp-mvar-id x)))
|
2019-09-22 16:49:11 +00:00
|
|
|
|
|
2019-09-23 09:41:36 +00:00
|
|
|
|
(defun comp-dead-assignments-func ()
|
2019-11-20 18:37:47 +00:00
|
|
|
|
"Clean-up dead assignments into current function.
|
2019-11-19 19:27:27 +00:00
|
|
|
|
Return the list of m-var ids nuked."
|
2019-09-22 16:49:11 +00:00
|
|
|
|
(let ((l-vals ())
|
|
|
|
|
(r-vals ()))
|
2019-11-22 18:15:12 +00:00
|
|
|
|
;; Collect used r and l-values.
|
2019-09-22 16:49:11 +00:00
|
|
|
|
(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)
|
2019-10-14 20:08:24 +00:00
|
|
|
|
(setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals))
|
2019-09-22 16:49:11 +00:00
|
|
|
|
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)))
|
2019-11-09 15:56:55 +00:00
|
|
|
|
(comp-log (format "Function %s\nl-vals %s\nr-vals %s\nNuking ids: %s\n"
|
2019-11-24 14:07:54 +00:00
|
|
|
|
(comp-func-name comp-func)
|
2019-11-09 15:56:55 +00:00
|
|
|
|
l-vals
|
|
|
|
|
r-vals
|
|
|
|
|
nuke-list)
|
|
|
|
|
3)
|
2019-09-22 16:49:11 +00:00
|
|
|
|
(cl-loop
|
|
|
|
|
for b being each hash-value of (comp-func-blocks comp-func)
|
2020-06-03 21:06:26 +00:00
|
|
|
|
do (comp-loop-insn-in-block b
|
|
|
|
|
(cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn
|
|
|
|
|
(when (and (comp-set-op-p op)
|
|
|
|
|
(memq (comp-mvar-id arg0) nuke-list))
|
|
|
|
|
(setf insn
|
|
|
|
|
(if (comp-limple-insn-call-p arg1)
|
|
|
|
|
arg1
|
|
|
|
|
`(comment ,(format "optimized out: %s"
|
|
|
|
|
insn))))))))
|
2019-11-19 19:27:27 +00:00
|
|
|
|
nuke-list)))
|
2019-09-22 16:49:11 +00:00
|
|
|
|
|
|
|
|
|
(defun comp-dead-code (_)
|
|
|
|
|
"Dead code elimination."
|
|
|
|
|
(when (>= comp-speed 2)
|
|
|
|
|
(maphash (lambda (_ f)
|
|
|
|
|
(let ((comp-func f))
|
2019-12-28 12:51:46 +00:00
|
|
|
|
;; FIXME remove the following condition when tested.
|
|
|
|
|
(unless (comp-func-has-non-local comp-func)
|
|
|
|
|
(cl-loop
|
|
|
|
|
for i from 1
|
|
|
|
|
while (comp-dead-assignments-func)
|
|
|
|
|
finally (comp-log (format "dead code rm run %d times\n" i) 2)
|
2020-05-25 19:27:46 +00:00
|
|
|
|
(comp-log-func comp-func 3)))))
|
2019-09-22 16:49:11 +00:00
|
|
|
|
(comp-ctxt-funcs-h comp-ctxt))))
|
|
|
|
|
|
2020-02-16 11:19:10 +00:00
|
|
|
|
|
|
|
|
|
;;; Tail Call Optimization pass specific code.
|
|
|
|
|
|
|
|
|
|
(defun comp-form-tco-call-seq (args)
|
|
|
|
|
"Generate a tco sequence for ARGS."
|
|
|
|
|
`(,@(cl-loop for arg in args
|
|
|
|
|
for i from 0
|
|
|
|
|
collect `(set ,(make-comp-mvar :slot i) ,arg))
|
|
|
|
|
(jump bb_0)))
|
|
|
|
|
|
|
|
|
|
(defun comp-tco-func ()
|
|
|
|
|
"Try to pattern match and perform TCO within the current function."
|
|
|
|
|
(cl-loop
|
|
|
|
|
for b being each hash-value of (comp-func-blocks comp-func)
|
|
|
|
|
do (cl-loop
|
|
|
|
|
named in-the-basic-block
|
|
|
|
|
for insns-seq on (comp-block-insns b)
|
|
|
|
|
do (pcase insns-seq
|
|
|
|
|
(`((set ,l-val (direct-call ,func . ,args))
|
|
|
|
|
(comment ,_comment)
|
|
|
|
|
(return ,ret-val))
|
|
|
|
|
(when (and (eq func (comp-func-name comp-func))
|
|
|
|
|
(eq l-val ret-val))
|
|
|
|
|
(let ((tco-seq (comp-form-tco-call-seq args)))
|
|
|
|
|
(setf (car insns-seq) (car tco-seq)
|
2020-02-29 17:14:43 +00:00
|
|
|
|
(cdr insns-seq) (cdr tco-seq)
|
|
|
|
|
(comp-func-ssa-status comp-func) 'dirty)
|
2020-02-16 11:19:10 +00:00
|
|
|
|
(cl-return-from in-the-basic-block))))))))
|
|
|
|
|
|
|
|
|
|
(defun comp-tco (_)
|
|
|
|
|
"Simple peephole pass performing self TCO."
|
|
|
|
|
(when (>= comp-speed 3)
|
|
|
|
|
(maphash (lambda (_ f)
|
|
|
|
|
(let ((comp-func f))
|
|
|
|
|
(unless (comp-func-has-non-local comp-func)
|
|
|
|
|
(comp-tco-func)
|
|
|
|
|
(comp-log-func comp-func 3))))
|
|
|
|
|
(comp-ctxt-funcs-h comp-ctxt))))
|
|
|
|
|
|
2020-05-25 19:27:46 +00:00
|
|
|
|
|
|
|
|
|
;;; Type hint removal pass specific code.
|
|
|
|
|
|
|
|
|
|
;; This must run after all SSA prop not to have the type hint
|
|
|
|
|
;; information overwritten.
|
|
|
|
|
|
|
|
|
|
(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)
|
2020-06-03 21:06:26 +00:00
|
|
|
|
do (comp-loop-insn-in-block b
|
|
|
|
|
(pcase insn
|
|
|
|
|
(`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val))
|
|
|
|
|
(setf insn `(set ,l-val ,r-val)))))))
|
2020-05-25 19:27:46 +00:00
|
|
|
|
|
|
|
|
|
(defun comp-remove-type-hints (_)
|
|
|
|
|
"Dead code elimination."
|
|
|
|
|
(when (>= comp-speed 2)
|
|
|
|
|
(maphash (lambda (_ f)
|
|
|
|
|
(let ((comp-func f))
|
|
|
|
|
(comp-remove-type-hints-func)
|
|
|
|
|
(comp-log-func comp-func 3)))
|
|
|
|
|
(comp-ctxt-funcs-h comp-ctxt))))
|
|
|
|
|
|
2019-08-18 15:17:56 +00:00
|
|
|
|
|
2019-09-07 06:57:07 +00:00
|
|
|
|
;;; Final pass specific code.
|
2019-08-18 15:17:56 +00:00
|
|
|
|
|
2020-02-29 15:53:42 +00:00
|
|
|
|
(defun comp-finalize-container (cont)
|
|
|
|
|
"Finalize data container CONT."
|
|
|
|
|
(setf (comp-data-container-l cont)
|
|
|
|
|
(cl-loop with h = (comp-data-container-idx cont)
|
|
|
|
|
for obj each hash-keys of h
|
|
|
|
|
for i from 0
|
|
|
|
|
do (puthash obj i h)
|
2020-05-03 19:26:35 +00:00
|
|
|
|
;; Prune byte-code objects coming from lambdas.
|
|
|
|
|
;; These are not anymore necessary as they will be
|
|
|
|
|
;; replaced at load time by native-elisp-subrs.
|
|
|
|
|
;; Note: we leave the objects in the idx hash table
|
|
|
|
|
;; to still be able to retrieve the correct index
|
|
|
|
|
;; from the corresponding m-var.
|
|
|
|
|
collect (if (gethash obj
|
|
|
|
|
(comp-ctxt-byte-func-to-func-h comp-ctxt))
|
2020-05-13 07:52:47 +00:00
|
|
|
|
'lambda-fixup
|
2020-05-03 19:26:35 +00:00
|
|
|
|
obj))))
|
2020-02-29 15:53:42 +00:00
|
|
|
|
|
|
|
|
|
(defun comp-finalize-relocs ()
|
|
|
|
|
"Finalize data containers for each relocation class.
|
|
|
|
|
Remove immediate duplicates within relocation classes.
|
|
|
|
|
Update all insn accordingly."
|
|
|
|
|
;; Symbols imported by C inlined functions. We do this here because
|
|
|
|
|
;; is better to add all objs to the relocation containers before we
|
|
|
|
|
;; compacting them.
|
|
|
|
|
(mapc #'comp-add-const-to-relocs '(nil t consp listp))
|
|
|
|
|
|
|
|
|
|
(let* ((d-default (comp-ctxt-d-default comp-ctxt))
|
|
|
|
|
(d-default-idx (comp-data-container-idx d-default))
|
|
|
|
|
(d-impure (comp-ctxt-d-impure comp-ctxt))
|
|
|
|
|
(d-impure-idx (comp-data-container-idx d-impure))
|
|
|
|
|
(d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt))
|
|
|
|
|
(d-ephemeral-idx (comp-data-container-idx d-ephemeral)))
|
2020-05-02 16:29:11 +00:00
|
|
|
|
;; We never want compiled lambdas ending up in pure space. A copy must
|
|
|
|
|
;; be already present in impure (see `comp-emit-lambda-for-top-level').
|
|
|
|
|
(cl-loop for obj being each hash-keys of d-default-idx
|
|
|
|
|
when (gethash obj (comp-ctxt-lambda-fixups-h comp-ctxt))
|
|
|
|
|
do (cl-assert (gethash obj d-impure-idx))
|
|
|
|
|
(remhash obj d-default-idx))
|
2020-04-13 19:43:21 +00:00
|
|
|
|
;; Remove entries in d-impure already present in d-default.
|
2020-02-29 15:53:42 +00:00
|
|
|
|
(cl-loop for obj being each hash-keys of d-impure-idx
|
|
|
|
|
when (gethash obj d-default-idx)
|
|
|
|
|
do (remhash obj d-impure-idx))
|
2020-04-13 19:43:21 +00:00
|
|
|
|
;; Remove entries in d-ephemeral already present in d-default or
|
2020-02-29 15:53:42 +00:00
|
|
|
|
;; d-impure.
|
|
|
|
|
(cl-loop for obj being each hash-keys of d-ephemeral-idx
|
|
|
|
|
when (or (gethash obj d-default-idx) (gethash obj d-impure-idx))
|
|
|
|
|
do (remhash obj d-ephemeral-idx))
|
|
|
|
|
;; Fix-up indexes in each relocation class and fill corresponding
|
|
|
|
|
;; reloc lists.
|
2020-04-26 08:11:33 +00:00
|
|
|
|
(mapc #'comp-finalize-container (list d-default d-impure d-ephemeral))
|
|
|
|
|
;; Make a vector from the function documentation hash table.
|
|
|
|
|
(cl-loop with h = (comp-ctxt-function-docs comp-ctxt)
|
|
|
|
|
with v = (make-vector (hash-table-count h) nil)
|
|
|
|
|
for idx being each hash-keys of h
|
|
|
|
|
for doc = (gethash idx h)
|
|
|
|
|
do (setf (aref v idx) doc)
|
|
|
|
|
finally
|
2020-05-02 16:29:11 +00:00
|
|
|
|
do (setf (comp-ctxt-function-docs comp-ctxt) v))
|
|
|
|
|
;; And now we conclude with the following: We need to pass to
|
|
|
|
|
;; `comp--register-lambda' the index in the impure relocation
|
|
|
|
|
;; array to store revived lambdas, but given we know it only now
|
|
|
|
|
;; we fix it up as last.
|
|
|
|
|
(cl-loop for f being each hash-keys of (comp-ctxt-lambda-fixups-h comp-ctxt)
|
|
|
|
|
using (hash-value mvar)
|
|
|
|
|
with reverse-h = (make-hash-table) ;; Make sure idx is unique.
|
|
|
|
|
for idx = (gethash f d-impure-idx)
|
|
|
|
|
do
|
|
|
|
|
(cl-assert (null (gethash idx reverse-h)))
|
|
|
|
|
(cl-assert (fixnump idx))
|
|
|
|
|
(setf (comp-mvar-constant mvar) idx)
|
|
|
|
|
(puthash idx t reverse-h))))
|
2020-02-29 15:53:42 +00:00
|
|
|
|
|
2019-08-18 15:17:56 +00:00
|
|
|
|
(defun comp-compile-ctxt-to-file (name)
|
2019-09-07 06:57:07 +00:00
|
|
|
|
"Compile as native code the current context naming it NAME.
|
2019-09-22 16:49:11 +00:00
|
|
|
|
Prepare every function for final compilation and drive the C back-end."
|
2020-02-06 20:23:14 +00:00
|
|
|
|
(let ((dir (file-name-directory name)))
|
|
|
|
|
(comp-finalize-relocs)
|
|
|
|
|
(unless (file-exists-p dir)
|
2020-03-03 23:06:46 +00:00
|
|
|
|
;; In case it's created in the meanwhile.
|
|
|
|
|
(ignore-error 'file-already-exists
|
|
|
|
|
(make-directory dir)))
|
2020-02-06 20:23:14 +00:00
|
|
|
|
(unless comp-dry-run
|
|
|
|
|
(comp--compile-ctxt-to-file name))))
|
2019-08-18 15:17:56 +00:00
|
|
|
|
|
2019-09-18 21:25:37 +00:00
|
|
|
|
(defun comp-final (_)
|
2019-11-22 18:15:12 +00:00
|
|
|
|
"Final pass driving the C back-end for code emission."
|
2019-09-07 06:57:07 +00:00
|
|
|
|
(let (compile-result)
|
2019-11-24 18:49:25 +00:00
|
|
|
|
(maphash (lambda (_ f)
|
|
|
|
|
(comp-log-func f 1))
|
|
|
|
|
(comp-ctxt-funcs-h comp-ctxt))
|
2019-09-07 06:57:07 +00:00
|
|
|
|
(comp--init-ctxt)
|
|
|
|
|
(unwind-protect
|
2019-11-22 18:20:05 +00:00
|
|
|
|
(setf compile-result
|
2019-09-18 21:25:37 +00:00
|
|
|
|
(comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt)))
|
2019-09-07 06:57:07 +00:00
|
|
|
|
(and (comp--release-ctxt)
|
|
|
|
|
compile-result))))
|
2019-08-18 15:17:56 +00:00
|
|
|
|
|
2019-07-21 11:57:51 +00:00
|
|
|
|
|
2019-09-23 09:41:36 +00:00
|
|
|
|
;;; Compiler type hints.
|
|
|
|
|
;; These are public entry points be used in user code to give comp suggestion
|
|
|
|
|
;; about types.
|
2019-09-23 10:45:06 +00:00
|
|
|
|
;; These can be used to implement CL style 'the', 'declare' or something like.
|
|
|
|
|
;; Note: types will propagates.
|
2019-09-23 09:41:36 +00:00
|
|
|
|
;; 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)
|
2019-11-22 13:00:02 +00:00
|
|
|
|
(unless (fixnump x)
|
|
|
|
|
(signal 'wrong-type-argument x)))
|
2019-09-23 09:41:36 +00:00
|
|
|
|
|
|
|
|
|
(defun comp-hint-cons (x)
|
2019-11-22 13:00:02 +00:00
|
|
|
|
(unless (consp x)
|
|
|
|
|
(signal 'wrong-type-argument x)))
|
2019-09-23 09:41:36 +00:00
|
|
|
|
|
|
|
|
|
|
2019-11-10 19:01:48 +00:00
|
|
|
|
;; Some entry point support code.
|
|
|
|
|
|
2020-05-19 18:57:31 +00:00
|
|
|
|
(defun comp--replace-output-file (outfile tmpfile)
|
2020-05-24 20:59:25 +00:00
|
|
|
|
"Replace OUTFILE with TMPFILE.
|
|
|
|
|
Takes the necessary steps when dealing with shared libraries that
|
|
|
|
|
may be loaded into Emacs"
|
2020-05-19 18:57:31 +00:00
|
|
|
|
(cond ((eq 'windows-nt system-type)
|
|
|
|
|
(ignore-errors (delete-file outfile))
|
|
|
|
|
(let ((retry t))
|
|
|
|
|
(while retry
|
|
|
|
|
(setf retry nil)
|
|
|
|
|
(condition-case _
|
|
|
|
|
(progn
|
|
|
|
|
;; outfile maybe recreated by another Emacs in
|
|
|
|
|
;; between the following two rename-file calls
|
|
|
|
|
(if (file-exists-p outfile)
|
|
|
|
|
(rename-file outfile (make-temp-file-internal
|
|
|
|
|
(file-name-sans-extension outfile)
|
|
|
|
|
nil ".eln.old" nil)
|
|
|
|
|
t))
|
|
|
|
|
(rename-file tmpfile outfile nil))
|
|
|
|
|
(file-already-exists (setf retry t))))))
|
|
|
|
|
;; Remove the old eln instead of copying the new one into it
|
|
|
|
|
;; to get a new inode and prevent crashes in case the old one
|
|
|
|
|
;; is currently loaded.
|
|
|
|
|
(t (delete-file outfile)
|
|
|
|
|
(rename-file tmpfile outfile))))
|
|
|
|
|
|
2020-03-15 10:19:22 +00:00
|
|
|
|
(defvar comp-files-queue ()
|
|
|
|
|
"List of Elisp files to be compiled.")
|
|
|
|
|
|
2020-04-25 13:39:11 +00:00
|
|
|
|
(defvar comp-async-compilations (make-hash-table :test #'equal)
|
|
|
|
|
"Hash table file-name -> async compilation process.")
|
2020-03-15 10:19:22 +00:00
|
|
|
|
|
2020-03-15 19:37:51 +00:00
|
|
|
|
(defun comp-async-runnings ()
|
|
|
|
|
"Return the number of async compilations currently running.
|
|
|
|
|
This function has the side effect of cleaning-up finished
|
2020-04-25 13:39:11 +00:00
|
|
|
|
processes from `comp-async-compilations'"
|
|
|
|
|
(cl-loop
|
|
|
|
|
for file-name in (cl-loop
|
|
|
|
|
for file-name being each hash-key of comp-async-compilations
|
|
|
|
|
for prc = (gethash file-name comp-async-compilations)
|
|
|
|
|
unless (process-live-p prc)
|
|
|
|
|
collect file-name)
|
|
|
|
|
do (remhash file-name comp-async-compilations))
|
|
|
|
|
(hash-table-count comp-async-compilations))
|
2020-03-15 19:37:51 +00:00
|
|
|
|
|
2020-05-19 07:40:56 +00:00
|
|
|
|
(defvar comp-num-cpus nil)
|
2020-05-18 19:51:46 +00:00
|
|
|
|
(defun comp-effective-async-max-jobs ()
|
|
|
|
|
"Compute the effective number of async jobs."
|
|
|
|
|
(if (zerop comp-async-jobs-number)
|
|
|
|
|
(or comp-num-cpus
|
|
|
|
|
(setf comp-num-cpus
|
2020-05-13 19:22:17 +00:00
|
|
|
|
;; FIXME: we already have a function to determine
|
|
|
|
|
;; the number of processors, see get_native_system_info in w32.c.
|
|
|
|
|
;; The result needs to be exported to Lisp.
|
|
|
|
|
(max 1 (/ (cond ((eq 'windows-nt system-type)
|
|
|
|
|
(string-to-number (getenv "NUMBER_OF_PROCESSORS")))
|
|
|
|
|
((executable-find "nproc")
|
|
|
|
|
(string-to-number (shell-command-to-string "nproc")))
|
|
|
|
|
(t 1))
|
2020-05-18 19:51:46 +00:00
|
|
|
|
2))))
|
|
|
|
|
comp-async-jobs-number))
|
2020-03-15 20:17:15 +00:00
|
|
|
|
|
2020-03-15 19:37:51 +00:00
|
|
|
|
(defun comp-run-async-workers ()
|
2020-03-15 10:19:22 +00:00
|
|
|
|
"Start compiling files from `comp-files-queue' asynchronously.
|
|
|
|
|
When compilation is finished, run `comp-async-all-done-hook' and
|
|
|
|
|
display a message."
|
2020-03-15 19:37:51 +00:00
|
|
|
|
(if (or comp-files-queue
|
|
|
|
|
(> (comp-async-runnings) 0))
|
2020-03-15 20:17:15 +00:00
|
|
|
|
(unless (>= (comp-async-runnings) (comp-effective-async-max-jobs))
|
2020-03-15 19:37:51 +00:00
|
|
|
|
(cl-loop
|
2020-03-18 19:52:36 +00:00
|
|
|
|
for (source-file . load) = (pop comp-files-queue)
|
2020-03-15 19:37:51 +00:00
|
|
|
|
while source-file
|
|
|
|
|
do (cl-assert (string-match-p (rx ".el" eos) source-file) nil
|
|
|
|
|
"`comp-files-queue' should be \".el\" files: %s"
|
|
|
|
|
source-file)
|
|
|
|
|
when (or comp-always-compile
|
2020-04-29 20:21:42 +00:00
|
|
|
|
(file-newer-than-file-p source-file
|
|
|
|
|
(comp-output-filename source-file)))
|
2020-03-15 19:37:51 +00:00
|
|
|
|
do (let* ((expr `(progn
|
|
|
|
|
(require 'comp)
|
|
|
|
|
(setf comp-speed ,comp-speed
|
|
|
|
|
comp-debug ,comp-debug
|
|
|
|
|
comp-verbose ,comp-verbose
|
|
|
|
|
load-path ',load-path)
|
2020-05-18 19:45:29 +00:00
|
|
|
|
,comp-async-env-modifier-form
|
2020-03-15 19:37:51 +00:00
|
|
|
|
(message "Compiling %s..." ,source-file)
|
2020-03-18 19:52:36 +00:00
|
|
|
|
(native-compile ,source-file ,(and load t))))
|
|
|
|
|
(source-file1 source-file) ;; Make the closure works :/
|
2020-05-14 08:11:55 +00:00
|
|
|
|
(_ (progn
|
|
|
|
|
(comp-log "\n")
|
|
|
|
|
(comp-log (prin1-to-string expr))))
|
2020-05-08 17:04:06 +00:00
|
|
|
|
(temp-file (make-temp-file
|
|
|
|
|
(concat "emacs-async-comp-"
|
|
|
|
|
(file-name-base source-file) "-")
|
|
|
|
|
nil ".el" (prin1-to-string expr)))
|
2020-03-18 19:52:36 +00:00
|
|
|
|
(load1 load)
|
2020-03-15 19:37:51 +00:00
|
|
|
|
(process (make-process
|
|
|
|
|
:name (concat "Compiling: " source-file)
|
|
|
|
|
:buffer (get-buffer-create comp-async-buffer-name)
|
|
|
|
|
:command (list
|
|
|
|
|
(expand-file-name invocation-name
|
|
|
|
|
invocation-directory)
|
2020-05-08 17:04:06 +00:00
|
|
|
|
"--batch" "-l" temp-file)
|
2020-03-18 20:16:05 +00:00
|
|
|
|
:sentinel
|
|
|
|
|
(lambda (process _event)
|
|
|
|
|
(run-hook-with-args
|
|
|
|
|
'comp-async-cu-done-hook
|
|
|
|
|
source-file)
|
|
|
|
|
(accept-process-output process)
|
2020-05-08 17:04:06 +00:00
|
|
|
|
(ignore-errors (delete-file temp-file))
|
2020-03-18 20:16:05 +00:00
|
|
|
|
(when (and load1
|
|
|
|
|
(zerop (process-exit-status process)))
|
|
|
|
|
(native-elisp-load
|
|
|
|
|
(comp-output-filename source-file1)
|
2020-04-24 18:02:55 +00:00
|
|
|
|
(eq load1 'late)))
|
2020-03-18 20:16:05 +00:00
|
|
|
|
(comp-run-async-workers)))))
|
2020-04-25 13:39:11 +00:00
|
|
|
|
(puthash source-file process comp-async-compilations))
|
2020-03-15 20:17:15 +00:00
|
|
|
|
when (>= (comp-async-runnings) (comp-effective-async-max-jobs))
|
2020-03-15 19:37:51 +00:00
|
|
|
|
do (cl-return)))
|
|
|
|
|
;; No files left to compile and all processes finished.
|
|
|
|
|
(let ((msg "Compilation finished."))
|
|
|
|
|
(run-hooks 'comp-async-all-done-hook)
|
|
|
|
|
(with-current-buffer (get-buffer-create comp-async-buffer-name)
|
|
|
|
|
(save-excursion
|
|
|
|
|
(goto-char (point-max))
|
|
|
|
|
(insert msg "\n")))
|
2020-03-23 15:57:48 +00:00
|
|
|
|
;; `comp-deferred-pending-h' should be empty at this stage.
|
|
|
|
|
;; Reset it anyway.
|
2020-04-25 14:43:10 +00:00
|
|
|
|
(clrhash comp-deferred-pending-h)
|
2020-03-15 19:37:51 +00:00
|
|
|
|
(message msg))))
|
2020-03-15 10:19:22 +00:00
|
|
|
|
|
2019-11-10 19:01:48 +00:00
|
|
|
|
|
2019-09-23 09:41:36 +00:00
|
|
|
|
;;; Compiler entry points.
|
2019-07-21 11:57:51 +00:00
|
|
|
|
|
2019-10-21 07:53:00 +00:00
|
|
|
|
;;;###autoload
|
2020-03-17 22:24:52 +00:00
|
|
|
|
(defun native-compile (function-or-file &optional with-late-load)
|
2020-03-15 10:19:22 +00:00
|
|
|
|
"Compile FUNCTION-OR-FILE into native code.
|
2019-11-22 18:15:12 +00:00
|
|
|
|
This is the entry-point for the Emacs Lisp native compiler.
|
2020-03-15 10:19:22 +00:00
|
|
|
|
FUNCTION-OR-FILE is a function symbol or a path to an Elisp file.
|
2020-04-03 19:09:02 +00:00
|
|
|
|
When WITH-LATE-LOAD non Nil mark the compilation unit for late load
|
|
|
|
|
once finished compiling (internal use only).
|
2019-11-22 18:15:12 +00:00
|
|
|
|
Return the compilation unit file name."
|
2020-03-15 10:19:22 +00:00
|
|
|
|
(unless (or (functionp function-or-file)
|
|
|
|
|
(stringp function-or-file))
|
2019-11-21 15:09:30 +00:00
|
|
|
|
(signal 'native-compiler-error
|
2020-03-15 10:19:22 +00:00
|
|
|
|
(list "Not a function symbol or file" function-or-file)))
|
|
|
|
|
(let* ((data function-or-file)
|
|
|
|
|
(comp-native-compiling t)
|
|
|
|
|
;; Have byte compiler signal an error when compilation fails.
|
|
|
|
|
(byte-compile-debug t)
|
|
|
|
|
(comp-ctxt
|
|
|
|
|
(make-comp-ctxt
|
2020-03-18 19:52:36 +00:00
|
|
|
|
:output (comp-output-base-filename function-or-file)
|
2020-03-17 22:24:52 +00:00
|
|
|
|
:with-late-load with-late-load)))
|
2019-11-09 15:56:55 +00:00
|
|
|
|
(comp-log "\n\n" 1)
|
2019-11-17 10:48:30 +00:00
|
|
|
|
(condition-case err
|
|
|
|
|
(mapc (lambda (pass)
|
2020-03-15 10:19:22 +00:00
|
|
|
|
(comp-log (format "(%s) Running pass %s:\n"
|
|
|
|
|
function-or-file pass)
|
|
|
|
|
2)
|
2019-11-22 18:20:05 +00:00
|
|
|
|
(setf data (funcall pass data)))
|
2019-11-17 10:48:30 +00:00
|
|
|
|
comp-passes)
|
2019-11-21 15:09:30 +00:00
|
|
|
|
(native-compiler-error
|
|
|
|
|
;; Add source input.
|
|
|
|
|
(let ((err-val (cdr err)))
|
2020-03-15 10:19:22 +00:00
|
|
|
|
(signal (car err) (if (consp err-val)
|
|
|
|
|
(cons function-or-file err-val)
|
|
|
|
|
(list function-or-file err-val))))))
|
2019-11-02 11:34:09 +00:00
|
|
|
|
data))
|
2019-07-07 07:23:10 +00:00
|
|
|
|
|
2019-12-24 19:38:13 +00:00
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun batch-native-compile ()
|
2020-03-15 10:19:22 +00:00
|
|
|
|
"Run `native-compile' on remaining command-line arguments.
|
|
|
|
|
Ultra cheap impersonation of `batch-byte-compile'."
|
2020-05-06 17:55:33 +00:00
|
|
|
|
(cl-loop for file in command-line-args-left
|
|
|
|
|
if (or (null byte-native-for-bootstrap)
|
|
|
|
|
(cl-notany (lambda (re) (string-match re file))
|
|
|
|
|
comp-bootstrap-black-list))
|
|
|
|
|
do (native-compile file)
|
|
|
|
|
else
|
|
|
|
|
do (byte-compile-file file)))
|
2019-12-24 19:38:13 +00:00
|
|
|
|
|
2019-12-29 14:56:49 +00:00
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun batch-byte-native-compile-for-bootstrap ()
|
|
|
|
|
"As `batch-byte-compile' but used for booststrap.
|
|
|
|
|
Always generate elc files too and handle native compiler expected errors."
|
2020-03-21 14:11:41 +00:00
|
|
|
|
(if (equal (getenv "NATIVE_DISABLE") "1")
|
|
|
|
|
(batch-byte-compile)
|
2020-05-06 17:55:33 +00:00
|
|
|
|
(cl-assert (= 1 (length command-line-args-left)))
|
2020-03-21 14:11:41 +00:00
|
|
|
|
(let ((byte-native-for-bootstrap t)
|
|
|
|
|
(byte-to-native-output-file nil))
|
|
|
|
|
(unwind-protect
|
|
|
|
|
(condition-case _
|
|
|
|
|
(batch-native-compile)
|
|
|
|
|
(native-compiler-error-dyn-func)
|
|
|
|
|
(native-compiler-error-empty-byte))
|
|
|
|
|
(pcase byte-to-native-output-file
|
|
|
|
|
(`(,tempfile . ,target-file)
|
|
|
|
|
(rename-file tempfile target-file t)))))))
|
2019-12-29 14:56:49 +00:00
|
|
|
|
|
2019-11-10 19:01:48 +00:00
|
|
|
|
;;;###autoload
|
2020-03-18 19:52:36 +00:00
|
|
|
|
(defun native-compile-async (paths &optional recursively load)
|
2020-03-15 10:19:22 +00:00
|
|
|
|
"Compile PATHS asynchronously.
|
|
|
|
|
PATHS is one path or a list of paths to files or directories.
|
2020-03-15 19:37:51 +00:00
|
|
|
|
`comp-async-jobs-number' specifies the number of (commands) to
|
|
|
|
|
run simultaneously. If RECURSIVELY, recurse into subdirectories
|
2020-03-18 19:52:36 +00:00
|
|
|
|
of given directories.
|
|
|
|
|
LOAD can be nil t or 'late."
|
|
|
|
|
(unless (member load '(nil t late))
|
|
|
|
|
(error "LOAD must be nil t or 'late"))
|
2020-03-15 10:19:22 +00:00
|
|
|
|
(unless (listp paths)
|
|
|
|
|
(setf paths (list paths)))
|
|
|
|
|
(let (files)
|
|
|
|
|
(dolist (path paths)
|
|
|
|
|
(cond ((file-directory-p path)
|
|
|
|
|
(dolist (file (if recursively
|
|
|
|
|
(directory-files-recursively path (rx ".el" eos))
|
|
|
|
|
(directory-files path t (rx ".el" eos))))
|
|
|
|
|
(push file files)))
|
|
|
|
|
((file-exists-p path) (push path files))
|
|
|
|
|
(t (signal 'native-compiler-error
|
|
|
|
|
(list "Path not a file nor directory" path)))))
|
2020-03-15 21:07:14 +00:00
|
|
|
|
(dolist (file files)
|
2020-03-18 19:52:36 +00:00
|
|
|
|
(if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=)))
|
2020-04-14 07:48:24 +00:00
|
|
|
|
;; When no load is specified (plain async compilation) we
|
|
|
|
|
;; consider valid the one previously queued, otherwise we
|
|
|
|
|
;; check for coherence (bug#40602).
|
|
|
|
|
(cl-assert (or (null load)
|
|
|
|
|
(eq load (cdr entry)))
|
|
|
|
|
nil "Trying to queue %s with LOAD %s but this is already \
|
|
|
|
|
queued with LOAD %"
|
|
|
|
|
file load (cdr entry))
|
2020-04-25 13:45:21 +00:00
|
|
|
|
;; Make sure we are not already compiling `file' (bug#40838).
|
2020-05-10 07:48:50 +00:00
|
|
|
|
(unless (or (gethash file comp-async-compilations)
|
|
|
|
|
;; Also exclude files from deferred compilation if
|
|
|
|
|
;; any of the regexps in
|
|
|
|
|
;; `comp-deferred-compilation-black-list' matches.
|
|
|
|
|
(and (eq load 'late)
|
|
|
|
|
(cl-some (lambda (re) (string-match re file))
|
|
|
|
|
comp-deferred-compilation-black-list)))
|
2020-05-03 12:37:38 +00:00
|
|
|
|
(let ((out-dir (comp-output-directory file))
|
|
|
|
|
(out-filename (comp-output-filename file)))
|
|
|
|
|
(if (or (file-writable-p out-filename)
|
|
|
|
|
(and (not (file-exists-p out-dir))
|
|
|
|
|
(file-writable-p (substring out-dir 0 -1))))
|
|
|
|
|
(setf comp-files-queue
|
|
|
|
|
(append comp-files-queue `((,file . ,load))))
|
|
|
|
|
(display-warning 'comp
|
|
|
|
|
(format "No write access for %s skipping."
|
|
|
|
|
out-filename)))))))
|
2020-03-15 19:37:51 +00:00
|
|
|
|
(when (zerop (comp-async-runnings))
|
2020-03-24 19:10:20 +00:00
|
|
|
|
(comp-run-async-workers)
|
|
|
|
|
(message "Compilation started."))))
|
2019-11-10 19:01:48 +00:00
|
|
|
|
|
2019-07-07 07:23:10 +00:00
|
|
|
|
(provide 'comp)
|
|
|
|
|
|
|
|
|
|
;;; comp.el ends here
|