mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-05 11:45:45 +00:00
Code Issues Releases Activity

improve relocation collection

Browse Source
This commit is contained in:
Andrea Corallo 2019-08-18 15:36:36 +02:00 committed by Andrea Corallo
parent f5ab0db4b0
commit 765e57e2d2
1 changed files with 37 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
lisp/emacs-lisp/comp.el
View File

@ -76,6 +76,18 @@
finally return h) finally return h)
"Hash table lap-op -> stack adjustment.")) "Hash table lap-op -> stack adjustment."))
(cl-defstruct comp-ctxt
(data-relocs () :type string
:documentation "Final data relocations.")
(data-relocs-l () :type list
:documentation "Constant objects used by functions.")
(data-relocs-idx (make-hash-table :test #'equal) :type hash-table
:documentation "Obj -> position into data-relocs.")
(func-relocs () :type list
:documentation "Native functions imported.")
(func-relocs-idx (make-hash-table :test #'equal) :type hash-table
:documentation "Obj -> position into func-relocs."))
(cl-defstruct comp-args-base (cl-defstruct comp-args-base
(min nil :type number (min nil :type number
:documentation "Minimum number of arguments allowed.")) :documentation "Minimum number of arguments allowed."))
@ -148,6 +160,25 @@ LIMPLE basic block.")
(block-name nil :type symbol (block-name nil :type symbol
:documentation "Current basic block name.")) :documentation "Current basic block name."))
(defvar comp-ctxt) ;; FIXME (to be removed)
(defun comp-add-const-to-relocs (obj)
"Keep track of OBJ into relocations.
The corresponding index into it is returned."
(let ((data-relocs-idx (comp-ctxt-data-relocs-idx comp-ctxt)))
(unless (gethash obj data-relocs-idx)
(push obj (comp-ctxt-data-relocs-l comp-ctxt))
(puthash obj (hash-table-count data-relocs-idx) data-relocs-idx))))
(defun comp-compile-ctxt-to-file (name)
"Compile as native code the current context naming it NAME."
(cl-assert (= (length (comp-ctxt-data-relocs-l comp-ctxt))
(hash-table-count (comp-ctxt-data-relocs-idx comp-ctxt))))
(setf (comp-ctxt-data-relocs comp-ctxt)
(prin1-to-string (vconcat (reverse (comp-ctxt-data-relocs-l comp-ctxt)))))
(comp--compile-ctxt-to-file name))
(defmacro comp-within-log-buff (&rest body) (defmacro comp-within-log-buff (&rest body)
"Execute BODY while at the end the log-buffer. "Execute BODY while at the end the log-buffer.
BODY is evaluate only if `comp-debug' is non nil." BODY is evaluate only if `comp-debug' is non nil."
@ -346,6 +377,7 @@ If DST-N is specified use it otherwise assume it to be the current slot."
(defun comp-emit-set-const (val) (defun comp-emit-set-const (val)
"Set constant VAL to current slot." "Set constant VAL to current slot."
(comp-add-const-to-relocs val)
(setf (comp-slot) (make-comp-mvar :slot (comp-sp) (setf (comp-slot) (make-comp-mvar :slot (comp-sp)
:constant val)) :constant val))
(comp-emit (list 'setimm (comp-slot) val))) (comp-emit (list 'setimm (comp-slot) val)))
@ -802,16 +834,17 @@ the annotation emission."
(let ((func (make-comp-func :symbol-name func-symbol-name (let ((func (make-comp-func :symbol-name func-symbol-name
:func f :func f
:c-func-name (comp-c-func-name :c-func-name (comp-c-func-name
func-symbol-name)))) func-symbol-name)))
(comp-ctxt (make-comp-ctxt)))
(mapc (lambda (pass) (mapc (lambda (pass)
(funcall pass func)) (funcall pass func))
comp-passes) comp-passes)
;; Once we have the final LIMPLE we jump into C. ;; Once we have the final LIMPLE we jump into C.
(comp-init-ctxt) (comp--init-ctxt)
(comp-add-func-to-ctxt func) (comp--add-func-to-ctxt func)
(comp-compile-ctxt-to-file (symbol-name func-symbol-name)) (comp-compile-ctxt-to-file (symbol-name func-symbol-name))
;; (comp-compile-and-load-ctxt) ;; (comp-compile-and-load-ctxt)
(comp-release-ctxt))) (comp--release-ctxt)))
(error "Trying to native compile something not a function"))) (error "Trying to native compile something not a function")))
(provide 'comp) (provide 'comp)