masscollaborationlabs/emacs
2
0
Fork 0
mirror of https://github.com/masscollaborationlabs/emacs.git synced 2025-07-05 19:59:38 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

comp: Recompute type slots after byte compilation for user types

Browse source 
* lisp/emacs-lisp/comp-cstr.el (comp--compute-typeof-types)
(comp--compute--pred-type-h): New functions.
(comp-cstr-ctxt): Make use of.
(comp-cstr-ctxt-update-type-slots): New function.

* lisp/emacs-lisp/comp.el (comp-spill-lap): Use
`comp-cstr-ctxt-update-type-slots'.
This commit is contained in:
Andrea Corallo 2023-05-28 14:49:19 +02:00
parent edcdb4c2ec
commit 56a8d57d03
2 changed files with 30 additions and 13 deletions
Download patch file Download diff file Expand all files Collapse all files

29
lisp/emacs-lisp/comp-cstr.el
View file

@ -102,17 +102,23 @@ Integer values are handled in the `range' slot.")
obarray) obarray)
res)) res))
(cl-defstruct comp-cstr-ctxt (defun comp--compute-typeof-types ()
(typeof-types (append comp--typeof-builtin-types (append comp--typeof-builtin-types
(mapcar #'comp--cl-class-hierarchy (comp--all-classes))) (mapcar #'comp--cl-class-hierarchy (comp--all-classes))))
:type list
:documentation "Type hierarchy.") (defun comp--compute--pred-type-h ()
(pred-type-h (cl-loop with h = (make-hash-table :test #'eq) (cl-loop with h = (make-hash-table :test #'eq)
for class-name in (comp--all-classes) for class-name in (comp--all-classes)
for pred = (get class-name 'cl-deftype-satisfies) for pred = (get class-name 'cl-deftype-satisfies)
when pred when pred
do (puthash pred class-name h) do (puthash pred class-name h)
finally return h) finally return h))
(cl-defstruct comp-cstr-ctxt
(typeof-types (comp--compute-typeof-types)
:type list
:documentation "Type hierarchy.")
(pred-type-h (comp--compute--pred-type-h)
:type hash-table :type hash-table
:documentation "Hash pred -> type.") :documentation "Hash pred -> type.")
(union-typesets-mem (make-hash-table :test #'equal) :type hash-table (union-typesets-mem (make-hash-table :test #'equal) :type hash-table
@ -135,6 +141,15 @@ Integer values are handled in the `range' slot.")
:documentation "Serve memoization for :documentation "Serve memoization for
`intersection-mem'.")) `intersection-mem'."))
(defun comp-cstr-ctxt-update-type-slots (ctxt)
"Update the type related slots of CTXT.
This must run after byte compilation in order to account for user
defined types."
(setf (comp-cstr-ctxt-typeof-types ctxt)
(comp--compute-typeof-types))
(setf (comp-cstr-ctxt-pred-type-h ctxt)
(comp--compute--pred-type-h)))
(defmacro with-comp-cstr-accessors (&rest body) (defmacro with-comp-cstr-accessors (&rest body)
"Define some quick accessor to reduce code vergosity in BODY." "Define some quick accessor to reduce code vergosity in BODY."
(declare (debug (form body)) (declare (debug (form body))

8
lisp/emacs-lisp/comp.el
View file

@ -1431,11 +1431,13 @@ clashes."
"Byte-compile and spill the LAP representation for INPUT. "Byte-compile and spill the LAP representation for INPUT.
If INPUT is a symbol, it is the function-name to be compiled. If INPUT is a symbol, it is the function-name to be compiled.
If INPUT is a string, it is the filename to be compiled." If INPUT is a string, it is the filename to be compiled."
(let ((byte-native-compiling t) (let* ((byte-native-compiling t)
(byte-to-native-lambdas-h (make-hash-table :test #'eq)) (byte-to-native-lambdas-h (make-hash-table :test #'eq))
(byte-to-native-top-level-forms ()) (byte-to-native-top-level-forms ())
(byte-to-native-plist-environment ())) (byte-to-native-plist-environment ())
(comp-spill-lap-function input))) (res (comp-spill-lap-function input)))
(comp-cstr-ctxt-update-type-slots comp-ctxt)
res))
;;; Limplification pass specific code. ;;; Limplification pass specific code.