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>
|
|
|
|
|
|
2019-07-07 07:23:10 +00:00
|
|
|
|
;; Copyright (C) 2019 Free Software Foundation, Inc.
|
|
|
|
|
|
|
|
|
|
;; Keywords: lisp
|
|
|
|
|
;; Package: emacs
|
|
|
|
|
|
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
|
|
|
|
|
|
;; GNU Emacs is free software: you can redistribute it and/or modify
|
|
|
|
|
;; it under the terms of the GNU General Public License as published by
|
|
|
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
|
|
|
;; (at your option) any later version.
|
|
|
|
|
|
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
|
;; GNU General Public License for more details.
|
|
|
|
|
|
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
|
|
|
;; along with GNU Emacs. If not, see <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.
|
|
|
|
|
;; Or, to put it another way to make a Carrera 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-lib)
|
|
|
|
|
(require 'cl-extra)
|
|
|
|
|
(require 'subr-x)
|
2019-07-07 07:23:10 +00:00
|
|
|
|
|
|
|
|
|
(defgroup comp nil
|
|
|
|
|
"Emacs Lisp native compiler."
|
|
|
|
|
:group 'lisp)
|
|
|
|
|
|
2019-08-11 09:59:31 +00:00
|
|
|
|
(defcustom comp-debug t
|
|
|
|
|
"Log compilation process."
|
|
|
|
|
:type 'boolean
|
|
|
|
|
:group 'comp)
|
|
|
|
|
|
|
|
|
|
(defconst native-compile-log-buffer "*Native-compile-Log*"
|
|
|
|
|
"Name of the native-compiler's log buffer.")
|
2019-07-07 07:23:10 +00:00
|
|
|
|
|
2019-07-14 22:58:03 +00:00
|
|
|
|
;; FIXME these has to be removed
|
2019-07-13 15:24:44 +00:00
|
|
|
|
(defvar comp-speed 2)
|
|
|
|
|
|
2019-07-21 13:20:39 +00:00
|
|
|
|
(defvar comp-pass nil
|
|
|
|
|
"Every pass has the right to bind what it likes here.")
|
|
|
|
|
|
|
|
|
|
(defconst comp-passes '(comp-spill-lap
|
2019-09-07 06:57:07 +00:00
|
|
|
|
comp-limplify
|
|
|
|
|
comp-final)
|
2019-07-07 10:30:03 +00:00
|
|
|
|
"Passes to be executed in order.")
|
|
|
|
|
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(defconst comp-known-ret-types '((cons . cons))
|
2019-07-21 13:20:39 +00:00
|
|
|
|
"Alist used for type propagation.")
|
2019-07-07 19:49:11 +00:00
|
|
|
|
|
2019-07-08 05:17:28 +00:00
|
|
|
|
(defconst comp-mostly-pure-funcs
|
|
|
|
|
'(% * + - / /= 1+ 1- < <= = > >= cons list % concat logand logcount logior
|
|
|
|
|
lognot logxor regexp-opt regexp-quote string-to-char string-to-syntax
|
|
|
|
|
symbol-name)
|
|
|
|
|
"Functions on witch we do constant propagation."
|
|
|
|
|
;; Is it acceptable to move into the compile time functions that are
|
|
|
|
|
;; allocating memory? (these are technically not side effect free)
|
|
|
|
|
)
|
|
|
|
|
|
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."))
|
|
|
|
|
|
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-09-07 14:35:07 +00:00
|
|
|
|
(output nil :type 'string
|
2019-09-07 06:57:07 +00:00
|
|
|
|
:documentation "Target output filename for the compilation.")
|
2019-09-07 14:35:07 +00:00
|
|
|
|
(top-level-defvars nil :type list
|
|
|
|
|
:documentation "List of top level form to be compiled.")
|
2019-08-18 15:17:56 +00:00
|
|
|
|
(funcs () :type list
|
2019-08-22 14:00:43 +00:00
|
|
|
|
:documentation "Exported functions list.")
|
2019-08-18 15:17:56 +00:00
|
|
|
|
(funcs-h (make-hash-table) :type hash-table
|
2019-08-18 21:09:20 +00:00
|
|
|
|
:documentation "lisp-func-name -> comp-func.
|
2019-08-18 15:17:56 +00:00
|
|
|
|
This is to build the prev field.")
|
2019-08-18 13:36:36 +00:00
|
|
|
|
(data-relocs-l () :type list
|
|
|
|
|
:documentation "Constant objects used by functions.")
|
|
|
|
|
(data-relocs-idx (make-hash-table :test #'equal) :type hash-table
|
|
|
|
|
:documentation "Obj -> position into data-relocs.")
|
2019-08-19 16:22:26 +00:00
|
|
|
|
(func-relocs-l () :type list
|
2019-08-18 13:36:36 +00:00
|
|
|
|
:documentation "Native functions imported.")
|
|
|
|
|
(func-relocs-idx (make-hash-table :test #'equal) :type hash-table
|
|
|
|
|
:documentation "Obj -> position into func-relocs."))
|
|
|
|
|
|
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-08-11 12:54:13 +00:00
|
|
|
|
"Describe args when the functin signature is of kind:
|
|
|
|
|
(ptrdiff_t nargs, Lisp_Object *args)."
|
|
|
|
|
(nonrest nil :type number
|
|
|
|
|
:documentation "Number of non rest arguments."))
|
2019-07-07 10:30:03 +00:00
|
|
|
|
|
2019-07-14 15:21:34 +00:00
|
|
|
|
(cl-defstruct (comp-block (:copier nil))
|
|
|
|
|
"A basic block."
|
2019-07-21 13:20:39 +00:00
|
|
|
|
;; The first two slots are used during limplification.
|
2019-07-14 15:21:34 +00:00
|
|
|
|
(sp nil
|
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-08-18 08:34:18 +00:00
|
|
|
|
(closed nil :type boolean
|
2019-07-21 13:20:39 +00:00
|
|
|
|
:documentation "If the block was already closed.")
|
|
|
|
|
(insns () :type list
|
|
|
|
|
:documentation "List of instructions."))
|
2019-07-14 15:21:34 +00:00
|
|
|
|
|
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-07-07 10:30:03 +00:00
|
|
|
|
(symbol-name nil
|
2019-07-14 18:54:53 +00:00
|
|
|
|
:documentation "Function symbol's name.")
|
2019-08-18 08:34:18 +00:00
|
|
|
|
(c-func-name nil :type string
|
2019-07-14 18:54:53 +00:00
|
|
|
|
:documentation "The function name in the native world.")
|
2019-07-07 10:30:03 +00:00
|
|
|
|
(func nil
|
2019-07-14 18:54:53 +00:00
|
|
|
|
:documentation "Original form.")
|
2019-07-07 10:30:03 +00:00
|
|
|
|
(byte-func nil
|
2019-07-14 18:54:53 +00:00
|
|
|
|
:documentation "Byte compiled version.")
|
2019-07-21 13:20:39 +00:00
|
|
|
|
(lap () :type list
|
|
|
|
|
:documentation "Lap assembly representation.")
|
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-07-14 12:39:29 +00:00
|
|
|
|
:documentation "Key value to convert from LAP label number to
|
2019-07-14 18:54:53 +00:00
|
|
|
|
LIMPLE basic block.")
|
2019-08-18 08:34:18 +00:00
|
|
|
|
(ssa-cnt -1 :type number
|
2019-07-14 18:54:53 +00:00
|
|
|
|
:documentation "Counter to create ssa limple vars."))
|
2019-07-07 10:30:03 +00:00
|
|
|
|
|
2019-07-08 05:56:37 +00:00
|
|
|
|
(cl-defstruct (comp-mvar (:copier nil) (:constructor make--comp-mvar))
|
2019-07-07 19:49:11 +00:00
|
|
|
|
"A meta-variable being a slot in the meta-stack."
|
2019-07-09 20:28:29 +00:00
|
|
|
|
(id nil :type number
|
2019-07-14 18:54:53 +00:00
|
|
|
|
:documentation "SSA number.")
|
2019-07-07 10:30:03 +00:00
|
|
|
|
(slot nil :type fixnum
|
2019-07-14 18:54:53 +00:00
|
|
|
|
:documentation "Slot position.")
|
2019-07-07 10:30:03 +00:00
|
|
|
|
(const-vld nil
|
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
|
|
|
|
|
:documentation "When const-vld non nil this is used for constant
|
2019-07-14 18:54:53 +00:00
|
|
|
|
propagation.")
|
2019-07-07 10:30:03 +00:00
|
|
|
|
(type nil
|
2019-07-14 18:54:53 +00:00
|
|
|
|
:documentation "When non nil is used for type propagation."))
|
2019-07-07 10:30:03 +00:00
|
|
|
|
|
2019-07-14 15:33:18 +00:00
|
|
|
|
(cl-defstruct (comp-limplify (:copier nil))
|
2019-09-07 14:35:07 +00:00
|
|
|
|
"Support structure used during function limplification."
|
2019-08-18 08:34:18 +00:00
|
|
|
|
(sp 0 :type fixnum
|
2019-07-14 18:54:53 +00:00
|
|
|
|
:documentation "Current stack pointer while walking LAP.")
|
2019-08-18 08:34:18 +00:00
|
|
|
|
(frame nil :type vector
|
2019-07-14 18:54:53 +00:00
|
|
|
|
:documentation "Meta-stack used to flat LAP.")
|
2019-08-18 08:34:18 +00:00
|
|
|
|
(block-name nil :type symbol
|
2019-07-14 18:54:53 +00:00
|
|
|
|
:documentation "Current basic block name."))
|
2019-07-07 10:30:03 +00:00
|
|
|
|
|
2019-08-18 13:36:36 +00:00
|
|
|
|
(defvar comp-ctxt) ;; FIXME (to be removed)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(defun comp-add-const-to-relocs (obj)
|
2019-08-19 15:59:20 +00:00
|
|
|
|
"Keep track of OBJ into the ctxt relocations.
|
|
|
|
|
The corresponding index is returned."
|
2019-08-18 13:36:36 +00:00
|
|
|
|
(let ((data-relocs-idx (comp-ctxt-data-relocs-idx comp-ctxt)))
|
2019-09-01 15:02:35 +00:00
|
|
|
|
(if-let ((idx (gethash obj data-relocs-idx)))
|
|
|
|
|
idx
|
2019-08-18 13:36:36 +00:00
|
|
|
|
(push obj (comp-ctxt-data-relocs-l comp-ctxt))
|
|
|
|
|
(puthash obj (hash-table-count data-relocs-idx) data-relocs-idx))))
|
|
|
|
|
|
2019-08-22 14:00:43 +00:00
|
|
|
|
(defun comp-add-subr-to-relocs (subr-name)
|
|
|
|
|
"Keep track of SUBR-NAME into the ctxt relocations.
|
|
|
|
|
The corresponding index is returned."
|
|
|
|
|
(let ((func-relocs-idx (comp-ctxt-func-relocs-idx comp-ctxt)))
|
2019-09-01 15:02:35 +00:00
|
|
|
|
(if-let ((idx (gethash subr-name func-relocs-idx)))
|
|
|
|
|
idx
|
2019-08-22 14:00:43 +00:00
|
|
|
|
(push subr-name (comp-ctxt-func-relocs-l comp-ctxt))
|
|
|
|
|
(puthash subr-name (hash-table-count func-relocs-idx) func-relocs-idx))))
|
|
|
|
|
|
2019-08-11 09:59:31 +00:00
|
|
|
|
(defmacro comp-within-log-buff (&rest body)
|
|
|
|
|
"Execute BODY while at the end the log-buffer.
|
|
|
|
|
BODY is evaluate only if `comp-debug' is non nil."
|
|
|
|
|
(declare (debug (form body))
|
|
|
|
|
(indent defun))
|
|
|
|
|
`(when comp-debug
|
|
|
|
|
(with-current-buffer (get-buffer-create native-compile-log-buffer)
|
|
|
|
|
(setq buffer-read-only t)
|
|
|
|
|
(let ((inhibit-read-only t))
|
|
|
|
|
(goto-char (point-max))
|
|
|
|
|
,@body))))
|
|
|
|
|
|
|
|
|
|
(defun comp-log (string)
|
|
|
|
|
"Log a STRING into the log-buffer."
|
|
|
|
|
(comp-within-log-buff
|
|
|
|
|
(cond (noninteractive
|
|
|
|
|
(message " %s" string))
|
|
|
|
|
(t
|
|
|
|
|
(insert (format "%s\n" string))))))
|
|
|
|
|
|
|
|
|
|
(defun comp-log-func (func)
|
|
|
|
|
"Pretty print function FUNC in the log-buffer."
|
|
|
|
|
(comp-within-log-buff
|
|
|
|
|
(insert (format "\n\n Function: %s" (comp-func-symbol-name func)))
|
|
|
|
|
(cl-loop for block-name being each hash-keys of (comp-func-blocks func)
|
|
|
|
|
using (hash-value bb)
|
|
|
|
|
do (progn
|
|
|
|
|
(insert (concat "\n<" (symbol-name block-name) ">"))
|
|
|
|
|
(cl-prettyprint (comp-block-insns bb))))))
|
2019-07-21 13:20:39 +00:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; spill-lap pass specific code.
|
2019-07-09 16:09:47 +00:00
|
|
|
|
|
2019-08-21 19:20:27 +00:00
|
|
|
|
(defun comp-c-func-name (symbol prefix)
|
|
|
|
|
"Given SYMBOL 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-08-21 19:20:27 +00:00
|
|
|
|
(let* ((orig-name (symbol-name symbol))
|
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))
|
|
|
|
|
do (aset str (1+ j) (aref byte 1))
|
|
|
|
|
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)))
|
2019-08-21 10:17:56 +00:00
|
|
|
|
(concat prefix crypted "_" human-readable)))
|
2019-07-08 10:11:34 +00:00
|
|
|
|
|
2019-07-07 10:30:03 +00:00
|
|
|
|
(defun comp-decrypt-lambda-list (x)
|
|
|
|
|
"Decript lambda list X."
|
2019-09-07 09:17:02 +00:00
|
|
|
|
(unless (fixnump x)
|
|
|
|
|
(error "Can't native compile a non lexical scoped function"))
|
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
|
|
|
|
|
:nonrest nonrest))))
|
2019-07-07 10:30:03 +00:00
|
|
|
|
|
2019-09-07 06:18:08 +00:00
|
|
|
|
(defun comp-spill-lap-function (function-name)
|
2019-09-07 09:17:02 +00:00
|
|
|
|
"Byte compile FUNCTION-NAME spilling data from the byte compiler."
|
2019-09-07 06:18:08 +00:00
|
|
|
|
(let* ((f (symbol-function function-name))
|
|
|
|
|
(func (make-comp-func :symbol-name function-name
|
|
|
|
|
:func f
|
|
|
|
|
:c-func-name (comp-c-func-name
|
|
|
|
|
function-name
|
|
|
|
|
"F"))))
|
|
|
|
|
(when (byte-code-function-p f)
|
|
|
|
|
(error "Can't native compile an already bytecompiled function"))
|
|
|
|
|
(setf (comp-func-byte-func func)
|
|
|
|
|
(byte-compile (comp-func-symbol-name func)))
|
|
|
|
|
(comp-within-log-buff
|
|
|
|
|
(cl-prettyprint byte-to-native-lap-output))
|
|
|
|
|
(let ((lambda-list (aref (comp-func-byte-func func) 0)))
|
2019-09-07 09:17:02 +00:00
|
|
|
|
(setf (comp-func-args func)
|
|
|
|
|
(comp-decrypt-lambda-list lambda-list)))
|
2019-09-07 06:18:08 +00:00
|
|
|
|
(setf (comp-func-lap func) (car byte-to-native-lap-output))
|
|
|
|
|
(setf (comp-func-frame-size func) (aref (comp-func-byte-func func) 3))
|
|
|
|
|
func))
|
|
|
|
|
|
2019-09-07 09:17:02 +00:00
|
|
|
|
(defun comp-spill-lap-functions-file (filename)
|
|
|
|
|
"Byte compile FILENAME spilling data from the byte compiler."
|
|
|
|
|
(byte-compile-file filename)
|
|
|
|
|
(cl-assert (= (length byte-to-native-names)
|
|
|
|
|
(length byte-to-native-lap-output)
|
|
|
|
|
(length byte-to-native-bytecode-output)))
|
2019-09-07 14:35:07 +00:00
|
|
|
|
(setf (comp-ctxt-top-level-defvars comp-ctxt)
|
|
|
|
|
(mapcar (lambda (x)
|
|
|
|
|
(if (eq (car x) 'defvar)
|
|
|
|
|
(cdr x)
|
|
|
|
|
(cl-assert nil)))
|
|
|
|
|
byte-to-native-top-level-forms))
|
2019-09-07 09:17:02 +00:00
|
|
|
|
(cl-loop for function-name in byte-to-native-names
|
|
|
|
|
for lap in byte-to-native-lap-output
|
|
|
|
|
for bytecode in byte-to-native-bytecode-output
|
|
|
|
|
for lambda-list = (aref bytecode 0)
|
|
|
|
|
for func = (make-comp-func :symbol-name function-name
|
|
|
|
|
:byte-func bytecode
|
|
|
|
|
:c-func-name (comp-c-func-name
|
|
|
|
|
function-name
|
|
|
|
|
"F")
|
|
|
|
|
:args (comp-decrypt-lambda-list lambda-list)
|
|
|
|
|
:lap lap
|
|
|
|
|
:frame-size (aref bytecode 3))
|
|
|
|
|
do (comp-within-log-buff
|
|
|
|
|
(cl-prettyprint lap))
|
|
|
|
|
collect func))
|
|
|
|
|
|
2019-09-07 06:18:08 +00:00
|
|
|
|
(defun comp-spill-lap (input)
|
|
|
|
|
"Byte compile and spill the LAP rapresentation for INPUT.
|
|
|
|
|
If INPUT is a symbol this is the function-name to be compiled.
|
|
|
|
|
If INPUT is a string this is the file path to be compiled."
|
2019-09-06 17:33:16 +00:00
|
|
|
|
(let ((byte-native-compiling t)
|
2019-09-07 09:17:02 +00:00
|
|
|
|
(byte-to-native-names ())
|
|
|
|
|
(byte-to-native-lap-output ())
|
2019-09-07 14:35:07 +00:00
|
|
|
|
(byte-to-native-bytecode-output ())
|
|
|
|
|
(byte-to-native-top-level-forms ()))
|
2019-09-07 06:18:08 +00:00
|
|
|
|
(cl-typecase input
|
|
|
|
|
(symbol (list (comp-spill-lap-function input)))
|
2019-09-07 09:17:02 +00:00
|
|
|
|
(string (comp-spill-lap-functions-file input)))))
|
2019-07-08 05:56:37 +00:00
|
|
|
|
|
2019-07-21 13:20:39 +00:00
|
|
|
|
|
|
|
|
|
;;; Limplification pass specific code.
|
|
|
|
|
|
|
|
|
|
;; Special vars used during limplifications
|
|
|
|
|
(defvar comp-block)
|
|
|
|
|
(defvar comp-func)
|
2019-07-08 09:37:17 +00:00
|
|
|
|
|
2019-07-08 05:56:37 +00:00
|
|
|
|
;; (defun comp-opt-call (inst)
|
|
|
|
|
;; "Optimize if possible a side-effect-free call in INST."
|
|
|
|
|
;; (cl-destructuring-bind (_ f &rest args) inst
|
|
|
|
|
;; (when (and (member f comp-mostly-pure-funcs)
|
|
|
|
|
;; (cl-every #'identity (mapcar #'comp-mvar-const-vld args)))
|
|
|
|
|
;; (apply f (mapcar #'comp-mvar-constant args)))))
|
2019-07-07 10:30:03 +00:00
|
|
|
|
|
2019-08-21 10:17:56 +00:00
|
|
|
|
(defun comp-call (func &rest args)
|
|
|
|
|
"Emit a call for function FUNC with ARGS."
|
2019-08-22 14:00:43 +00:00
|
|
|
|
(comp-add-subr-to-relocs func)
|
2019-08-21 19:20:27 +00:00
|
|
|
|
`(call ,func ,@args))
|
2019-08-19 15:59:20 +00:00
|
|
|
|
|
2019-08-21 10:17:56 +00:00
|
|
|
|
(defun comp-callref (func &rest args)
|
|
|
|
|
"Emit a call usign narg abi for FUNC with ARGS."
|
2019-08-22 14:00:43 +00:00
|
|
|
|
(comp-add-subr-to-relocs func)
|
2019-08-21 19:20:27 +00:00
|
|
|
|
`(callref ,func ,@args))
|
2019-08-19 15:59:20 +00:00
|
|
|
|
|
2019-07-21 13:20:39 +00:00
|
|
|
|
(defun comp-new-frame (size)
|
|
|
|
|
"Return a clean frame of meta variables of size SIZE."
|
|
|
|
|
(let ((v (make-vector size nil)))
|
|
|
|
|
(cl-loop for i below size
|
|
|
|
|
do (aset v i (make-comp-mvar :slot i)))
|
|
|
|
|
v))
|
2019-07-08 07:06:58 +00:00
|
|
|
|
|
2019-08-03 14:15:37 +00:00
|
|
|
|
(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type)
|
2019-09-04 21:12:34 +00:00
|
|
|
|
(when const-vld
|
|
|
|
|
(comp-add-const-to-relocs constant))
|
2019-07-21 13:20:39 +00:00
|
|
|
|
(make--comp-mvar :id (cl-incf (comp-func-ssa-cnt comp-func))
|
2019-07-08 07:29:13 +00:00
|
|
|
|
:slot slot :const-vld const-vld :constant constant
|
|
|
|
|
:type type))
|
|
|
|
|
|
2019-07-07 10:30:03 +00:00
|
|
|
|
(defmacro comp-sp ()
|
|
|
|
|
"Current stack pointer."
|
2019-07-14 18:54:53 +00:00
|
|
|
|
'(comp-limplify-sp comp-pass))
|
2019-07-07 10:30:03 +00:00
|
|
|
|
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(defmacro comp-with-sp (sp &rest body)
|
|
|
|
|
"Execute BODY setting the stack pointer to SP.
|
2019-07-14 12:39:29 +00:00
|
|
|
|
Restore the original value afterwards."
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(declare (debug (form body))
|
2019-07-14 12:39:29 +00:00
|
|
|
|
(indent defun))
|
|
|
|
|
(let ((sym (gensym)))
|
|
|
|
|
`(let ((,sym (comp-sp)))
|
|
|
|
|
(setf (comp-sp) ,sp)
|
|
|
|
|
(progn ,@body)
|
|
|
|
|
(setf (comp-sp) ,sym))))
|
2019-07-14 07:53:06 +00:00
|
|
|
|
|
2019-07-07 16:42:55 +00:00
|
|
|
|
(defmacro comp-slot-n (n)
|
|
|
|
|
"Slot N into the meta-stack."
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(declare (debug (form)))
|
2019-07-14 18:54:53 +00:00
|
|
|
|
`(aref (comp-limplify-frame comp-pass) ,n))
|
2019-07-07 16:42:55 +00:00
|
|
|
|
|
2019-07-07 10:30:03 +00:00
|
|
|
|
(defmacro comp-slot ()
|
|
|
|
|
"Current slot into the meta-stack pointed by sp."
|
2019-07-07 16:42:55 +00:00
|
|
|
|
'(comp-slot-n (comp-sp)))
|
2019-07-07 10:30:03 +00:00
|
|
|
|
|
2019-07-07 19:49:11 +00:00
|
|
|
|
(defmacro comp-slot-next ()
|
|
|
|
|
"Slot into the meta-stack pointed by sp + 1."
|
|
|
|
|
'(comp-slot-n (1+ (comp-sp))))
|
|
|
|
|
|
2019-07-21 13:20:39 +00:00
|
|
|
|
(defun comp-emit (insn)
|
|
|
|
|
"Emit INSN into current basic block."
|
|
|
|
|
(push insn (comp-block-insns comp-block)))
|
2019-07-13 14:34:59 +00:00
|
|
|
|
|
|
|
|
|
(defun 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-08 07:06:58 +00:00
|
|
|
|
(setf (comp-slot)
|
2019-07-08 07:29:13 +00:00
|
|
|
|
(make-comp-mvar :slot (comp-sp)
|
2019-07-13 15:08:15 +00:00
|
|
|
|
:type (when (> comp-speed 0)
|
|
|
|
|
(alist-get (cadr call)
|
|
|
|
|
comp-known-ret-types))))
|
2019-07-13 14:34:59 +00:00
|
|
|
|
(comp-emit (list 'set (comp-slot) call)))
|
2019-07-13 09:33:15 +00:00
|
|
|
|
|
2019-08-19 15:08:44 +00:00
|
|
|
|
(defmacro comp-emit-set-call-subr (subr-name sp-delta)
|
|
|
|
|
"Emit a call for SUBR-NAME.
|
|
|
|
|
SP-DELTA is the stack adjustment."
|
2019-07-14 21:35:04 +00:00
|
|
|
|
(let ((subr (symbol-function subr-name))
|
2019-07-20 13:49:30 +00:00
|
|
|
|
(subr-str (symbol-name subr-name))
|
|
|
|
|
(nargs (1+ (- sp-delta))))
|
2019-07-14 21:35:04 +00:00
|
|
|
|
(cl-assert (subrp subr) nil
|
|
|
|
|
"%s not a subr" subr-str)
|
|
|
|
|
(let* ((arity (subr-arity subr))
|
|
|
|
|
(minarg (car arity))
|
|
|
|
|
(maxarg (cdr arity)))
|
2019-07-20 13:49:30 +00:00
|
|
|
|
(cl-assert (not (eq maxarg 'unevalled)) nil
|
|
|
|
|
"%s contains unevalled arg" subr-name)
|
|
|
|
|
(if (eq maxarg 'many)
|
|
|
|
|
;; callref case.
|
2019-09-01 10:29:13 +00:00
|
|
|
|
`(comp-emit-set-call (comp-callref ',subr-name ,nargs (comp-sp)))
|
2019-07-20 13:49:30 +00:00
|
|
|
|
;; Normal call.
|
|
|
|
|
(cl-assert (and (>= maxarg nargs) (<= minarg nargs))
|
|
|
|
|
(nargs maxarg minarg)
|
|
|
|
|
"Incoherent stack adjustment %d, maxarg %d minarg %d")
|
2019-08-19 15:08:44 +00:00
|
|
|
|
`(let* ((subr-name ',subr-name)
|
2019-07-20 13:49:30 +00:00
|
|
|
|
(slots (cl-loop for i from 0 below ,maxarg
|
|
|
|
|
collect (comp-slot-n (+ i (comp-sp))))))
|
2019-08-19 15:59:20 +00:00
|
|
|
|
(comp-emit-set-call (apply #'comp-call (cons subr-name slots))))))))
|
2019-07-14 18:25:42 +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."
|
|
|
|
|
(comp-with-sp (if dst-n dst-n (comp-sp))
|
|
|
|
|
(let ((src-slot (comp-slot-n src-n)))
|
|
|
|
|
(cl-assert src-slot)
|
|
|
|
|
;; FIXME id should encrease here.
|
|
|
|
|
(setf (comp-slot)
|
|
|
|
|
(copy-sequence src-slot))
|
|
|
|
|
(setf (comp-mvar-slot (comp-slot)) (comp-sp))
|
|
|
|
|
(comp-emit (list 'set (comp-slot) src-slot)))))
|
2019-07-08 07:06:58 +00:00
|
|
|
|
|
2019-07-10 16:55:19 +00:00
|
|
|
|
(defun comp-emit-annotation (str)
|
|
|
|
|
"Emit annotation STR."
|
2019-07-13 14:34:59 +00:00
|
|
|
|
(comp-emit `(comment ,str)))
|
2019-07-10 16:55:19 +00:00
|
|
|
|
|
2019-07-14 18:25:42 +00:00
|
|
|
|
(defun comp-emit-set-const (val)
|
2019-07-13 16:28:00 +00:00
|
|
|
|
"Set constant VAL to current slot."
|
2019-08-18 19:39:09 +00:00
|
|
|
|
(let ((rel-idx (comp-add-const-to-relocs val)))
|
2019-09-01 15:02:35 +00:00
|
|
|
|
(cl-assert (numberp rel-idx))
|
2019-08-18 19:39:09 +00:00
|
|
|
|
(setf (comp-slot) (make-comp-mvar :slot (comp-sp)
|
|
|
|
|
:constant val))
|
2019-08-18 21:09:20 +00:00
|
|
|
|
(comp-emit `(setimm ,(comp-slot) ,rel-idx ,val))))
|
2019-07-08 15:04:33 +00:00
|
|
|
|
|
2019-07-14 16:36:57 +00:00
|
|
|
|
(defun comp-mark-block-closed ()
|
|
|
|
|
"Mark current basic block as closed."
|
2019-07-14 18:54:53 +00:00
|
|
|
|
(setf (comp-block-closed (gethash (comp-limplify-block-name comp-pass)
|
2019-07-14 16:36:57 +00:00
|
|
|
|
(comp-func-blocks comp-func)))
|
|
|
|
|
t))
|
|
|
|
|
|
|
|
|
|
(defun comp-emit-jump (target)
|
|
|
|
|
"Emit an unconditional branch to block TARGET."
|
|
|
|
|
(comp-emit (list 'jump target))
|
|
|
|
|
(comp-mark-block-closed))
|
|
|
|
|
|
2019-07-14 15:21:34 +00:00
|
|
|
|
(defun comp-emit-block (block-name)
|
|
|
|
|
"Emit basic block BLOCK-NAME."
|
2019-07-14 16:36:57 +00:00
|
|
|
|
(let ((blocks (comp-func-blocks comp-func)))
|
|
|
|
|
;; In case does not exist register it into comp-func-blocks.
|
|
|
|
|
(unless (gethash block-name blocks)
|
|
|
|
|
(puthash block-name
|
|
|
|
|
(make-comp-block :sp (comp-sp))
|
|
|
|
|
blocks))
|
|
|
|
|
;; If we are abandoning an non closed basic block close it with a fall
|
|
|
|
|
;; through.
|
|
|
|
|
(when (and (not (eq block-name 'entry))
|
2019-07-21 13:20:39 +00:00
|
|
|
|
(not (comp-block-closed
|
|
|
|
|
(gethash (comp-limplify-block-name comp-pass)
|
|
|
|
|
blocks))))
|
2019-07-14 16:36:57 +00:00
|
|
|
|
(comp-emit-jump block-name))
|
2019-07-21 13:20:39 +00:00
|
|
|
|
;; Set this a currently compiled block.
|
|
|
|
|
(setf comp-block (gethash block-name blocks))
|
2019-07-14 16:36:57 +00:00
|
|
|
|
;; Every new block we are forced to wipe out all the frame.
|
|
|
|
|
;; This will be optimized by proper flow analysis.
|
2019-07-14 18:54:53 +00:00
|
|
|
|
(setf (comp-limplify-frame comp-pass)
|
|
|
|
|
(comp-new-frame (comp-func-frame-size comp-func)))
|
2019-07-14 16:36:57 +00:00
|
|
|
|
;; If we are landing here form a recorded branch adjust sp accordingly.
|
|
|
|
|
(setf (comp-sp)
|
|
|
|
|
(comp-block-sp (gethash block-name blocks)))
|
2019-07-14 18:54:53 +00:00
|
|
|
|
(setf (comp-limplify-block-name comp-pass) block-name)))
|
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-08-03 15:08:55 +00:00
|
|
|
|
If NEGATED non nil negate the tested condition."
|
2019-07-21 07:48:52 +00:00
|
|
|
|
(let ((blocks (comp-func-blocks comp-func))
|
|
|
|
|
(bb (comp-new-block-sym))) ;; Fall through block
|
2019-07-14 16:36:57 +00:00
|
|
|
|
(puthash bb
|
2019-07-21 07:48:52 +00:00
|
|
|
|
(make-comp-block :sp (comp-sp))
|
2019-07-14 16:36:57 +00:00
|
|
|
|
blocks)
|
2019-07-21 07:48:52 +00:00
|
|
|
|
(let ((target (comp-lap-to-limple-bb lap-label)))
|
|
|
|
|
(comp-emit (if negated
|
2019-08-03 15:08:55 +00:00
|
|
|
|
(list 'cond-jump a b target bb)
|
|
|
|
|
(list 'cond-jump a b bb target)))
|
2019-07-21 07:48:52 +00:00
|
|
|
|
(puthash target
|
|
|
|
|
(make-comp-block :sp (+ target-offset (comp-sp)))
|
|
|
|
|
blocks)
|
|
|
|
|
(comp-mark-block-closed))
|
2019-07-14 16:36:57 +00:00
|
|
|
|
(comp-emit-block bb)))
|
2019-07-14 12:39:29 +00:00
|
|
|
|
|
2019-07-13 16:28:00 +00:00
|
|
|
|
(defun comp-stack-adjust (n)
|
|
|
|
|
"Move sp by N."
|
|
|
|
|
(cl-incf (comp-sp) n))
|
2019-07-07 10:30:03 +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)
|
|
|
|
|
(comp-slot-next))))))
|
2019-07-14 07:53:06 +00:00
|
|
|
|
|
2019-07-14 12:39:29 +00:00
|
|
|
|
(defun comp-new-block-sym ()
|
|
|
|
|
"Return a symbol naming the next new basic block."
|
2019-07-14 15:21:34 +00:00
|
|
|
|
(intern (format "bb_%s" (hash-table-count (comp-func-blocks comp-func)))))
|
2019-07-14 12:39:29 +00:00
|
|
|
|
|
|
|
|
|
(defun comp-lap-to-limple-bb (n)
|
|
|
|
|
"Given the LAP label N return the limple basic block."
|
|
|
|
|
(let ((hash (comp-func-lap-block comp-func)))
|
|
|
|
|
(if-let ((bb (gethash n hash)))
|
|
|
|
|
;; If was already created return it.
|
|
|
|
|
bb
|
|
|
|
|
(let ((name (comp-new-block-sym)))
|
|
|
|
|
(puthash n name hash)
|
|
|
|
|
name))))
|
|
|
|
|
|
2019-07-22 09:08:53 +00:00
|
|
|
|
(defun comp-emit-handler (guarded-label handler-type)
|
|
|
|
|
"Emit a non local exit handler for GUARDED-LABEL of type HANDLER-TYPE."
|
|
|
|
|
(let ((blocks (comp-func-blocks comp-func))
|
|
|
|
|
(guarded-bb (comp-new-block-sym)))
|
|
|
|
|
(puthash guarded-bb
|
|
|
|
|
(make-comp-block :sp (comp-sp))
|
|
|
|
|
blocks)
|
|
|
|
|
(let ((handler-bb (comp-lap-to-limple-bb guarded-label)))
|
|
|
|
|
(comp-emit (list 'push-handler (comp-slot-next)
|
|
|
|
|
handler-type
|
|
|
|
|
handler-bb
|
|
|
|
|
guarded-bb))
|
|
|
|
|
(puthash handler-bb
|
|
|
|
|
(make-comp-block :sp (1+ (comp-sp)))
|
|
|
|
|
blocks)
|
|
|
|
|
(comp-mark-block-closed)
|
|
|
|
|
(comp-emit-block guarded-bb))))
|
|
|
|
|
|
2019-08-03 15:08:55 +00:00
|
|
|
|
(defun comp-emit-switch (var m-hash)
|
|
|
|
|
"Emit a limple for a lap jump table given VAR and M-HASH."
|
|
|
|
|
(cl-assert (comp-mvar-const-vld m-hash))
|
|
|
|
|
(cl-loop for test being each hash-keys of (comp-mvar-constant m-hash)
|
|
|
|
|
using (hash-value target-label)
|
|
|
|
|
for m-test = (make-comp-mvar :constant test)
|
|
|
|
|
do (comp-emit-cond-jump var m-test 0 target-label nil)))
|
|
|
|
|
|
2019-08-16 08:38:51 +00:00
|
|
|
|
(defun comp-emit-funcall (narg)
|
|
|
|
|
"Avoid Ffuncall trampoline if possibile.
|
|
|
|
|
NARG is the number of Ffuncall arguments."
|
|
|
|
|
(comp-stack-adjust (- narg))
|
|
|
|
|
(let* ((callee (comp-slot))
|
|
|
|
|
(callee-sym-name (comp-mvar-constant callee))
|
|
|
|
|
(optimize nil)
|
|
|
|
|
(callref nil))
|
|
|
|
|
(and (comp-mvar-const-vld callee)
|
|
|
|
|
(or (and (>= comp-speed 2)
|
|
|
|
|
(eq callee-sym-name (comp-func-symbol-name comp-func))
|
|
|
|
|
(setq optimize t)
|
|
|
|
|
(setq callref (comp-nargs-p (comp-func-args comp-func))))
|
|
|
|
|
;; (and (>= comp-speed 3)
|
|
|
|
|
;; (symbol-function callee-sym-name)
|
|
|
|
|
;; (subrp (symbol-function callee-sym-name))
|
|
|
|
|
;; (setq optimize t)
|
|
|
|
|
;; (setq callref (eq 'many
|
|
|
|
|
;; (cdr (subr-arity
|
|
|
|
|
;; (symbol-function callee-sym-name)))))
|
|
|
|
|
;; (setf callee-sym-name ))
|
|
|
|
|
))
|
|
|
|
|
(if optimize
|
|
|
|
|
(if callref
|
2019-09-01 10:29:13 +00:00
|
|
|
|
(comp-emit-set-call (comp-callref callee-sym-name
|
|
|
|
|
narg (1+ (comp-sp))))
|
2019-08-16 08:38:51 +00:00
|
|
|
|
(comp-emit-set-call `(call ,callee-sym-name
|
|
|
|
|
,@(cl-loop for i from (1+ (comp-sp))
|
|
|
|
|
repeat narg
|
|
|
|
|
collect (comp-slot-n i)))))
|
2019-09-01 10:29:13 +00:00
|
|
|
|
(comp-emit-set-call (comp-callref 'funcall (1+ narg) (comp-sp))))))
|
2019-08-16 08:38:51 +00:00
|
|
|
|
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(defmacro comp-op-case (&rest cases)
|
2019-07-14 18:25:42 +00:00
|
|
|
|
"Expand CASES into the corresponding pcase.
|
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-07-20 14:44:40 +00:00
|
|
|
|
(cl-labels ((op-to-fun (x)
|
|
|
|
|
;; Given the LAP op strip "byte-" to have the subr name.
|
|
|
|
|
(intern (replace-regexp-in-string "byte-" "" x)))
|
|
|
|
|
(body-eff (body op-name sp-delta)
|
|
|
|
|
;; Given the original body BODY compute the effective one.
|
2019-07-20 15:35:57 +00:00
|
|
|
|
;; When BODY is auto guess function name form the LAP bytecode
|
|
|
|
|
;; name. Othewise expect lname fnname.
|
2019-07-20 14:44:40 +00:00
|
|
|
|
(pcase (car body)
|
|
|
|
|
('auto
|
|
|
|
|
(list `(comp-emit-set-call-subr
|
|
|
|
|
,(op-to-fun op-name)
|
|
|
|
|
,sp-delta)))
|
|
|
|
|
((pred symbolp)
|
|
|
|
|
(list `(comp-emit-set-call-subr
|
|
|
|
|
,(car body)
|
2019-08-19 15:08:44 +00:00
|
|
|
|
,sp-delta)))
|
2019-07-20 14:44:40 +00:00
|
|
|
|
(_ body))))
|
2019-07-14 21:35:04 +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
|
2019-07-20 15:35:57 +00:00
|
|
|
|
;; Log all LAP ops except the TAG one.
|
2019-07-14 21:35:04 +00:00
|
|
|
|
,(unless (eq op 'TAG)
|
|
|
|
|
`(comp-emit-annotation
|
|
|
|
|
,(concat "LAP op " op-name)))
|
2019-07-20 15:35:57 +00:00
|
|
|
|
;; Emit the stack adjustment if present.
|
2019-07-20 13:49:30 +00:00
|
|
|
|
,(when (and sp-delta (not (eq 0 sp-delta)))
|
2019-07-14 21:35:04 +00:00
|
|
|
|
`(comp-stack-adjust ,sp-delta))
|
2019-07-20 14:44:40 +00:00
|
|
|
|
,@(body-eff body op-name sp-delta))
|
2019-07-14 21:35:04 +00:00
|
|
|
|
else
|
|
|
|
|
collect `(',op (error ,(concat "Unsupported LAP op "
|
|
|
|
|
op-name))))
|
|
|
|
|
(_ (error "Unexpected LAP op %s" (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)
|
|
|
|
|
"Limplify LAP instruction INSN pushng it in the proper basic block."
|
|
|
|
|
(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
|
|
|
|
|
(comp-emit-block (comp-lap-to-limple-bb arg)))
|
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)
|
|
|
|
|
(comp-slot))))
|
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)
|
|
|
|
|
(comp-slot-next))))
|
2019-07-14 09:15:18 +00:00
|
|
|
|
(byte-call
|
2019-08-16 08:38:51 +00:00
|
|
|
|
(comp-emit-funcall arg))
|
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-07-22 09:08:53 +00:00
|
|
|
|
(comp-emit-handler (cl-third insn) 'condition-case))
|
|
|
|
|
(byte-pushcatch
|
|
|
|
|
(comp-emit-handler (cl-third 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-08-19 16:22:26 +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-08-19 16:22:26 +00:00
|
|
|
|
(comp-emit-set-call (comp-call 'narrow_to_region
|
2019-08-19 15:59:20 +00:00
|
|
|
|
(comp-slot)
|
|
|
|
|
(comp-slot-next))))
|
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-08-11 12:41:35 +00:00
|
|
|
|
(byte-constant2) ;; TODO
|
2019-07-14 12:39:29 +00:00
|
|
|
|
(byte-goto
|
2019-07-22 09:08:53 +00:00
|
|
|
|
(comp-emit-jump (comp-lap-to-limple-bb (cl-third insn))))
|
2019-07-14 12:39:29 +00:00
|
|
|
|
(byte-goto-if-nil
|
2019-08-03 15:08:55 +00:00
|
|
|
|
(comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 0
|
|
|
|
|
(cl-third insn) nil))
|
2019-07-14 12:39:29 +00:00
|
|
|
|
(byte-goto-if-not-nil
|
2019-08-03 15:08:55 +00:00
|
|
|
|
(comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 0
|
|
|
|
|
(cl-third insn) t))
|
2019-07-14 12:39:29 +00:00
|
|
|
|
(byte-goto-if-nil-else-pop
|
2019-08-03 15:08:55 +00:00
|
|
|
|
(comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1
|
|
|
|
|
(cl-third insn) nil))
|
2019-07-14 12:39:29 +00:00
|
|
|
|
(byte-goto-if-not-nil-else-pop
|
2019-08-03 15:08:55 +00:00
|
|
|
|
(comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1
|
|
|
|
|
(cl-third insn) t))
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(byte-return
|
2019-08-08 15:35:25 +00:00
|
|
|
|
(comp-emit `(return ,(comp-slot-next)))
|
2019-07-14 16:36:57 +00:00
|
|
|
|
(comp-mark-block-closed))
|
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-08-19 15:59:20 +00:00
|
|
|
|
(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-08-19 15:59:20 +00:00
|
|
|
|
(comp-emit (comp-call 'helper_unwind_protect (comp-slot-next))))
|
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-07-20 17:26:30 +00:00
|
|
|
|
(comp-stack-adjust (- 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-07-20 17:26:30 +00:00
|
|
|
|
(comp-stack-adjust (- 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-07-20 17:26:30 +00:00
|
|
|
|
(comp-stack-adjust (- 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
|
|
|
|
|
(comp-with-sp (1+ (comp-sp))
|
|
|
|
|
(comp-copy-slot (comp-sp) (- (comp-sp) arg))))
|
2019-08-11 12:41:35 +00:00
|
|
|
|
(byte-stack-set2) ;; TODO
|
2019-07-20 17:26:30 +00:00
|
|
|
|
(byte-discardN
|
|
|
|
|
(comp-stack-adjust (- arg)))
|
2019-08-03 15:08:55 +00:00
|
|
|
|
(byte-switch
|
|
|
|
|
(comp-emit-switch (comp-slot-next) (comp-slot-n (+ 2 (comp-sp)))))
|
2019-07-14 07:53:06 +00:00
|
|
|
|
(byte-constant
|
2019-07-20 16:50:41 +00:00
|
|
|
|
(comp-emit-set-const arg))
|
|
|
|
|
(byte-discardN-preserve-tos
|
|
|
|
|
(comp-stack-adjust (- arg))
|
2019-07-20 17:26:30 +00:00
|
|
|
|
(comp-copy-slot (+ arg (comp-sp)))))))
|
2019-07-07 10:30:03 +00:00
|
|
|
|
|
2019-08-11 17:03:06 +00:00
|
|
|
|
(defun comp-emit-narg-prologue (minarg nonrest)
|
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-08-11 14:44:12 +00:00
|
|
|
|
do (progn
|
|
|
|
|
(comp-emit `(set-args-to-local ,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))
|
|
|
|
|
do (progn
|
|
|
|
|
(comp-emit `(cond-jump-narg-leq ,i ,bb ,fallback))
|
|
|
|
|
(comp-mark-block-closed)
|
|
|
|
|
(comp-emit-block bb)
|
|
|
|
|
(comp-emit `(set-args-to-local ,i))
|
|
|
|
|
(comp-emit '(inc-args)))
|
|
|
|
|
finally (comp-emit-jump 'entry_rest_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
|
|
|
|
do (comp-with-sp i
|
|
|
|
|
(comp-emit-block (intern (format "entry_fallback_%s" i)))
|
|
|
|
|
(comp-emit-set-const nil)))
|
|
|
|
|
(comp-emit-block 'entry_rest_args)
|
2019-08-11 17:03:06 +00:00
|
|
|
|
(comp-emit `(set-rest-args-to-local ,nonrest)))
|
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))))
|
|
|
|
|
(comp-log-func func)
|
|
|
|
|
func)
|
|
|
|
|
|
|
|
|
|
(defun comp-limplify-top-level ()
|
|
|
|
|
"Create a limple function doing the business for top level forms.
|
|
|
|
|
This will be called at runtime."
|
|
|
|
|
(let* ((func (make-comp-func :symbol-name 'top-level-run
|
|
|
|
|
:c-func-name "top_level_run"
|
|
|
|
|
:args (make-comp-args :min 0 :max 0)
|
|
|
|
|
:frame-size 0))
|
|
|
|
|
(comp-func func)
|
|
|
|
|
(comp-pass (make-comp-limplify
|
|
|
|
|
:sp -1
|
|
|
|
|
:frame (comp-new-frame 0)))
|
|
|
|
|
(comp-block ()))
|
|
|
|
|
(comp-emit-block 'entry)
|
|
|
|
|
(comp-emit-annotation "Top level")
|
|
|
|
|
(cl-loop for args in (comp-ctxt-top-level-defvars comp-ctxt)
|
|
|
|
|
do (comp-emit (comp-call 'defvar (make-comp-mvar :constant args))))
|
|
|
|
|
(comp-emit `(return ,(make-comp-mvar :constant nil)))
|
|
|
|
|
(comp-limplify-finalize-function func)))
|
|
|
|
|
|
|
|
|
|
(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
|
|
|
|
|
:sp -1
|
|
|
|
|
:frame (comp-new-frame frame-size)))
|
|
|
|
|
(args (comp-func-args func))
|
|
|
|
|
(args-min (comp-args-base-min args))
|
|
|
|
|
(comp-block ()))
|
|
|
|
|
;; Prologue
|
|
|
|
|
(comp-emit-block 'entry)
|
|
|
|
|
(comp-emit-annotation (concat "Lisp function: "
|
|
|
|
|
(symbol-name (comp-func-symbol-name func))))
|
|
|
|
|
(if (comp-args-p args)
|
|
|
|
|
(cl-loop for i below (comp-args-max args)
|
|
|
|
|
do (cl-incf (comp-sp))
|
|
|
|
|
do (comp-emit `(set-par-to-local ,(comp-slot) ,i)))
|
|
|
|
|
(let ((nonrest (comp-nargs-nonrest args)))
|
|
|
|
|
(comp-emit-narg-prologue args-min nonrest)
|
|
|
|
|
(cl-incf (comp-sp) (1+ nonrest))))
|
|
|
|
|
;; Body
|
|
|
|
|
(comp-emit-block 'bb_1)
|
|
|
|
|
(mapc #'comp-limplify-lap-inst (comp-func-lap func))
|
|
|
|
|
(comp-limplify-finalize-function func)))
|
|
|
|
|
|
2019-09-07 06:18:08 +00:00
|
|
|
|
(defun comp-limplify (funcs)
|
2019-09-07 14:35:07 +00:00
|
|
|
|
"Compute the LIMPLE ir for FUNCS.
|
|
|
|
|
Top level forms for the current context are rendered too."
|
|
|
|
|
(cons (comp-limplify-top-level)
|
|
|
|
|
(mapcar #'comp-limplify-function funcs)))
|
2019-07-07 07:23:10 +00:00
|
|
|
|
|
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
|
|
|
|
|
|
|
|
|
(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.
|
|
|
|
|
Prepare every functions for final compilation and drive the C side."
|
2019-08-18 15:17:56 +00:00
|
|
|
|
(cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt))
|
|
|
|
|
(hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt))))
|
|
|
|
|
(setf (comp-ctxt-funcs comp-ctxt)
|
2019-09-02 15:05:15 +00:00
|
|
|
|
(cl-loop with h = (comp-ctxt-funcs-h comp-ctxt)
|
|
|
|
|
for f being each hash-value of h
|
|
|
|
|
for args = (comp-func-args f)
|
|
|
|
|
for doc = (when (> (length (comp-func-byte-func f))
|
|
|
|
|
4)
|
|
|
|
|
(aref (comp-func-byte-func f) 4))
|
|
|
|
|
collect (vector (comp-func-symbol-name f)
|
|
|
|
|
(comp-func-c-func-name f)
|
|
|
|
|
(cons (comp-args-base-min args)
|
|
|
|
|
(if (comp-args-p args)
|
|
|
|
|
(comp-args-max args)
|
|
|
|
|
'many))
|
|
|
|
|
doc)))
|
2019-08-18 15:17:56 +00:00
|
|
|
|
(comp--compile-ctxt-to-file name))
|
|
|
|
|
|
|
|
|
|
(defun comp-add-func-to-ctxt (func)
|
|
|
|
|
"Add FUNC to the current compiler contex."
|
2019-08-18 21:09:20 +00:00
|
|
|
|
(puthash (comp-func-symbol-name func)
|
|
|
|
|
func
|
2019-09-07 06:57:07 +00:00
|
|
|
|
(comp-ctxt-funcs-h comp-ctxt)))
|
|
|
|
|
|
|
|
|
|
(defun comp-final (data)
|
|
|
|
|
"Final pass driving DATA into the C side for code emission."
|
|
|
|
|
(let (compile-result)
|
|
|
|
|
(comp--init-ctxt)
|
|
|
|
|
(unwind-protect
|
|
|
|
|
(progn
|
|
|
|
|
(mapc #'comp-add-func-to-ctxt data)
|
|
|
|
|
(setq compile-result
|
|
|
|
|
(comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt))))
|
|
|
|
|
(and (comp--release-ctxt)
|
|
|
|
|
compile-result))))
|
2019-08-18 15:17:56 +00:00
|
|
|
|
|
2019-07-21 11:57:51 +00:00
|
|
|
|
|
|
|
|
|
;;; Entry points.
|
|
|
|
|
|
2019-09-07 06:18:08 +00:00
|
|
|
|
(defun native-compile (input)
|
|
|
|
|
"Compile INPUT into native code.
|
|
|
|
|
This is the entrypoint for the Emacs Lisp native compiler.
|
2019-09-07 09:17:02 +00:00
|
|
|
|
If INPUT is a symbol, native-compile its function definition.
|
|
|
|
|
If INPUT is a string, use it as the file path to be native compiled."
|
2019-09-07 06:57:07 +00:00
|
|
|
|
(unless (or (symbolp input)
|
|
|
|
|
(stringp input))
|
2019-09-07 09:17:02 +00:00
|
|
|
|
(error "Trying to native compile something not a symbol function or file"))
|
2019-09-07 06:18:08 +00:00
|
|
|
|
(let ((data input)
|
2019-09-07 06:57:07 +00:00
|
|
|
|
(comp-ctxt (make-comp-ctxt :output (if (symbolp input)
|
|
|
|
|
(symbol-name input)
|
|
|
|
|
(file-name-sans-extension input)))))
|
2019-09-07 06:18:08 +00:00
|
|
|
|
(mapc (lambda (pass)
|
|
|
|
|
(setq data (funcall pass data)))
|
2019-09-07 06:57:07 +00:00
|
|
|
|
comp-passes)))
|
2019-07-07 07:23:10 +00:00
|
|
|
|
|
|
|
|
|
(provide 'comp)
|
|
|
|
|
|
|
|
|
|
;;; comp.el ends here
|