* MPS codegen (was: MPS: Update)
2024-06-12 8:00 ` Gerd Möllmann
@ 2024-06-13 9:07 ` Helmut Eller
2024-06-13 12:33 ` MPS codegen Gerd Möllmann
0 siblings, 1 reply; 62+ messages in thread
From: Helmut Eller @ 2024-06-13 9:07 UTC (permalink / raw)
To: Gerd Möllmann; +Cc: Eli Zaretskii, emacs-devel
[-- Attachment #1: Type: text/plain, Size: 293 bytes --]
The patches below use a code generator for most of the fix an mirror
functions. I dropped tree-sitter for now; maybe it can be used for
something later. The code generator is about 800 lines and the
generated code 1600. However the generated code is longer than hand
written code. WDYT?
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-WIP-Generate-code-for-scan-methods.patch --]
[-- Type: text/x-diff, Size: 40454 bytes --]
From 19f992b8ea59c2c106da2caf8c6208c16252ea97 Mon Sep 17 00:00:00 2001
From: Helmut Eller <eller.helmut@gmail.com>
Date: Fri, 7 Jun 2024 14:09:48 +0200
Subject: [PATCH 1/5] WIP Generate code for scan methods
* admin/igc-codegen.el: New file.
* src/Makefile.in: New rule for igc-generated.c
* srg/igc.c: Include the generated code.
---
admin/igc-codegen.el | 625 +++++++++++++++++++++++++++++++++++++++++++
src/Makefile.in | 3 +
src/igc.c | 353 ++++++++++++++++++------
3 files changed, 904 insertions(+), 77 deletions(-)
create mode 100644 admin/igc-codegen.el
diff --git a/admin/igc-codegen.el b/admin/igc-codegen.el
new file mode 100644
index 00000000000..cefe4111866
--- /dev/null
+++ b/admin/igc-codegen.el
@@ -0,0 +1,625 @@
+;; -*- lexical-binding: t -*-
+
+(require 'treesit)
+(require 'project)
+
+(defmacro igccg--define-record (name &rest fields)
+ (let* ((constructor (intern (format "igccg--make-%s" name)))
+ (conc-name (intern (format "igccg--%s." name)))
+ (tag-name (intern (format "igccg--%s" name))))
+ `(cl-defstruct (,tag-name
+ (:constructor ,constructor (,@fields))
+ (:constructor nil)
+ (:conc-name ,conc-name)
+ (:predicate nil)
+ (:copier nil)
+ (:noinline))
+ ,@(mapcar (lambda (field)
+ `(,field nil :read-only t))
+ fields))))
+
+(igccg--define-record layout name header pvectype tag ctype fields)
+
+(defun igccg--arg-decl (name type)
+ (pcase-exhaustive type
+ (`(* ,type) (igccg--arg-decl (format "*%s" name) type))
+ (`(struct ,s) (format "struct %s %s" s name))
+ (`(array ,type) (igccg--arg-decl (format "%s[]" name) type))
+ (`vectorlike_header (igccg--arg-decl name `(struct Lisp_Vector)))
+ ((guard (symbolp type)) (format "%s %s" type name))))
+
+(defun igccg--type-spec (type)
+ (pcase-exhaustive type
+ (`(* ,type) (format "%s*" (igccg--type-spec type)))
+ (`(struct ,s) (format "struct %s" s))
+ (`(array ,type) (format "%s*" (igccg--type-spec type)))
+ (`vectorlike_header (igccg--type-spec `(struct Lisp_Vector)))
+ ((guard (symbolp type)) (symbol-name type))))
+
+(defvar igccg--indent 0)
+
+(defun igccg--emit-line (string)
+ (princ (format "%s%s\n"
+ (make-string igccg--indent ?\s)
+ string)))
+
+(defun igccg--emit-function (rtype name args body)
+ (princ (format "static %s\n%s (%s)\n{\n" rtype name (string-join args ", ")))
+ (let ((igccg--indent 2))
+ (funcall body))
+ (princ "}\n\n"))
+
+(defun igccg--emit-block (body)
+ (igccg--emit-line "{")
+ (let ((igccg--indent (+ 2 igccg--indent)))
+ (funcall body))
+ (igccg--emit-line "}"))
+
+(defun igccg--emit-switch (exp cases)
+ (igccg--emit-line (format "switch (%s)" exp))
+ (igccg--emit-block (lambda ()
+ (dolist (c cases)
+ (igccg--emit-line
+ (cond ((equal (car c) "default") "default:")
+ (t (format "case %s:" (car c)))))
+ (let ((igccg--indent (+ 2 igccg--indent)))
+ (funcall (cdr c))
+ (igccg--emit-line "break;"))))))
+
+(defun igccg--emit-\#if (exp body)
+ (igccg--emit-line (format "#if %s" exp))
+ (funcall body)
+ (igccg--emit-line "#endif"))
+
+(defun igccg--ifdef-exp (exp)
+ (pcase-exhaustive exp
+ ((guard (symbolp exp)) (format "defined %s" exp))
+ (`(or . ,exps) (mapconcat #'igccg--ifdef-exp exps " || "))))
+
+(defun igccg--emit-scan-body (body)
+ (igccg--emit-line "MPS_SCAN_BEGIN (ss)")
+ (igccg--emit-block body)
+ (igccg--emit-line "MPS_SCAN_END (ss);")
+ (igccg--emit-line "return MPS_RES_OK;"))
+
+(defun igccg--field-addr-exp (var path)
+ (pcase-exhaustive path
+ ((guard (symbolp path))
+ (format "&%s->%s" var path))
+ (`(path . ,symbols)
+ (format "&%s->%s" var (mapconcat #'symbol-name symbols ".")))
+ ((guard (stringp path))
+ (format path var))))
+
+(defun igccg--field-value-exp (var path)
+ (pcase-exhaustive path
+ ((guard (symbolp path))
+ (format "%s->%s" var path))
+ (`(path . ,symbols)
+ (format "%s->%s" var (mapconcat #'symbol-name symbols ".")))
+ ((guard (stringp path))
+ (format path var))
+ ('(pvec-header-size)
+ (format "%s->header.size & PSEUDOVECTOR_SIZE_MASK" var))
+ ('(igc-header-len)
+ (format "((struct igc_header *)client_to_base (%s))->nwords \
+- to_words (sizeof (struct igc_header))" var))
+ ('(sub-char-table-len)
+ (format "(%s->header.size & PSEUDOVECTOR_SIZE_MASK)\
+ - SUB_CHAR_TABLE_OFFSET" var))))
+
+(defun igccg--emit-fix-call (ss type var fname)
+ (igccg--emit-line
+ (format "IGC_FIX_CALL_FN (%s, %s, %s, %s);"
+ ss (igccg--type-spec type) var fname)))
+
+(defun igccg--emit-abort ()
+ (igccg--emit-line "emacs_abort ();"))
+
+(defun igccg--emit-fix-field-exp (ss obj exp)
+ (pcase-exhaustive exp
+ (`(tagged ,path)
+ (igccg--emit-line (format "IGC_FIX12_OBJ (%s, %s);"
+ ss (igccg--field-addr-exp obj path))))
+ (`(untagged ,path)
+ (igccg--emit-line (format "IGC_FIX12_RAW (%s, %s);"
+ ss (igccg--field-addr-exp obj path))))
+ (`(switch ,path . ,cases)
+ (igccg--emit-switch
+ (igccg--field-value-exp obj path)
+ (mapcar (lambda (case)
+ (pcase-exhaustive case
+ (`(,tag . ,fields)
+ (cons (symbol-name tag)
+ (lambda ()
+ (mapc (lambda (field)
+ (igccg--emit-fix-field-exp ss obj field))
+ fields))))))
+ cases)))
+ (`(array tagged ,start ,len)
+ (igccg--emit-line
+ (format (concat "IGC_FIX12_NOBJS (%s, %s, %s);")
+ ss
+ (igccg--field-value-exp obj start)
+ (igccg--field-value-exp obj len))))
+ (`(array untagged ,start ,len)
+ (igccg--emit-line
+ (format "size_t len = %s;" (igccg--field-value-exp obj len)))
+ (igccg--emit-line
+ (format "for (void **p = %s, **q = p + len; p < q; p++)"
+ (igccg--field-value-exp obj start)))
+ (igccg--emit-block (lambda ()
+ (igccg--emit-line
+ (format "IGC_FIX12_RAW (%s, p);" ss)))))
+ (`(vectorlike)
+ (igccg--emit-line
+ (format
+ "IGC_FIX12_NOBJS (%s,\
+ (Lisp_Object *)(&%s->header + 1),\
+ %s->header.size & PSEUDOVECTOR_SIZE_MASK);" ss obj obj)))
+ (`(cfg ,test . ,exps)
+ (igccg--emit-\#if (igccg--ifdef-exp test)
+ (lambda ()
+ (mapc (lambda (exp)
+ (igccg--emit-fix-field-exp ss obj exp))
+ exps))))
+ ('(abort)
+ (igccg--emit-abort))
+ ('(frame-quirks)
+ (igccg--emit-line
+ (format "IGC_FIX_CALL_FN (%s, struct frame, %s, fix_frame_quirks);"
+ ss obj)))
+ ('(window-quirks)
+ (igccg--emit-line
+ (format "IGC_FIX_CALL_FN (%s, struct window, %s, fix_window_quirks);"
+ ss obj)))
+ ('(buffer-quirks)
+ (igccg--emit-line
+ (format "IGC_FIX_CALL_FN (%s, struct buffer, %s, fix_buffer_quirks);"
+ ss obj)))
+ ('(terminal-quirks)
+ (igccg--emit-line
+ (format "IGC_FIX_CALL_FN (%s, struct terminal, %s, fix_terminal_quirks);"
+ ss obj)))
+ ('(font-object-quirks)
+ (igccg--emit-line
+ (format "IGC_FIX_CALL_FN (%s, struct font, %s, fix_font_object_quirks);"
+ ss obj)))))
+
+(defun igccg--fix-method-name (layout)
+ (format "fix_%s" (igccg--layout.name layout)))
+
+(defun igccg--scan-vectorlike-method-name (prefix)
+ (format "%s_scan_vectorlike" prefix))
+
+(defun igccg--emit-fix-method (layout)
+ (igccg--emit-function
+ "mps_res_t"
+ (igccg--fix-method-name layout)
+ (list "mps_ss_t ss" (igccg--arg-decl "o"
+ `(* ,(igccg--layout.ctype layout))))
+ (lambda ()
+ (igccg--emit-scan-body
+ (lambda ()
+ (dolist (exp (igccg--layout.fields layout))
+ (igccg--emit-fix-field-exp "ss" "o" exp)))))))
+
+(defun igccg--emit-scan-vectorlike-method (name layouts)
+ (igccg--emit-function
+ "mps_res_t"
+ name
+ (list "mps_ss_t ss" "struct Lisp_Vector *v")
+ (lambda ()
+ (igccg--emit-scan-body
+ (lambda ()
+ (igccg--emit-switch
+ "pseudo_vector_type (v->header)"
+ (append
+ (mapcar (lambda (l)
+ (cons (symbol-name (igccg--layout.pvectype l))
+ (lambda ()
+ (igccg--emit-fix-call
+ "ss" (igccg--layout.ctype l)
+ "v" (igccg--fix-method-name l)))))
+ layouts)
+ (list (cons 'PVEC_FREE (lambda () (igccg--emit-abort)))))))))))
+
+(defun igccg--emit-scan-object-method (prefix layouts)
+ (mapc #'igccg--emit-fix-method layouts)
+ (let* ((alist (seq-group-by #'igccg--layout.header igccg--layouts ))
+ (vectorlike (cdr (assq 'IGC_OBJ_VECTOR alist)))
+ (scan-vectorlike (igccg--scan-vectorlike-method-name prefix)))
+ (igccg--emit-scan-vectorlike-method scan-vectorlike vectorlike)
+ (igccg--emit-function
+ "mps_res_t"
+ (format "%s_scan_object" prefix)
+ (list "mps_ss_t ss" "mps_addr_t base")
+ (lambda ()
+ (igccg--emit-scan-body
+ (lambda ()
+ (igccg--emit-line "mps_addr_t client = base_to_client (base);")
+ (igccg--emit-line "struct igc_header *header = base;")
+ (igccg--emit-switch
+ "header->obj_type"
+ (append
+ (mapcar
+ (lambda (p)
+ (pcase-exhaustive p
+ (`(,type . (,layout))
+ (cons (symbol-name type)
+ (lambda ()
+ (igccg--emit-fix-call
+ "ss" (igccg--layout.ctype layout)
+ "client" (igccg--fix-method-name layout)))))
+ (`(IGC_OBJ_VECTOR . ,_)
+ (cons "IGC_OBJ_VECTOR"
+ (lambda ()
+ (igccg--emit-fix-call "ss" '(struct Lisp_Vector)
+ "client" scan-vectorlike))))))
+ alist)
+ (list
+ (cons "IGC_OBJ_FWD" (lambda ()))
+ (cons "IGC_OBJ_PAD" (lambda ()))
+ (cons "IGC_OBJ_INVALID" (lambda () (igccg--emit-abort))))))))))))
+
+(defvar igccg--layouts
+ (list
+ (igccg--make-layout
+ 'cons 'IGC_OBJ_CONS nil 'Lisp_Cons '(struct Lisp_Cons)
+ '((tagged (path u s car))
+ (tagged (path u s u cdr))))
+
+ (igccg--make-layout
+ 'symbol 'IGC_OBJ_SYMBOL nil 'Lisp_Symbol '(struct Lisp_Symbol)
+ '((tagged (path u s name))
+ (tagged (path u s function))
+ (tagged (path u s plist))
+ (untagged (path u s next))
+ (switch
+ (path u s redirect)
+ (SYMBOL_PLAINVAL (tagged (path u s val value)))
+ (SYMBOL_VARALIAS (untagged (path u s val alias)))
+ (SYMBOL_LOCALIZED (untagged (path u s val blv)))
+ (SYMBOL_FORWARDED
+ (switch
+ "XFWDTYPE (%s->u.s.val.fwd)"
+ (Lisp_Fwd_Int)
+ (Lisp_Fwd_Bool)
+ (Lisp_Fwd_Kboard_Obj)
+ (Lisp_Fwd_Obj
+ (tagged "((struct Lisp_Objfwd *)(%s->u.s.val.fwd.fwdptr))->objvar"))
+ (Lisp_Fwd_Buffer_Obj
+ (tagged
+ "&\
+((struct Lisp_Buffer_Objfwd *)(%s->u.s.val.fwd.fwdptr))\
+->predicate")))))))
+
+ (igccg--make-layout
+ 'interval 'IGC_OBJ_INTERVAL nil nil '(struct interval)
+ '((untagged left)
+ (untagged right)
+ (switch up_obj
+ (default (tagged (path up obj)))
+ (false (untagged (path up interval))))
+ (tagged plist)))
+
+ (igccg--make-layout
+ 'string 'IGC_OBJ_STRING nil 'Lisp_String '(struct Lisp_String)
+ '((untagged (path u s data))
+ (untagged (path u s intervals))))
+
+ (igccg--make-layout
+ 'string_data 'IGC_OBJ_STRING_DATA nil nil '(array uint8_t) nil)
+
+ (igccg--make-layout
+ 'itree_tree 'IGC_OBJ_ITREE_TREE nil nil '(struct itree_tree)
+ '((untagged root)))
+
+ (igccg--make-layout
+ 'itree_node 'IGC_OBJ_ITREE_NODE nil nil '(struct itree_node)
+ '((untagged parent)
+ (untagged left)
+ (untagged right)
+ (tagged data)))
+
+ (igccg--make-layout
+ 'image 'IGC_OBJ_IMAGE nil nil '(struct image)
+ '((tagged spec)
+ (tagged dependencies)
+ (tagged lisp_data)
+ (untagged next)
+ (untagged prev)))
+
+ (igccg--make-layout
+ 'image_cache 'IGC_OBJ_IMAGE_CACHE nil nil '(struct image_cache)
+ '((untagged images)
+ (untagged buckets)))
+
+ (igccg--make-layout
+ 'face 'IGC_OBJ_FACE nil nil '(struct face)
+ '((array tagged lface "ARRAYELTS (%s->lface)")
+ (untagged font)
+ (untagged next)
+ (untagged prev)
+ (untagged ascii_face)
+ (cfg
+ (or HAVE_XFT HAVE_FREETYPE)
+ (untagged extra))))
+
+ (igccg--make-layout
+ 'face_cache 'IGC_OBJ_FACE_CACHE nil nil '(struct face_cache)
+ '((untagged f)
+ (untagged faces_by_id)
+ (untagged buckets)))
+
+ (igccg--make-layout
+ 'float 'IGC_OBJ_FLOAT nil 'Lisp_Float '(struct Lisp_Float)
+ '())
+
+ (igccg--make-layout
+ 'blv 'IGC_OBJ_BLV nil nil '(struct Lisp_Buffer_Local_Value)
+ '((tagged where)
+ (tagged defcell)
+ (tagged valcell)))
+
+ ;; (igccg--make-layout
+ ;; 'weak_ref 'IGC_OBJ_WEAK 'Lisp_Vectorlike '(struct Lisp_Weak_Ref)
+ ;; '((tagged ref)))
+
+ (igccg--make-layout
+ 'ptr_vec 'IGC_OBJ_PTR_VEC nil nil '(* void)
+ '((array untagged "%s" (igc-header-len))))
+
+ (igccg--make-layout
+ 'obj_vec 'IGC_OBJ_OBJ_VEC nil nil 'Lisp_Object
+ '((array tagged "%s" (igc-header-len))))
+
+ (igccg--make-layout
+ 'handler 'IGC_OBJ_HANDLER nil nil '(struct handler)
+ '((tagged tag_or_ch)
+ (tagged val)
+ (untagged next)
+ (untagged nextfree)))
+
+ (igccg--make-layout
+ 'bytes 'IGC_OBJ_BYTES nil nil '(array uint8_t) nil)
+
+ (igccg--make-layout
+ 'normal_vector 'IGC_OBJ_VECTOR 'PVEC_NORMAL_VECTOR 'Lisp_Vectorlike
+ '(struct Lisp_Vector) '((array tagged contents (path header size))))
+
+ (igccg--make-layout
+ 'bignum 'IGC_OBJ_VECTOR 'PVEC_BIGNUM 'Lisp_Vectorlike
+ '(struct Lisp_Bignum) '())
+
+ (igccg--make-layout
+ 'marker 'IGC_OBJ_VECTOR 'PVEC_MARKER 'Lisp_Vectorlike
+ '(struct Lisp_Marker)
+ '((untagged buffer)
+ ;;(untagged next)
+ ))
+
+ (igccg--make-layout
+ 'overlay 'IGC_OBJ_VECTOR 'PVEC_OVERLAY 'Lisp_Vectorlike
+ '(struct Lisp_Overlay)
+ '((untagged buffer)
+ (tagged plist)
+ (untagged interval)))
+
+ (igccg--make-layout
+ 'finalizer 'IGC_OBJ_VECTOR 'PVEC_FINALIZER 'Lisp_Vectorlike
+ '(struct Lisp_Finalizer)
+ '((tagged function)
+ (untagged next)
+ (untagged prev)))
+
+ (igccg--make-layout
+ 'symbol_with_pos 'IGC_OBJ_VECTOR 'PVEC_SYMBOL_WITH_POS 'Lisp_Vectorlike
+ '(struct Lisp_Symbol_With_Pos)
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'misc_ptr 'IGC_OBJ_VECTOR 'PVEC_MISC_PTR 'Lisp_Vectorlike
+ '(struct Lisp_Misc_Ptr)
+ '())
+
+ (igccg--make-layout
+ 'user_ptr 'IGC_OBJ_VECTOR 'PVEC_USER_PTR 'Lisp_Vectorlike
+ '(struct Lisp_User_Ptr)
+ '())
+
+ (igccg--make-layout
+ 'process 'IGC_OBJ_VECTOR 'PVEC_PROCESS 'Lisp_Vectorlike
+ '(struct Lisp_Process)
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'frame 'IGC_OBJ_VECTOR 'PVEC_FRAME 'Lisp_Vectorlike
+ '(struct frame)
+ '((vectorlike)
+ (untagged face_cache)
+ (untagged terminal)
+ (frame-quirks)))
+
+ (igccg--make-layout
+ 'window 'IGC_OBJ_VECTOR 'PVEC_WINDOW 'Lisp_Vectorlike
+ '(struct window)
+ '((vectorlike)
+ (tagged prev_buffers)
+ (tagged next_buffers)
+ (window-quirks)))
+
+ (igccg--make-layout
+ 'bool_vector 'IGC_OBJ_VECTOR 'PVEC_BOOL_VECTOR 'Lisp_Vectorlike
+ '(struct Lisp_Bool_Vector)
+ '())
+
+ (igccg--make-layout
+ 'buffer 'IGC_OBJ_VECTOR 'PVEC_BUFFER 'Lisp_Vectorlike
+ '(struct buffer)
+ '((vectorlike)
+ (untagged (path own_text intervals))
+ (untagged (path own_text markers))
+ (untagged overlays)
+ (untagged base_buffer)
+ (tagged undo_list_)
+ (buffer-quirks)))
+
+ (igccg--make-layout
+ 'hash_table 'IGC_OBJ_VECTOR 'PVEC_HASH_TABLE 'Lisp_Vectorlike
+ '(struct Lisp_Hash_Table)
+ '((untagged key)
+ (untagged value)
+ (untagged hash)
+ (untagged next)
+ (untagged index)))
+
+ (igccg--make-layout
+ 'obarray 'IGC_OBJ_VECTOR 'PVEC_OBARRAY 'Lisp_Vectorlike
+ '(struct Lisp_Obarray)
+ '((untagged buckets)))
+
+ (igccg--make-layout
+ 'terminal 'IGC_OBJ_VECTOR 'PVEC_TERMINAL 'Lisp_Vectorlike
+ '(struct terminal)
+ '((vectorlike)
+ (untagged next_terminal)
+ (cfg HAVE_WINDOW_SYSTEM
+ (untagged image_cache))
+ (terminal-quirks)))
+
+ (igccg--make-layout
+ 'window_configuraion 'IGC_OBJ_VECTOR 'PVEC_WINDOW_CONFIGURATION
+ 'Lisp_Vectorlike
+ 'vectorlike_header
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'subr 'IGC_OBJ_VECTOR 'PVEC_SUBR 'Lisp_Vectorlike
+ '(struct Lisp_Subr)
+ '((tagged command_modes)
+ (cfg
+ HAVE_NATIVE_COMP
+ (tagged (path intspec native))
+ (tagged native_comp_u)
+ (tagged lambda_list)
+ (tagged type))))
+
+ (igccg--make-layout
+ 'other 'IGC_OBJ_VECTOR 'PVEC_OTHER 'Lisp_Vectorlike
+ '(struct scroll_bar)
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'xwidget 'IGC_OBJ_VECTOR 'PVEC_XWIDGET 'Lisp_Vectorlike
+ 'vectorlike_header
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'xwidget_view 'IGC_OBJ_VECTOR 'PVEC_XWIDGET_VIEW 'Lisp_Vectorlike
+ 'vectorlike_header
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'thread 'IGC_OBJ_VECTOR 'PVEC_THREAD 'Lisp_Vectorlike
+ '(struct thread_state)
+ '((vectorlike)
+ (untagged m_current_buffer)
+ (untagged next_thread)
+ (untagged m_handlerlist)))
+
+ (igccg--make-layout
+ 'mutex 'IGC_OBJ_VECTOR 'PVEC_MUTEX 'Lisp_Vectorlike
+ '(struct Lisp_Mutex)
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'condvar 'IGC_OBJ_VECTOR 'PVEC_CONDVAR 'Lisp_Vectorlike
+ '(struct Lisp_CondVar)
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'module_function 'IGC_OBJ_VECTOR 'PVEC_MODULE_FUNCTION 'Lisp_Vectorlike
+ '(struct module_global_reference)
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'module_global_reference 'IGC_OBJ_VECTOR 'PVEC_MODULE_GLOBAL_REFERENCE
+ 'Lisp_Vectorlike
+ 'vectorlike_header
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'comp_unit 'IGC_OBJ_VECTOR 'PVEC_NATIVE_COMP_UNIT
+ 'Lisp_Vectorlike
+ '(struct Lisp_Native_Comp_Unit)
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'ts_parser 'IGC_OBJ_VECTOR 'PVEC_TS_PARSER
+ 'Lisp_Vectorlike
+ '(struct Lisp_TS_Parser)
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'ts_node 'IGC_OBJ_VECTOR 'PVEC_TS_NODE
+ 'Lisp_Vectorlike
+ '(struct Lisp_TS_Node)
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'ts_query 'IGC_OBJ_VECTOR 'PVEC_TS_COMPILED_QUERY
+ 'Lisp_Vectorlike
+ '(struct Lisp_TS_Query)
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'sqlite 'IGC_OBJ_VECTOR 'PVEC_SQLITE
+ 'Lisp_Vectorlike
+ '(struct Lisp_Sqlite)
+ '((vectorlike)))
+
+ ;; (PVEC_WEAK_REF (struct Lisp_Weak_Ref))
+
+ (igccg--make-layout
+ 'closure 'IGC_OBJ_VECTOR 'PVEC_CLOSURE
+ 'Lisp_Vectorlike
+ 'vectorlike_header
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'char_table 'IGC_OBJ_VECTOR 'PVEC_CHAR_TABLE
+ 'Lisp_Vectorlike
+ '(struct Lisp_Char_Table)
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'sub_char_table 'IGC_OBJ_VECTOR 'PVEC_SUB_CHAR_TABLE
+ 'Lisp_Vectorlike
+ '(struct Lisp_Sub_Char_Table)
+ '((array tagged contents (sub-char-table-len))))
+
+ (igccg--make-layout
+ 'record 'IGC_OBJ_VECTOR 'PVEC_RECORD 'Lisp_Vectorlike
+ 'vectorlike_header
+ '((vectorlike)))
+
+ (igccg--make-layout
+ 'font 'IGC_OBJ_VECTOR 'PVEC_FONT 'Lisp_Vectorlike
+ '(struct Lisp_Vector)
+ '((vectorlike)
+ (switch (pvec-header-size)
+ (FONT_SPEC_MAX)
+ (FONT_ENTITY_MAX)
+ (FONT_OBJECT_MAX (font-object-quirks))
+ (default (abort)))))
+ ))
+
+(defun igccg-main ()
+ (igccg--emit-line "/* Generated by igc-codegen.el */")
+ (igccg--emit-line "#pragma GCC diagnostic push")
+ ;;(igccg--emit-line "#pragma GCC diagnostic ignored \"-Wunused-function\"")
+ (igccg--emit-scan-object-method "dflt" igccg--layouts)
+ (igccg--emit-line "#pragma GCC diagnostic pop"))
+
+;; (igccg-main)
diff --git a/src/Makefile.in b/src/Makefile.in
index d9874104327..c0494e4edd0 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -556,6 +556,9 @@ dmpstruct.h:
$(AM_V_GEN)POSIXLY_CORRECT=1 awk -f $(srcdir)/dmpstruct.awk \
$(dmpstruct_headers) > $@
+igc-generated.c: ../admin/igc-codegen.el
+ $(AM_V_GEN) emacs --batch -l $< -f igccg-main > $@
+
AUTO_DEPEND = @AUTO_DEPEND@
DEPDIR = deps
ifeq ($(AUTO_DEPEND),yes)
diff --git a/src/igc.c b/src/igc.c
index 541bbd6614e..c94be5aecef 100644
--- a/src/igc.c
+++ b/src/igc.c
@@ -47,6 +47,7 @@
#include "termhooks.h"
#include "thread.h"
#include "treesit.h"
+#include "process.h"
#include "puresize.h"
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
@@ -528,9 +529,12 @@ object_nelems (void *client, size_t elem_size)
}
static enum pvec_type
-pseudo_vector_type (const struct Lisp_Vector *v)
+pseudo_vector_type (union vectorlike_header header)
{
- return PSEUDOVECTOR_TYPE (v);
+ ptrdiff_t size = header.size;
+ return (size & PSEUDOVECTOR_FLAG
+ ? (size & PVEC_TYPE_MASK) >> PSEUDOVECTOR_AREA_BITS
+ : PVEC_NORMAL_VECTOR);
}
static size_t
@@ -545,7 +549,7 @@ vector_size (const struct Lisp_Vector *v)
static size_t
vector_start (const struct Lisp_Vector *v)
{
- enum pvec_type type = pseudo_vector_type (v);
+ enum pvec_type type = pseudo_vector_type (v->header);
return type == PVEC_SUB_CHAR_TABLE ? SUB_CHAR_TABLE_OFFSET : 0;
}
@@ -718,6 +722,7 @@ scan_staticvec (mps_ss_t ss, void *start, void *end, void *closure)
return MPS_RES_OK;
}
+#if 0
static mps_res_t
fix_fwd (mps_ss_t ss, lispfwd fwd)
{
@@ -750,7 +755,9 @@ fix_fwd (mps_ss_t ss, lispfwd fwd)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_symbol (mps_ss_t ss, struct Lisp_Symbol *sym)
{
@@ -786,6 +793,7 @@ fix_symbol (mps_ss_t ss, struct Lisp_Symbol *sym)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
/* This exists because we need access to a threads' current specpdl
pointer, which means we need access to the thread_state, which can
@@ -805,6 +813,139 @@ scan_igc (mps_ss_t ss, void *start, void *end, void *closure)
return MPS_RES_OK;
}
+static mps_res_t
+fix_frame_quirks (mps_ss_t ss, struct frame *f)
+{
+ MPS_SCAN_BEGIN (ss)
+ {
+#ifdef HAVE_WINDOW_SYSTEM
+ if (FRAME_WINDOW_P (f) && FRAME_OUTPUT_DATA (f))
+ {
+ struct font **font_ptr = &FRAME_FONT (f);
+ if (*font_ptr)
+ IGC_FIX12_RAW (ss, font_ptr);
+ Lisp_Object *nle = &FRAME_DISPLAY_INFO (f)->name_list_element;
+ IGC_FIX12_OBJ (ss, nle);
+
+#ifdef HAVE_NS
+ struct ns_display_info *i = FRAME_DISPLAY_INFO (f);
+ IGC_FIX12_RAW (ss, &i->terminal);
+ IGC_FIX12_OBJ (ss, &i->rdb);
+ IGC_FIX12_RAW (ss, &i->highlight_frame);
+ IGC_FIX12_RAW (ss, &i->ns_focus_frame);
+ IGC_FIX12_RAW (ss, &i->last_mouse_motion_frame);
+ struct frame **pf = ns_emacs_view_emacs_frame (f);
+ IGC_FIX12_RAW (ss, pf);
+#endif
+ }
+#endif // HAVE_WINDOW_SYSTEM
+ }
+ MPS_SCAN_END (ss);
+ return MPS_RES_OK;
+}
+
+static mps_res_t
+fix_glyph_matrix (mps_ss_t ss, struct glyph_matrix *matrix)
+{
+ MPS_SCAN_BEGIN (ss)
+ {
+ struct glyph_row *row = matrix->rows;
+ struct glyph_row *end = row + matrix->nrows;
+
+ for (; row < end; ++row)
+ if (row->enabled_p)
+ for (int area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
+ {
+ struct glyph *glyph = row->glyphs[area];
+ struct glyph *end_glyph = glyph + row->used[area];
+ for (; glyph < end_glyph; ++glyph)
+ IGC_FIX12_OBJ (ss, &glyph->object);
+ }
+ IGC_FIX12_RAW (ss, &matrix->buffer);
+ }
+ MPS_SCAN_END (ss);
+ return MPS_RES_OK;
+}
+
+static mps_res_t
+fix_window_quirks (mps_ss_t ss, struct window *w)
+{
+ MPS_SCAN_BEGIN (ss)
+ {
+ if (w->current_matrix)
+ IGC_FIX_CALL (ss, fix_glyph_matrix (ss, w->current_matrix));
+ if (w->desired_matrix)
+ IGC_FIX_CALL (ss, fix_glyph_matrix (ss, w->desired_matrix));
+
+#ifdef HAVE_NS
+ void *pr[4];
+ int n = ns_emacs_scroller_refs (w, pr, ARRAYELTS (pr));
+ for (int i = 0; i < n; ++i)
+ IGC_FIX12_RAW (ss, pr[i]);
+#endif
+ }
+ MPS_SCAN_END (ss);
+ return MPS_RES_OK;
+}
+
+static mps_res_t
+fix_buffer_quirks (mps_ss_t ss, struct buffer *b)
+{
+ MPS_SCAN_BEGIN (ss)
+ {
+ if (b->base_buffer)
+ b->text = &b->base_buffer->own_text;
+ else
+ b->text = &b->own_text;
+ }
+ MPS_SCAN_END (ss);
+ return MPS_RES_OK;
+}
+
+static mps_res_t
+fix_coding (mps_ss_t ss, struct coding_system *c)
+{
+ MPS_SCAN_BEGIN (ss)
+ {
+ if (c)
+ {
+ IGC_FIX12_OBJ (ss, &c->src_object);
+ IGC_FIX12_OBJ (ss, &c->dst_object);
+ }
+ }
+ MPS_SCAN_END (ss);
+ return MPS_RES_OK;
+}
+
+static mps_res_t
+fix_terminal_quirks (mps_ss_t ss, struct terminal *t)
+{
+ MPS_SCAN_BEGIN (ss)
+ {
+ // These are malloc'd, so they can be accessed.
+ IGC_FIX_CALL_FN (ss, struct coding_system, t->keyboard_coding,
+ fix_coding);
+ IGC_FIX_CALL_FN (ss, struct coding_system, t->terminal_coding,
+ fix_coding);
+ }
+ MPS_SCAN_END (ss);
+ return MPS_RES_OK;
+}
+
+static mps_res_t
+fix_font_object_quirks (mps_ss_t ss, struct font *f)
+{
+ MPS_SCAN_BEGIN (ss)
+ {
+ Lisp_Object const *type = &f->driver->type;
+ IGC_FIX12_OBJ (ss, (Lisp_Object *)type);
+ }
+ MPS_SCAN_END (ss);
+ return MPS_RES_OK;
+}
+
+#include "igc-generated.c"
+
static mps_res_t
scan_lispsym (mps_ss_t ss, void *start, void *end, void *closure)
{
@@ -1108,6 +1249,7 @@ dflt_skip (mps_addr_t base_addr)
return next;
}
+#if 0
static mps_res_t
fix_string (mps_ss_t ss, struct Lisp_String *s)
{
@@ -1119,7 +1261,9 @@ fix_string (mps_ss_t ss, struct Lisp_String *s)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_interval (mps_ss_t ss, struct interval *iv)
{
@@ -1136,7 +1280,9 @@ fix_interval (mps_ss_t ss, struct interval *iv)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_itree_tree (mps_ss_t ss, struct itree_tree *t)
{
@@ -1148,7 +1294,9 @@ fix_itree_tree (mps_ss_t ss, struct itree_tree *t)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_itree_node (mps_ss_t ss, struct itree_node *n)
{
@@ -1165,7 +1313,9 @@ fix_itree_node (mps_ss_t ss, struct itree_node *n)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_image (mps_ss_t ss, struct image *i)
{
@@ -1182,7 +1332,9 @@ fix_image (mps_ss_t ss, struct image *i)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_image_cache (mps_ss_t ss, struct image_cache *c)
{
@@ -1196,7 +1348,9 @@ fix_image_cache (mps_ss_t ss, struct image_cache *c)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_face (mps_ss_t ss, struct face *f)
{
@@ -1214,7 +1368,9 @@ fix_face (mps_ss_t ss, struct face *f)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_face_cache (mps_ss_t ss, struct face_cache *c)
{
@@ -1227,7 +1383,9 @@ fix_face_cache (mps_ss_t ss, struct face_cache *c)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_ptr_vec (mps_ss_t ss, void *client)
{
@@ -1241,7 +1399,9 @@ fix_ptr_vec (mps_ss_t ss, void *client)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_obj_vec (mps_ss_t ss, Lisp_Object *v)
{
@@ -1254,7 +1414,9 @@ fix_obj_vec (mps_ss_t ss, Lisp_Object *v)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_cons (mps_ss_t ss, struct Lisp_Cons *cons)
{
@@ -1266,7 +1428,9 @@ fix_cons (mps_ss_t ss, struct Lisp_Cons *cons)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_blv (mps_ss_t ss, struct Lisp_Buffer_Local_Value *blv)
{
@@ -1279,7 +1443,9 @@ fix_blv (mps_ss_t ss, struct Lisp_Buffer_Local_Value *blv)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_handler (mps_ss_t ss, struct handler *h)
{
@@ -1294,9 +1460,11 @@ fix_handler (mps_ss_t ss, struct handler *h)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
static mps_res_t fix_vector (mps_ss_t ss, struct Lisp_Vector *v);
+#if 0
static mps_res_t
dflt_scan_obj (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
void *closure)
@@ -1341,7 +1509,7 @@ dflt_scan_obj (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
break;
case IGC_OBJ_PTR_VEC:
- IGC_FIX_CALL_FN (ss, mps_word_t, client, fix_ptr_vec);
+ IGC_FIX_CALL_FN (ss, void *, client, fix_ptr_vec);
break;
case IGC_OBJ_OBJ_VEC:
@@ -1404,14 +1572,47 @@ dflt_scan_obj (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
break;
case IGC_OBJ_BLV:
- IGC_FIX_CALL_FN (ss, struct Lisp_Buffer_Local_Value, client,
- fix_blv);
+ IGC_FIX_CALL_FN (ss, struct Lisp_Buffer_Local_Value, client, fix_blv);
break;
}
}
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+
+static mps_res_t
+dflt_scanx_obj (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
+ void *closure)
+{
+ MPS_SCAN_BEGIN (ss)
+ {
+ mps_addr_t base = base_start;
+ mps_addr_t client = base_to_client (base);
+ struct igc_header *header = base;
+
+ if (closure)
+ {
+ struct igc_stats *st = closure;
+ mps_word_t obj_type = header->obj_type;
+ igc_assert (obj_type < IGC_OBJ_NUM_TYPES);
+ st->obj[obj_type].nwords += header->nwords;
+ st->obj[obj_type].nobjs += 1;
+ if (obj_type == IGC_OBJ_VECTOR)
+ {
+ struct Lisp_Vector *v = (struct Lisp_Vector *)client;
+ enum pvec_type pvec_type = pseudo_vector_type (v->header);
+ igc_assert (0 <= pvec_type && pvec_type <= PVEC_TAG_MAX);
+ st->pvec[pvec_type].nwords += header->nwords;
+ st->pvec[pvec_type].nobjs += 1;
+ }
+ }
+
+ IGC_FIX_CALL (ss, dflt_scan_object (ss, base));
+ }
+ MPS_SCAN_END (ss);
+ return MPS_RES_OK;
+}
static mps_res_t
dflt_scanx (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
@@ -1421,7 +1622,7 @@ dflt_scanx (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
{
for (mps_addr_t base = base_start; base < base_limit;
base = dflt_skip (base))
- IGC_FIX_CALL (ss, dflt_scan_obj (ss, base, base_limit, closure));
+ IGC_FIX_CALL (ss, dflt_scanx_obj (ss, base, base_limit, closure));
}
MPS_SCAN_END (ss);
return MPS_RES_OK;
@@ -1432,7 +1633,9 @@ dflt_scan (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit)
{
MPS_SCAN_BEGIN (ss)
{
- IGC_FIX_CALL (ss, dflt_scanx (ss, base_start, base_limit, NULL));
+ for (mps_addr_t base = base_start; base < base_limit;
+ base = dflt_skip (base))
+ IGC_FIX_CALL (ss, dflt_scan_object (ss, base));
}
MPS_SCAN_END (ss);
return MPS_RES_OK;
@@ -1450,6 +1653,7 @@ fix_vectorlike (mps_ss_t ss, struct Lisp_Vector *v)
return MPS_RES_OK;
}
+#if 0
static mps_res_t
fix_buffer (mps_ss_t ss, struct buffer *b)
{
@@ -1472,32 +1676,9 @@ fix_buffer (mps_ss_t ss, struct buffer *b)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
-static mps_res_t
-fix_glyph_matrix (mps_ss_t ss, struct glyph_matrix *matrix)
-{
- MPS_SCAN_BEGIN (ss)
- {
- struct glyph_row *row = matrix->rows;
- struct glyph_row *end = row + matrix->nrows;
-
- for (; row < end; ++row)
- if (row->enabled_p)
- {
- for (int area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
- {
- struct glyph *glyph = row->glyphs[area];
- struct glyph *end_glyph = glyph + row->used[area];
- for (; glyph < end_glyph; ++glyph)
- IGC_FIX12_OBJ (ss, &glyph->object);
- }
- }
- IGC_FIX12_RAW (ss, &matrix->buffer);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-
+#if 0
static mps_res_t
fix_frame (mps_ss_t ss, struct frame *f)
{
@@ -1514,32 +1695,14 @@ fix_frame (mps_ss_t ss, struct frame *f)
IGC_FIX12_RAW (ss, &f->face_cache);
if (f->terminal)
IGC_FIX12_RAW (ss, &f->terminal);
-#ifdef HAVE_WINDOW_SYSTEM
- if (FRAME_WINDOW_P (f) && FRAME_OUTPUT_DATA (f))
- {
- struct font **font_ptr = &FRAME_FONT (f);
- if (*font_ptr)
- IGC_FIX12_RAW (ss, font_ptr);
- Lisp_Object *nle = &FRAME_DISPLAY_INFO (f)->name_list_element;
- IGC_FIX12_OBJ (ss, nle);
-
-#ifdef HAVE_NS
- struct ns_display_info *i = FRAME_DISPLAY_INFO (f);
- IGC_FIX12_RAW (ss, &i->terminal);
- IGC_FIX12_OBJ (ss, &i->rdb);
- IGC_FIX12_RAW (ss, &i->highlight_frame);
- IGC_FIX12_RAW (ss, &i->ns_focus_frame);
- IGC_FIX12_RAW (ss, &i->last_mouse_motion_frame);
- struct frame **pf = ns_emacs_view_emacs_frame (f);
- IGC_FIX12_RAW (ss, pf);
-#endif
- }
-#endif // HAVE_WINDOW_SYSTEM
+ IGC_FIX_CALL_FN (ss, struct frame, f, fix_frame_quirks);
}
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_window (mps_ss_t ss, struct window *w)
{
@@ -1569,7 +1732,9 @@ fix_window (mps_ss_t ss, struct window *w)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_hash_table (mps_ss_t ss, struct Lisp_Hash_Table *h)
{
@@ -1585,9 +1750,11 @@ fix_hash_table (mps_ss_t ss, struct Lisp_Hash_Table *h)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
-fix_char_table (mps_ss_t ss, struct Lisp_Vector *v)
+fix_char_table (mps_ss_t ss, struct Lisp_Char_Table *v)
{
MPS_SCAN_BEGIN (ss)
{
@@ -1597,7 +1764,23 @@ fix_char_table (mps_ss_t ss, struct Lisp_Vector *v)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
+static mps_res_t
+fix_sub_char_table (mps_ss_t ss, struct Lisp_Sub_Char_Table *v)
+{
+ MPS_SCAN_BEGIN (ss)
+ {
+ int size = v->header.size & PSEUDOVECTOR_SIZE_MASK;
+ IGC_FIX12_NOBJS (ss, v->contents, size - SUB_CHAR_TABLE_OFFSET);
+ }
+ MPS_SCAN_END (ss);
+ return MPS_RES_OK;
+}
+#endif
+
+#if 0
static mps_res_t
fix_overlay (mps_ss_t ss, struct Lisp_Overlay *o)
{
@@ -1610,7 +1793,9 @@ fix_overlay (mps_ss_t ss, struct Lisp_Overlay *o)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_subr (mps_ss_t ss, struct Lisp_Subr *s)
{
@@ -1628,7 +1813,9 @@ fix_subr (mps_ss_t ss, struct Lisp_Subr *s)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_misc_ptr (mps_ss_t ss, struct Lisp_Misc_Ptr *p)
{
@@ -1640,7 +1827,9 @@ fix_misc_ptr (mps_ss_t ss, struct Lisp_Misc_Ptr *p)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_user_ptr (mps_ss_t ss, struct Lisp_User_Ptr *p)
{
@@ -1652,7 +1841,9 @@ fix_user_ptr (mps_ss_t ss, struct Lisp_User_Ptr *p)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_thread (mps_ss_t ss, struct thread_state *s)
{
@@ -1666,6 +1857,7 @@ fix_thread (mps_ss_t ss, struct thread_state *s)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
/* This is here because main_thread is, for some reason, a variable in
the data segment, and not like other threads. */
@@ -1683,6 +1875,7 @@ scan_main_thread (mps_ss_t ss, void *start, void *end, void *closure)
return MPS_RES_OK;
}
+#if 0
static mps_res_t
fix_mutex (mps_ss_t ss, struct Lisp_Mutex *m)
{
@@ -1694,22 +1887,9 @@ fix_mutex (mps_ss_t ss, struct Lisp_Mutex *m)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
-static mps_res_t
-fix_coding (mps_ss_t ss, struct coding_system *c)
-{
- MPS_SCAN_BEGIN (ss)
- {
- if (c)
- {
- IGC_FIX12_OBJ (ss, &c->src_object);
- IGC_FIX12_OBJ (ss, &c->dst_object);
- }
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-
+#if 0
static mps_res_t
fix_terminal (mps_ss_t ss, struct terminal *t)
{
@@ -1727,7 +1907,9 @@ fix_terminal (mps_ss_t ss, struct terminal *t)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_marker (mps_ss_t ss, struct Lisp_Marker *m)
{
@@ -1739,7 +1921,9 @@ fix_marker (mps_ss_t ss, struct Lisp_Marker *m)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_finalizer (mps_ss_t ss, struct Lisp_Finalizer *f)
{
@@ -1752,7 +1936,9 @@ fix_finalizer (mps_ss_t ss, struct Lisp_Finalizer *f)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
+#if 0
static mps_res_t
fix_comp_unit (mps_ss_t ss, struct Lisp_Native_Comp_Unit *u)
{
@@ -1768,6 +1954,7 @@ fix_comp_unit (mps_ss_t ss, struct Lisp_Native_Comp_Unit *u)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
#ifdef HAVE_XWIDGETS
@@ -1812,6 +1999,7 @@ fix_global_ref (mps_ss_t ss, struct module_global_reference *r)
#endif
#ifndef IN_MY_FORK
+#if 0
static mps_res_t
fix_obarray (mps_ss_t ss, struct Lisp_Obarray *o)
{
@@ -1823,7 +2011,9 @@ fix_obarray (mps_ss_t ss, struct Lisp_Obarray *o)
return MPS_RES_OK;
}
#endif
+#endif
+#if 0
static mps_res_t
fix_font (mps_ss_t ss, struct Lisp_Vector *v)
{
@@ -1850,17 +2040,19 @@ fix_font (mps_ss_t ss, struct Lisp_Vector *v)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
/* Note that there is a small window after committing a vectorlike
allocation where the object is zeroed, and so the vector header is
also zero. This doesn't have an adverse effect. */
+#if 0
static mps_res_t
fix_vector (mps_ss_t ss, struct Lisp_Vector *v)
{
MPS_SCAN_BEGIN (ss)
{
- switch (pseudo_vector_type (v))
+ switch (pseudo_vector_type (v->header))
{
#ifndef IN_MY_FORK
case PVEC_OBARRAY:
@@ -1885,8 +2077,12 @@ fix_vector (mps_ss_t ss, struct Lisp_Vector *v)
break;
case PVEC_CHAR_TABLE:
+ IGC_FIX_CALL_FN (ss, struct Lisp_Char_Table, v, fix_char_table);
+ break;
+
case PVEC_SUB_CHAR_TABLE:
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, v, fix_char_table);
+ IGC_FIX_CALL_FN (ss, struct Lisp_Sub_Char_Table, v,
+ fix_sub_char_table);
break;
case PVEC_BOOL_VECTOR:
@@ -1983,6 +2179,7 @@ fix_vector (mps_ss_t ss, struct Lisp_Vector *v)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
static igc_scan_result_t
scan_cell_callback (struct igc_opaque *op, Lisp_Object *addr)
@@ -2557,7 +2754,7 @@ finalize_finalizer (struct Lisp_Finalizer *f)
static void
finalize_vector (mps_addr_t v)
{
- switch (pseudo_vector_type (v))
+ switch (pseudo_vector_type (((struct Lisp_Vector *)v)->header))
{
case PVEC_FREE:
emacs_abort ();
@@ -3575,7 +3772,9 @@ igc_header_size (void)
static bool
is_builtin_subr (enum igc_obj_type type, void *client)
{
- if (type == IGC_OBJ_VECTOR && pseudo_vector_type (client) == PVEC_SUBR)
+ if (type == IGC_OBJ_VECTOR
+ && pseudo_vector_type (((struct Lisp_Vector *)client)->header)
+ == PVEC_SUBR)
{
Lisp_Object subr = make_lisp_ptr (client, Lisp_Vectorlike);
return !SUBR_NATIVE_COMPILEDP (subr);
@@ -3809,7 +4008,7 @@ record_copy (struct igc_mirror *m, void *dumped, void *copy)
if (h->obj_type == IGC_OBJ_VECTOR)
{
struct Lisp_Vector *v = base_to_client (copy);
- int i = pseudo_vector_type (v);
+ int i = pseudo_vector_type (v->header);
m->pvec[i].n += 1;
m->pvec[i].nbytes += header_nbytes (h);
}
@@ -4281,9 +4480,9 @@ mirror_global_ref (struct igc_mirror *m, struct module_global_reference *r)
#endif
static void
-mirror_vector (struct igc_mirror *m, void *client)
+mirror_vector (struct igc_mirror *m, struct Lisp_Vector *client)
{
- switch (pseudo_vector_type (client))
+ switch (pseudo_vector_type (client->header))
{
#ifndef IN_MY_FORK
case PVEC_OBARRAY:
--
2.39.2
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-WIP-generate-mirror-code.patch --]
[-- Type: text/x-diff, Size: 30849 bytes --]
From 6c50ae682cd7f78954bab97f72c586acdf92be1f Mon Sep 17 00:00:00 2001
From: Helmut Eller <eller.helmut@gmail.com>
Date: Tue, 11 Jun 2024 12:52:42 +0200
Subject: [PATCH 2/5] WIP generate mirror code
---
admin/igc-codegen.el | 379 +++++++++++++++++++++++++++++--------------
src/igc.c | 153 ++++++++++++++---
2 files changed, 385 insertions(+), 147 deletions(-)
diff --git a/admin/igc-codegen.el b/admin/igc-codegen.el
index cefe4111866..6224252e7d7 100644
--- a/admin/igc-codegen.el
+++ b/admin/igc-codegen.el
@@ -3,7 +3,36 @@
(require 'treesit)
(require 'project)
+(defconst igccg--obj-types
+ '(IGC_OBJ_INVALID
+ IGC_OBJ_PAD
+ IGC_OBJ_FWD
+ IGC_OBJ_CONS
+ IGC_OBJ_SYMBOL
+ IGC_OBJ_INTERVAL
+ IGC_OBJ_STRING
+ IGC_OBJ_STRING_DATA
+ IGC_OBJ_VECTOR
+ IGC_OBJ_VECTOR_WEAK
+ IGC_OBJ_ITREE_TREE
+ IGC_OBJ_ITREE_NODE
+ IGC_OBJ_IMAGE
+ IGC_OBJ_IMAGE_CACHE
+ IGC_OBJ_FACE
+ IGC_OBJ_FACE_CACHE
+ IGC_OBJ_FLOAT
+ IGC_OBJ_BLV
+ IGC_OBJ_PTR_VEC
+ IGC_OBJ_OBJ_VEC
+ IGC_OBJ_HANDLER
+ IGC_OBJ_BYTES
+ IGC_OBJ_BUILTIN_SYMBOL
+ IGC_OBJ_BUILTIN_THREAD
+ IGC_OBJ_BUILTIN_SUBR
+ ))
+
(defmacro igccg--define-record (name &rest fields)
+ (declare (indent 1))
(let* ((constructor (intern (format "igccg--make-%s" name)))
(conc-name (intern (format "igccg--%s." name)))
(tag-name (intern (format "igccg--%s" name))))
@@ -43,11 +72,14 @@ igccg--emit-line
(make-string igccg--indent ?\s)
string)))
-(defun igccg--emit-function (rtype name args body)
- (princ (format "static %s\n%s (%s)\n{\n" rtype name (string-join args ", ")))
- (let ((igccg--indent 2))
- (funcall body))
- (princ "}\n\n"))
+(defun igccg--emit-function (spec body)
+ (pcase-exhaustive spec
+ (`[,name ,args ,rtype]
+ (princ (format "static %s\n%s (%s)\n{\n"
+ rtype name (string-join args ", ")))
+ (let ((igccg--indent 2))
+ (funcall body))
+ (princ "}\n\n"))))
(defun igccg--emit-block (body)
(igccg--emit-line "{")
@@ -76,12 +108,6 @@ igccg--ifdef-exp
((guard (symbolp exp)) (format "defined %s" exp))
(`(or . ,exps) (mapconcat #'igccg--ifdef-exp exps " || "))))
-(defun igccg--emit-scan-body (body)
- (igccg--emit-line "MPS_SCAN_BEGIN (ss)")
- (igccg--emit-block body)
- (igccg--emit-line "MPS_SCAN_END (ss);")
- (igccg--emit-line "return MPS_RES_OK;"))
-
(defun igccg--field-addr-exp (var path)
(pcase-exhaustive path
((guard (symbolp path))
@@ -108,22 +134,15 @@ igccg--field-value-exp
(format "(%s->header.size & PSEUDOVECTOR_SIZE_MASK)\
- SUB_CHAR_TABLE_OFFSET" var))))
-(defun igccg--emit-fix-call (ss type var fname)
- (igccg--emit-line
- (format "IGC_FIX_CALL_FN (%s, %s, %s, %s);"
- ss (igccg--type-spec type) var fname)))
-
(defun igccg--emit-abort ()
(igccg--emit-line "emacs_abort ();"))
-(defun igccg--emit-fix-field-exp (ss obj exp)
+(defun igccg--emit-fix-field-exp (visitor layout obj exp)
(pcase-exhaustive exp
(`(tagged ,path)
- (igccg--emit-line (format "IGC_FIX12_OBJ (%s, %s);"
- ss (igccg--field-addr-exp obj path))))
+ (igccg--emit-fix-tagged visitor (igccg--field-addr-exp obj path)))
(`(untagged ,path)
- (igccg--emit-line (format "IGC_FIX12_RAW (%s, %s);"
- ss (igccg--field-addr-exp obj path))))
+ (igccg--emit-fix-untagged visitor (igccg--field-addr-exp obj path)))
(`(switch ,path . ,cases)
(igccg--emit-switch
(igccg--field-value-exp obj path)
@@ -132,135 +151,240 @@ igccg--emit-fix-field-exp
(`(,tag . ,fields)
(cons (symbol-name tag)
(lambda ()
- (mapc (lambda (field)
- (igccg--emit-fix-field-exp ss obj field))
+ (mapc (lambda (f)
+ (igccg--emit-fix-field-exp
+ visitor layout obj f))
fields))))))
cases)))
(`(array tagged ,start ,len)
- (igccg--emit-line
- (format (concat "IGC_FIX12_NOBJS (%s, %s, %s);")
- ss
- (igccg--field-value-exp obj start)
- (igccg--field-value-exp obj len))))
+ (igccg--emit-fix-tagged-array visitor
+ (igccg--field-value-exp obj start)
+ (igccg--field-value-exp obj len)))
(`(array untagged ,start ,len)
- (igccg--emit-line
- (format "size_t len = %s;" (igccg--field-value-exp obj len)))
- (igccg--emit-line
- (format "for (void **p = %s, **q = p + len; p < q; p++)"
- (igccg--field-value-exp obj start)))
- (igccg--emit-block (lambda ()
- (igccg--emit-line
- (format "IGC_FIX12_RAW (%s, p);" ss)))))
+ (igccg--emit-fix-untagged-array visitor
+ (igccg--field-value-exp obj start)
+ (igccg--field-value-exp obj len)))
(`(vectorlike)
- (igccg--emit-line
- (format
- "IGC_FIX12_NOBJS (%s,\
- (Lisp_Object *)(&%s->header + 1),\
- %s->header.size & PSEUDOVECTOR_SIZE_MASK);" ss obj obj)))
+ (igccg--emit-fix-tagged-array
+ visitor
+ (format "(Lisp_Object *)(&%s->header + 1)" obj)
+ (format "%s->header.size & PSEUDOVECTOR_SIZE_MASK" obj)))
(`(cfg ,test . ,exps)
(igccg--emit-\#if (igccg--ifdef-exp test)
(lambda ()
(mapc (lambda (exp)
- (igccg--emit-fix-field-exp ss obj exp))
+ (igccg--emit-fix-field-exp
+ visitor layout obj exp))
exps))))
('(abort)
(igccg--emit-abort))
- ('(frame-quirks)
- (igccg--emit-line
- (format "IGC_FIX_CALL_FN (%s, struct frame, %s, fix_frame_quirks);"
- ss obj)))
- ('(window-quirks)
- (igccg--emit-line
- (format "IGC_FIX_CALL_FN (%s, struct window, %s, fix_window_quirks);"
- ss obj)))
- ('(buffer-quirks)
- (igccg--emit-line
- (format "IGC_FIX_CALL_FN (%s, struct buffer, %s, fix_buffer_quirks);"
- ss obj)))
- ('(terminal-quirks)
- (igccg--emit-line
- (format "IGC_FIX_CALL_FN (%s, struct terminal, %s, fix_terminal_quirks);"
- ss obj)))
- ('(font-object-quirks)
- (igccg--emit-line
- (format "IGC_FIX_CALL_FN (%s, struct font, %s, fix_font_object_quirks);"
- ss obj)))))
-
-(defun igccg--fix-method-name (layout)
- (format "fix_%s" (igccg--layout.name layout)))
+ ('(quirks)
+ (igccg--emit-quirks visitor (igccg--layout.name layout) obj))))
(defun igccg--scan-vectorlike-method-name (prefix)
(format "%s_scan_vectorlike" prefix))
-(defun igccg--emit-fix-method (layout)
+(defun igccg--emit-scan-method (visitor layout)
(igccg--emit-function
- "mps_res_t"
- (igccg--fix-method-name layout)
- (list "mps_ss_t ss" (igccg--arg-decl "o"
- `(* ,(igccg--layout.ctype layout))))
+ (igccg--scan-method-spec visitor "o" layout)
(lambda ()
- (igccg--emit-scan-body
+ (igccg--emit-function-body
+ visitor
(lambda ()
(dolist (exp (igccg--layout.fields layout))
- (igccg--emit-fix-field-exp "ss" "o" exp)))))))
+ (igccg--emit-fix-field-exp visitor layout "o" exp)))))))
-(defun igccg--emit-scan-vectorlike-method (name layouts)
+(defun igccg--emit-scan-vectorlike (visitor layouts)
(igccg--emit-function
- "mps_res_t"
- name
- (list "mps_ss_t ss" "struct Lisp_Vector *v")
+ (igccg--scan-vectorlike-spec visitor)
(lambda ()
- (igccg--emit-scan-body
+ (igccg--emit-function-body
+ visitor
(lambda ()
(igccg--emit-switch
"pseudo_vector_type (v->header)"
(append
(mapcar (lambda (l)
- (cons (symbol-name (igccg--layout.pvectype l))
- (lambda ()
- (igccg--emit-fix-call
- "ss" (igccg--layout.ctype l)
- "v" (igccg--fix-method-name l)))))
+ (cons
+ (symbol-name (igccg--layout.pvectype l))
+ (lambda ()
+ (igccg--emit-call
+ visitor
+ (aref (igccg--scan-method-spec visitor "x" l) 0)
+ "v" (igccg--layout.ctype l)))))
layouts)
(list (cons 'PVEC_FREE (lambda () (igccg--emit-abort)))))))))))
-(defun igccg--emit-scan-object-method (prefix layouts)
- (mapc #'igccg--emit-fix-method layouts)
- (let* ((alist (seq-group-by #'igccg--layout.header igccg--layouts ))
- (vectorlike (cdr (assq 'IGC_OBJ_VECTOR alist)))
- (scan-vectorlike (igccg--scan-vectorlike-method-name prefix)))
- (igccg--emit-scan-vectorlike-method scan-vectorlike vectorlike)
+(cl-defgeneric igccg--scan-object-spec (visitor))
+(cl-defgeneric igccg--scan-vectorlike-spec (visitor))
+(cl-defgeneric igccg--scan-method-spec (visitor var layout))
+(cl-defgeneric igccg--emit-function-body (visitor))
+(cl-defgeneric igccg--emit-call (visitor fname var type))
+(cl-defgeneric igccg--emit-fix-tagged (visitor addr-exp))
+(cl-defgeneric igccg--emit-fix-untagged (visitor addr-exp))
+(cl-defgeneric igccg--emit-fix-tagged-array (visitor start len))
+(cl-defgeneric igccg--emit-fix-untagged-array (visitor start len))
+(cl-defgeneric igccg--emit-quirks (visitor layout obj))
+
+(progn
+ ;; dflt methods
+ (cl-defmethod igccg--scan-object-spec ((v (eql 'dflt)))
+ ["dflt_scan_object" ("mps_ss_t ss" "mps_addr_t base") "mps_res_t"])
+
+ (cl-defmethod igccg--scan-vectorlike-spec ((v (eql 'dflt)))
+ ["fix_vectorlike" ("mps_ss_t ss" "struct Lisp_Vector *v") "mps_res_t"])
+
+ (cl-defmethod igccg--scan-method-spec ((v (eql 'dflt)) var layout)
+ (vector
+ (format "fix_%s" (igccg--layout.name layout))
+ (list "mps_ss_t ss"
+ (igccg--arg-decl var `(* ,(igccg--layout.ctype layout))))
+ "mps_res_t"))
+
+ (cl-defmethod igccg--emit-function-body ((v (eql 'dflt)) body)
+ (igccg--emit-line "MPS_SCAN_BEGIN (ss)")
+ (igccg--emit-block body)
+ (igccg--emit-line "MPS_SCAN_END (ss);")
+ (igccg--emit-line "return MPS_RES_OK;"))
+
+ (cl-defmethod igccg--emit-call ((v (eql 'dflt)) fname var type)
+ (igccg--emit-line (format "IGC_FIX_CALL_FN (ss, %s, %s, %s);"
+ (igccg--type-spec type) var fname)))
+
+ (cl-defmethod igccg--emit-fix-tagged ((v (eql 'dflt)) addr-expr)
+ (igccg--emit-line (format "IGC_FIX12_OBJ (ss, %s);" addr-expr)))
+
+ (cl-defmethod igccg--emit-fix-untagged ((v (eql 'dflt)) addr-expr)
+ (igccg--emit-line (format "IGC_FIX12_RAW (ss, %s);" addr-expr)))
+
+ (cl-defmethod igccg--emit-fix-tagged-array ((v (eql 'dflt)) start len)
+ (igccg--emit-line (format "IGC_FIX12_NOBJS (ss, %s, %s);" start len)))
+
+ (cl-defmethod igccg--emit-fix-untagged-array ((v (eql 'dflt)) start len)
+ (igccg--emit-line (format "IGC_FIX12_NRAW (ss, %s, %s);" start len)))
+
+ (cl-defmethod igccg--emit-quirks ((v (eql 'dflt)) (l (eql 'frame)) obj)
+ (igccg--emit-line
+ (format "IGC_FIX_CALL_FN (ss, struct frame, %s, fix_frame_quirks);"
+ obj)))
+
+ (cl-defmethod igccg--emit-quirks ((v (eql 'dflt)) (l (eql 'window)) obj)
+ (igccg--emit-line
+ (format "IGC_FIX_CALL_FN (ss, struct window, %s, fix_window_quirks);"
+ obj)))
+
+ (cl-defmethod igccg--emit-quirks ((v (eql 'dflt)) (l (eql 'buffer)) obj)
+ (igccg--emit-line
+ (format "IGC_FIX_CALL_FN (ss, struct buffer, %s, fix_buffer_quirks);"
+ obj)))
+
+ (cl-defmethod igccg--emit-quirks ((v (eql 'dflt)) (l (eql 'terminal)) obj)
+ (igccg--emit-line
+ (format "IGC_FIX_CALL_FN (ss, struct terminal, %s, fix_terminal_quirks);"
+ obj)))
+
+ (cl-defmethod igccg--emit-quirks ((v (eql 'dflt)) (l (eql 'font)) obj)
+ (igccg--emit-line
+ (format "IGC_FIX_CALL_FN (ss, struct font, %s, fix_font_quirks);"
+ obj)))
+
+ )
+
+(progn
+ ;; mirror methods
+ (cl-defmethod igccg--scan-object-spec ((v (eql 'mirror)))
+ ["mirror_obj" ("struct igc_mirror *m" "mps_addr_t base") "void"])
+
+ (cl-defmethod igccg--scan-vectorlike-spec ((v (eql 'mirror)))
+ ["mirror_vectorlike" ("struct igc_mirror *m" "struct Lisp_Vector *v")
+ "void"])
+
+ (cl-defmethod igccg--scan-method-spec ((v (eql 'mirror)) var layout)
+ (vector
+ (format "mirror_%s" (igccg--layout.name layout))
+ (list "struct igc_mirror *m"
+ (igccg--arg-decl var `(* ,(igccg--layout.ctype layout))))
+ "void"))
+
+ (cl-defmethod igccg--emit-function-body ((v (eql 'mirror)) body)
+ (funcall body))
+
+ (cl-defmethod igccg--emit-call ((v (eql 'mirror)) fname var type)
+ (igccg--emit-line (format "%s (m, (%s)%s);"
+ fname (igccg--type-spec `(* ,type)) var)))
+
+ (cl-defmethod igccg--emit-fix-tagged ((v (eql 'mirror)) addr-expr)
+ (igccg--emit-line (format "mirror_lisp_obj (m, %s);" addr-expr)))
+
+ (cl-defmethod igccg--emit-fix-untagged ((v (eql 'mirror)) addr-expr)
+ (igccg--emit-line (format "mirror_raw (m, (mps_addr_t *)%s);" addr-expr)))
+
+ (cl-defmethod igccg--emit-fix-tagged-array ((v (eql 'mirror)) start len)
+ (igccg--emit-line (format "mirror_nobj (m, %s, %s);" start len)))
+
+ (cl-defmethod igccg--emit-fix-untagged-array ((v (eql 'mirror)) start len)
+ (igccg--emit-line (format "mirror_nraw (m, %s, %s);" start len)))
+
+ (cl-defmethod igccg--emit-quirks ((v (eql 'mirror)) l obj)
+ )
+ )
+
+(defun igccg--scan-method-case (visitor obj layout)
+ (cons
+ (symbol-name (igccg--layout.header layout))
+ (lambda ()
+ (igccg--emit-call visitor
+ (aref (igccg--scan-method-spec visitor "o" layout) 0)
+ obj
+ (igccg--layout.ctype layout)))))
+
+
+(defun igccg--scan-method-vectorlike-case (visitor obj)
+ (cons "IGC_OBJ_VECTOR"
+ (lambda ()
+ (igccg--emit-call visitor
+ (aref (igccg--scan-vectorlike-spec visitor) 0)
+ obj
+ '(struct Lisp_Vector)))))
+
+(defun igccg--emit-scan-object-body (visitor layouts)
+ (let* ((alist (seq-group-by #'igccg--layout.header layouts))
+ (pvecs (assq 'IGC_OBJ_VECTOR alist))
+ (nonpvecs (mapcar (lambda (p)
+ (pcase-exhaustive p
+ (`(,_ . (,layout)) layout)))
+ (remq pvecs alist)))
+ (ignored '(IGC_OBJ_FWD IGC_OBJ_PAD))
+ (unhandled (cl-set-difference igccg--obj-types
+ (append (mapcar #'car alist)
+ ignored)))
+ (unhandled (cons 'IGC_OBJ_NUM_TYPES unhandled)))
+ (igccg--emit-line "mps_addr_t client = base_to_client (base);")
+ (igccg--emit-line "struct igc_header *header = base;")
+ (igccg--emit-switch
+ "header->obj_type"
+ (append
+ (mapcar (lambda (layout)
+ (igccg--scan-method-case visitor "client" layout))
+ nonpvecs)
+ (list (igccg--scan-method-vectorlike-case visitor "client"))
+ (mapcar (lambda (type) (cons (symbol-name type) (lambda ())))
+ ignored)
+ (mapcar (lambda (type) (cons (symbol-name type) #'igccg--emit-abort))
+ unhandled)))))
+
+(defun igccg--emit-scan-object (visitor layouts)
+ (mapc (lambda (l) (igccg--emit-scan-method visitor l)) layouts)
+ (let* ((alist (seq-group-by #'igccg--layout.header layouts))
+ (pvecs (cdr (assq 'IGC_OBJ_VECTOR alist))))
+ (igccg--emit-scan-vectorlike visitor pvecs)
(igccg--emit-function
- "mps_res_t"
- (format "%s_scan_object" prefix)
- (list "mps_ss_t ss" "mps_addr_t base")
+ (igccg--scan-object-spec visitor)
(lambda ()
- (igccg--emit-scan-body
+ (igccg--emit-function-body
+ visitor
(lambda ()
- (igccg--emit-line "mps_addr_t client = base_to_client (base);")
- (igccg--emit-line "struct igc_header *header = base;")
- (igccg--emit-switch
- "header->obj_type"
- (append
- (mapcar
- (lambda (p)
- (pcase-exhaustive p
- (`(,type . (,layout))
- (cons (symbol-name type)
- (lambda ()
- (igccg--emit-fix-call
- "ss" (igccg--layout.ctype layout)
- "client" (igccg--fix-method-name layout)))))
- (`(IGC_OBJ_VECTOR . ,_)
- (cons "IGC_OBJ_VECTOR"
- (lambda ()
- (igccg--emit-fix-call "ss" '(struct Lisp_Vector)
- "client" scan-vectorlike))))))
- alist)
- (list
- (cons "IGC_OBJ_FWD" (lambda ()))
- (cons "IGC_OBJ_PAD" (lambda ()))
- (cons "IGC_OBJ_INVALID" (lambda () (igccg--emit-abort))))))))))))
+ (igccg--emit-scan-object-body visitor layouts)))))))
(defvar igccg--layouts
(list
@@ -388,6 +512,10 @@ igccg--layouts
'normal_vector 'IGC_OBJ_VECTOR 'PVEC_NORMAL_VECTOR 'Lisp_Vectorlike
'(struct Lisp_Vector) '((array tagged contents (path header size))))
+ (igccg--make-layout
+ 'weak_vector 'IGC_OBJ_VECTOR_WEAK 'PVEC_NORMAL_VECTOR 'Lisp_Vectorlike
+ '(struct Lisp_Vector) '((array tagged contents (path header size))))
+
(igccg--make-layout
'bignum 'IGC_OBJ_VECTOR 'PVEC_BIGNUM 'Lisp_Vectorlike
'(struct Lisp_Bignum) '())
@@ -439,7 +567,7 @@ igccg--layouts
'((vectorlike)
(untagged face_cache)
(untagged terminal)
- (frame-quirks)))
+ (quirks)))
(igccg--make-layout
'window 'IGC_OBJ_VECTOR 'PVEC_WINDOW 'Lisp_Vectorlike
@@ -447,7 +575,7 @@ igccg--layouts
'((vectorlike)
(tagged prev_buffers)
(tagged next_buffers)
- (window-quirks)))
+ (quirks)))
(igccg--make-layout
'bool_vector 'IGC_OBJ_VECTOR 'PVEC_BOOL_VECTOR 'Lisp_Vectorlike
@@ -459,11 +587,12 @@ igccg--layouts
'(struct buffer)
'((vectorlike)
(untagged (path own_text intervals))
- (untagged (path own_text markers))
+ ;;(untagged (path own_text markers))
+ (tagged (path own_text markers))
(untagged overlays)
(untagged base_buffer)
(tagged undo_list_)
- (buffer-quirks)))
+ (quirks)))
(igccg--make-layout
'hash_table 'IGC_OBJ_VECTOR 'PVEC_HASH_TABLE 'Lisp_Vectorlike
@@ -486,7 +615,7 @@ igccg--layouts
(untagged next_terminal)
(cfg HAVE_WINDOW_SYSTEM
(untagged image_cache))
- (terminal-quirks)))
+ (quirks)))
(igccg--make-layout
'window_configuraion 'IGC_OBJ_VECTOR 'PVEC_WINDOW_CONFIGURATION
@@ -611,15 +740,15 @@ igccg--layouts
(switch (pvec-header-size)
(FONT_SPEC_MAX)
(FONT_ENTITY_MAX)
- (FONT_OBJECT_MAX (font-object-quirks))
- (default (abort)))))
- ))
+ (FONT_OBJECT_MAX (quirks))
+ (default (abort)))))))
(defun igccg-main ()
(igccg--emit-line "/* Generated by igc-codegen.el */")
(igccg--emit-line "#pragma GCC diagnostic push")
;;(igccg--emit-line "#pragma GCC diagnostic ignored \"-Wunused-function\"")
- (igccg--emit-scan-object-method "dflt" igccg--layouts)
+ (igccg--emit-scan-object 'dflt igccg--layouts)
+ (igccg--emit-scan-object 'mirror igccg--layouts)
(igccg--emit-line "#pragma GCC diagnostic pop"))
;; (igccg-main)
diff --git a/src/igc.c b/src/igc.c
index c94be5aecef..12d2472bc69 100644
--- a/src/igc.c
+++ b/src/igc.c
@@ -675,6 +675,17 @@ #define IGC_FIX12_NOBJS(ss, a, n) \
} \
while (0)
+#define IGC_FIX12_NRAW(ss, a, n) \
+ do \
+ { \
+ mps_res_t res; \
+ MPS_FIX_CALL ((ss), res = fix_raw_array ((ss), (a), (n))); \
+ if (res != MPS_RES_OK) \
+ return res; \
+ } \
+ while (0)
+
+
#define IGC_FIX_CALL(ss, expr) \
do \
{ \
@@ -708,6 +719,18 @@ fix_array (mps_ss_t ss, Lisp_Object *array, size_t n)
return MPS_RES_OK;
}
+static mps_res_t
+fix_raw_array (mps_ss_t ss, mps_addr_t array[], size_t n)
+{
+ MPS_SCAN_BEGIN (ss)
+ {
+ for (size_t i = 0; i < n; ++i)
+ IGC_FIX12_RAW (ss, &array[i]);
+ }
+ MPS_SCAN_END (ss);
+ return MPS_RES_OK;
+}
+
static mps_res_t
scan_staticvec (mps_ss_t ss, void *start, void *end, void *closure)
{
@@ -933,7 +956,7 @@ fix_terminal_quirks (mps_ss_t ss, struct terminal *t)
}
static mps_res_t
-fix_font_object_quirks (mps_ss_t ss, struct font *f)
+fix_font_quirks (mps_ss_t ss, struct font *f)
{
MPS_SCAN_BEGIN (ss)
{
@@ -944,6 +967,31 @@ fix_font_object_quirks (mps_ss_t ss, struct font *f)
return MPS_RES_OK;
}
+
+struct igc_mirror
+{
+ Lisp_Object dump_to_mps;
+ struct
+ {
+ size_t n, nbytes;
+ } objs[IGC_OBJ_NUM_TYPES];
+ struct
+ {
+ size_t n, nbytes;
+ } pvec[PVEC_TAG_MAX + 1];
+ struct
+ {
+ const char *msg;
+ double time;
+ } times[10];
+ int ntimes;
+};
+
+static void mirror_lisp_obj (struct igc_mirror *m, Lisp_Object *pobj);
+static void mirror_raw (struct igc_mirror *m, mps_addr_t *p);
+static void mirror_nobj (struct igc_mirror *m, Lisp_Object *array, size_t n);
+static void mirror_nraw (struct igc_mirror *m, mps_addr_t array[], size_t n);
+
#include "igc-generated.c"
static mps_res_t
@@ -1462,7 +1510,9 @@ fix_handler (mps_ss_t ss, struct handler *h)
}
#endif
+#if 0
static mps_res_t fix_vector (mps_ss_t ss, struct Lisp_Vector *v);
+#endif
#if 0
static mps_res_t
@@ -1641,6 +1691,7 @@ dflt_scan (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit)
return MPS_RES_OK;
}
+#if 0
static mps_res_t
fix_vectorlike (mps_ss_t ss, struct Lisp_Vector *v)
{
@@ -1652,6 +1703,7 @@ fix_vectorlike (mps_ss_t ss, struct Lisp_Vector *v)
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
+#endif
#if 0
static mps_res_t
@@ -1985,6 +2037,7 @@ fix_xwidget_view (mps_ss_t ss, struct xwidget_view *v)
#endif // HAVE_XWIDGETS
#ifdef HAVE_MODULES
+#if 0
static mps_res_t
fix_global_ref (mps_ss_t ss, struct module_global_reference *r)
{
@@ -1997,6 +2050,7 @@ fix_global_ref (mps_ss_t ss, struct module_global_reference *r)
return MPS_RES_OK;
}
#endif
+#endif
#ifndef IN_MY_FORK
#if 0
@@ -3907,24 +3961,6 @@ copy_to_mps (mps_addr_t base)
return copy;
}
-struct igc_mirror
-{
- Lisp_Object dump_to_mps;
- struct
- {
- size_t n, nbytes;
- } objs[IGC_OBJ_NUM_TYPES];
- struct
- {
- size_t n, nbytes;
- } pvec[PVEC_TAG_MAX + 1];
- struct
- {
- const char *msg;
- double time;
- } times[10];
- int ntimes;
-};
static void
record_time (struct igc_mirror *m, const char *msg)
@@ -4125,13 +4161,20 @@ #define IGC_MIRROR_OBJ(m, obj) mirror_lisp_obj ((m), (obj))
#define IGC_MIRROR_RAW(m, pp) mirror_raw ((m), (mps_addr_t *) (pp))
static void
-mirror_array (struct igc_mirror *m, Lisp_Object *array, size_t n)
+mirror_nobj (struct igc_mirror *m, Lisp_Object *array, size_t n)
{
for (size_t i = 0; i < n; ++i)
IGC_MIRROR_OBJ (m, &array[i]);
}
-#define IGC_MIRROR_NOBJS(m, a, n) mirror_array (m, a, n)
+static void
+mirror_nraw (struct igc_mirror *m, mps_addr_t array[], size_t n)
+{
+ for (size_t i = 0; i < n; ++i)
+ mirror_raw (m, &array[i]);
+}
+
+#define IGC_MIRROR_NOBJS(m, a, n) mirror_nobj (m, a, n)
static void
mirror_fwd (struct igc_mirror *m, lispfwd fwd)
@@ -4159,6 +4202,7 @@ mirror_fwd (struct igc_mirror *m, lispfwd fwd)
}
}
+#if 0
static void
mirror_symbol (struct igc_mirror *m, struct Lisp_Symbol *sym)
{
@@ -4189,14 +4233,18 @@ mirror_symbol (struct igc_mirror *m, struct Lisp_Symbol *sym)
break;
}
}
+#endif
+#if 0
static void
mirror_string (struct igc_mirror *m, struct Lisp_String *s)
{
IGC_MIRROR_RAW (m, &s->u.s.data);
IGC_MIRROR_RAW (m, &s->u.s.intervals);
}
+#endif
+#if 0
static void
mirror_interval (struct igc_mirror *m, struct interval *i)
{
@@ -4208,13 +4256,17 @@ mirror_interval (struct igc_mirror *m, struct interval *i)
IGC_MIRROR_RAW (m, &i->up.interval);
IGC_MIRROR_OBJ (m, &i->plist);
}
+#endif
+#if 0
static void
mirror_itree_tree (struct igc_mirror *m, struct itree_tree *t)
{
IGC_NOT_IMPLEMENTED ();
}
+#endif
+#if 0
static void
mirror_itree_node (struct igc_mirror *m, struct itree_node *n)
{
@@ -4226,37 +4278,49 @@ mirror_itree_node (struct igc_mirror *m, struct itree_node *n)
IGC_MIRROR_RAW (m, &n->right);
IGC_MIRROR_OBJ (m, &n->data);
}
+#endif
+#if 0
static void
mirror_image (struct igc_mirror *m, struct image *i)
{
IGC_NOT_IMPLEMENTED ();
}
+#endif
+#if 0
static void
mirror_image_cache (struct igc_mirror *m, struct image_cache *c)
{
IGC_NOT_IMPLEMENTED ();
}
+#endif
+#if 0
static void
mirror_face (struct igc_mirror *m, struct face *f)
{
IGC_NOT_IMPLEMENTED ();
}
+#endif
+#if 0
static void
mirror_face_cache (struct igc_mirror *m, struct face_cache *c)
{
IGC_NOT_IMPLEMENTED ();
}
+#endif
+#if 0
static void
mirror_ptr_vec (struct igc_mirror *m, void *p)
{
IGC_NOT_IMPLEMENTED ();
}
+#endif
+#if 0
static void
mirror_obj_vec (struct igc_mirror *m, Lisp_Object *v)
{
@@ -4264,20 +4328,26 @@ mirror_obj_vec (struct igc_mirror *m, Lisp_Object *v)
for (size_t i = 0; i < n; ++i)
IGC_MIRROR_OBJ (m, &v[i]);
}
+#endif
+#if 0
static void
mirror_handler (struct igc_mirror *m, struct handler *h)
{
IGC_NOT_IMPLEMENTED ();
}
+#endif
+#if 0
static void
mirror_cons (struct igc_mirror *m, struct Lisp_Cons *c)
{
IGC_MIRROR_OBJ (m, &c->u.s.car);
IGC_MIRROR_OBJ (m, &c->u.s.u.cdr);
}
+#endif
+#if 0
static void
mirror_blv (struct igc_mirror *m, struct Lisp_Buffer_Local_Value *blv)
{
@@ -4285,6 +4355,7 @@ mirror_blv (struct igc_mirror *m, struct Lisp_Buffer_Local_Value *blv)
IGC_MIRROR_OBJ (m, &blv->defcell);
IGC_MIRROR_OBJ (m, &blv->valcell);
}
+#endif
static void
mirror_vectorlike_ (struct igc_mirror *m, struct Lisp_Vector *v)
@@ -4297,13 +4368,16 @@ #define IGC_MIRROR_VECTORLIKE(m, v) \
mirror_vectorlike_ ((m), (struct Lisp_Vector *) (v))
#ifndef IN_MY_FORK
+#if 0
static void
mirror_obarray (struct igc_mirror *m, struct Lisp_Obarray *o)
{
IGC_MIRROR_RAW (m, &o->buckets);
}
#endif
+#endif
+#if 0
static void
mirror_font (struct igc_mirror *m, struct Lisp_Vector *v)
{
@@ -4326,13 +4400,17 @@ mirror_font (struct igc_mirror *m, struct Lisp_Vector *v)
emacs_abort ();
}
}
+#endif
+#if 0
static void
mirror_mutex (struct igc_mirror *m, struct Lisp_Mutex *x)
{
IGC_NOT_IMPLEMENTED ();
}
+#endif
+#if 0
static void
mirror_buffer (struct igc_mirror *m, struct buffer *b)
{
@@ -4349,7 +4427,9 @@ mirror_buffer (struct igc_mirror *m, struct buffer *b)
IGC_MIRROR_OBJ (m, &b->undo_list_);
}
+#endif
+#if 0
static void
mirror_frame (struct igc_mirror *m, struct frame *f)
{
@@ -4361,7 +4441,9 @@ mirror_frame (struct igc_mirror *m, struct frame *f)
igc_assert (!FRAME_WINDOW_P (f));
#endif
}
+#endif
+#if 0
static void
mirror_window (struct igc_mirror *m, struct window *w)
{
@@ -4371,7 +4453,9 @@ mirror_window (struct igc_mirror *m, struct window *w)
IGC_MIRROR_OBJ (m, &w->prev_buffers);
IGC_MIRROR_OBJ (m, &w->next_buffers);
}
+#endif
+#if 0
static void
mirror_hash_table (struct igc_mirror *m, struct Lisp_Hash_Table *h)
{
@@ -4383,14 +4467,18 @@ mirror_hash_table (struct igc_mirror *m, struct Lisp_Hash_Table *h)
igc_assert (!pdumper_object_p (h->key));
igc_assert (!pdumper_object_p (h->value));
}
+#endif
+#if 0
static void
mirror_char_table (struct igc_mirror *m, struct Lisp_Vector *v)
{
for (size_t i = vector_start (v), n = vector_size (v); i < n; ++i)
IGC_MIRROR_OBJ (m, &v->contents[i]);
}
+#endif
+#if 0
static void
mirror_overlay (struct igc_mirror *m, struct Lisp_Overlay *o)
{
@@ -4398,7 +4486,9 @@ mirror_overlay (struct igc_mirror *m, struct Lisp_Overlay *o)
IGC_MIRROR_OBJ (m, &o->plist);
IGC_MIRROR_RAW (m, &o->interval);
}
+#endif
+#if 0
static void
mirror_subr (struct igc_mirror *m, struct Lisp_Subr *s)
{
@@ -4411,19 +4501,25 @@ mirror_subr (struct igc_mirror *m, struct Lisp_Subr *s)
IGC_MIRROR_OBJ (m, &s->type);
#endif
}
+#endif
+#if 0
static void
mirror_misc_ptr (struct igc_mirror *m, struct Lisp_Misc_Ptr *p)
{
IGC_NOT_IMPLEMENTED ();
}
+#endif
+#if 0
static void
mirror_user_ptr (struct igc_mirror *m, struct Lisp_User_Ptr *p)
{
IGC_NOT_IMPLEMENTED ();
}
+#endif
+#if 0
static void
mirror_thread (struct igc_mirror *m, struct thread_state *s)
{
@@ -4432,30 +4528,39 @@ mirror_thread (struct igc_mirror *m, struct thread_state *s)
IGC_MIRROR_RAW (m, &s->next_thread);
IGC_MIRROR_RAW (m, &s->m_handlerlist);
}
+#endif
+#if 0
static void
mirror_terminal (struct igc_mirror *m, struct terminal *t)
{
IGC_NOT_IMPLEMENTED ();
}
+#endif
+#if 0
static void
mirror_marker (struct igc_mirror *m, struct Lisp_Marker *ma)
{
IGC_MIRROR_RAW (m, &ma->buffer);
}
+#endif
+#if 0
static void
mirror_finalizer (struct igc_mirror *m, struct Lisp_Finalizer *f)
{
IGC_NOT_IMPLEMENTED ();
}
+#endif
+#if 0
static void
mirror_comp_unit (struct igc_mirror *m, struct Lisp_Native_Comp_Unit *u)
{
IGC_MIRROR_VECTORLIKE (m, u);
}
+#endif
#ifdef HAVE_XWIDGETS
static void
@@ -4479,6 +4584,7 @@ mirror_global_ref (struct igc_mirror *m, struct module_global_reference *r)
}
#endif
+#if 0
static void
mirror_vector (struct igc_mirror *m, struct Lisp_Vector *client)
{
@@ -4602,7 +4708,9 @@ mirror_vector (struct igc_mirror *m, struct Lisp_Vector *client)
break;
}
}
+#endif
+#if 0
static void
mirror (struct igc_mirror *m, void *org_base, void *copy_base)
{
@@ -4689,12 +4797,13 @@ mirror (struct igc_mirror *m, void *org_base, void *copy_base)
break;
}
}
+#endif
static void
mirror_references (struct igc_mirror *m)
{
DOHASH (XHASH_TABLE (m->dump_to_mps), org_base, copy_base)
- mirror (m, fixnum_to_pointer (org_base), fixnum_to_pointer (copy_base));
+ mirror_obj (m, fixnum_to_pointer (copy_base));
record_time (m, "Mirror references");
}
--
2.39.2
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: attachment --]
[-- Type: text/x-diff, Size: 22727 bytes --]
From c25a02f01b68af1af5d7c55ff90542835f291f71 Mon Sep 17 00:00:00 2001
From: Helmut Eller <eller.helmut@gmail.com>
Date: Thu, 13 Jun 2024 08:39:31 +0200
Subject: [PATCH 3/5] Improve code generator
Add a cfg field to the layout description so that we can generate the
needed #ifdefs.
* src/igc.c (mirror_buffer_quirks): New.
* admin/igc-codegen.el (igccg--emit-quirks): Buffers need special
mirroring code.
(igccg--layout.type): Renamed from igccg--layout.header.
(igccg--layout.cfg): New field.
(igccg--layouts): Add cfg expressions for packages and images.
(igccg--emit-switch, igccg--emit-case): Introduce #ifdef cases.
(igccg--field-addr-exp, igccg--emit-scan-method, igccg--scan-vectorlike-case)
(igccg--scan-method-case, igccg--scan-method-vectorlike-case): Emit
conditional code.
(igccg--ifdef-exp): Allow not operator.
---
admin/igc-codegen.el | 252 +++++++++++++++++++++++--------------------
src/igc.c | 9 ++
2 files changed, 146 insertions(+), 115 deletions(-)
diff --git a/admin/igc-codegen.el b/admin/igc-codegen.el
index 6224252e7d7..f9a6c02827a 100644
--- a/admin/igc-codegen.el
+++ b/admin/igc-codegen.el
@@ -47,7 +47,7 @@ igccg--define-record
`(,field nil :read-only t))
fields))))
-(igccg--define-record layout name header pvectype tag ctype fields)
+(igccg--define-record layout name type pvectype tag cfg ctype fields)
(defun igccg--arg-decl (name type)
(pcase-exhaustive type
@@ -87,16 +87,25 @@ igccg--emit-block
(funcall body))
(igccg--emit-line "}"))
+(defun igccg--emit-case (case)
+ (let ((emit-body (lambda (body)
+ (let ((igccg--indent (+ 2 igccg--indent)))
+ (funcall body)
+ (igccg--emit-line "break;")))))
+ (pcase-exhaustive case
+ (`(case ,tag ,body)
+ (igccg--emit-line (format "case %s:" (symbol-name tag)))
+ (funcall emit-body body))
+ (`(default ,body)
+ (igccg--emit-line "default:")
+ (funcall emit-body body))
+ (`(cfg ,cfg ,case)
+ (igccg--emit-\#if (igccg--ifdef-exp cfg)
+ (lambda () (igccg--emit-case case)))))))
+
(defun igccg--emit-switch (exp cases)
(igccg--emit-line (format "switch (%s)" exp))
- (igccg--emit-block (lambda ()
- (dolist (c cases)
- (igccg--emit-line
- (cond ((equal (car c) "default") "default:")
- (t (format "case %s:" (car c)))))
- (let ((igccg--indent (+ 2 igccg--indent)))
- (funcall (cdr c))
- (igccg--emit-line "break;"))))))
+ (igccg--emit-block (lambda () (mapc #'igccg--emit-case cases))))
(defun igccg--emit-\#if (exp body)
(igccg--emit-line (format "#if %s" exp))
@@ -106,7 +115,8 @@ igccg--emit-\#if
(defun igccg--ifdef-exp (exp)
(pcase-exhaustive exp
((guard (symbolp exp)) (format "defined %s" exp))
- (`(or . ,exps) (mapconcat #'igccg--ifdef-exp exps " || "))))
+ (`(or . ,exps) (mapconcat #'igccg--ifdef-exp exps " || "))
+ (`(not ,exp) (format "!(%s)" (igccg--ifdef-exp exp)))))
(defun igccg--field-addr-exp (var path)
(pcase-exhaustive path
@@ -149,12 +159,12 @@ igccg--emit-fix-field-exp
(mapcar (lambda (case)
(pcase-exhaustive case
(`(,tag . ,fields)
- (cons (symbol-name tag)
- (lambda ()
- (mapc (lambda (f)
- (igccg--emit-fix-field-exp
- visitor layout obj f))
- fields))))))
+ `(,@(if (eq tag 'default) `(default) `(case ,tag))
+ ,(lambda ()
+ (mapc (lambda (f)
+ (igccg--emit-fix-field-exp
+ visitor layout obj f))
+ fields))))))
cases)))
(`(array tagged ,start ,len)
(igccg--emit-fix-tagged-array visitor
@@ -185,14 +195,30 @@ igccg--scan-vectorlike-method-name
(format "%s_scan_vectorlike" prefix))
(defun igccg--emit-scan-method (visitor layout)
- (igccg--emit-function
- (igccg--scan-method-spec visitor "o" layout)
- (lambda ()
- (igccg--emit-function-body
- visitor
- (lambda ()
- (dolist (exp (igccg--layout.fields layout))
- (igccg--emit-fix-field-exp visitor layout "o" exp)))))))
+ (let ((f (lambda ()
+ (igccg--emit-function
+ (igccg--scan-method-spec visitor "o" layout)
+ (lambda ()
+ (igccg--emit-function-body
+ visitor
+ (lambda ()
+ (dolist (exp (igccg--layout.fields layout))
+ (igccg--emit-fix-field-exp visitor layout "o" exp)))))))))
+ (cond ((igccg--layout.cfg layout)
+ (igccg--emit-\#if (igccg--ifdef-exp (igccg--layout.cfg layout))
+ f))
+ (t (funcall f)))))
+
+(defun igccg--scan-vectorlike-case (visitor layout)
+ (let ((case `(case ,(igccg--layout.pvectype layout)
+ ,(lambda ()
+ (igccg--emit-call
+ visitor
+ (aref (igccg--scan-method-spec visitor "x" layout) 0)
+ "v" (igccg--layout.ctype layout))))))
+ (cond ((igccg--layout.cfg layout)
+ `(cfg ,(igccg--layout.cfg layout) ,case))
+ (t case))))
(defun igccg--emit-scan-vectorlike (visitor layouts)
(igccg--emit-function
@@ -204,16 +230,9 @@ igccg--emit-scan-vectorlike
(igccg--emit-switch
"pseudo_vector_type (v->header)"
(append
- (mapcar (lambda (l)
- (cons
- (symbol-name (igccg--layout.pvectype l))
- (lambda ()
- (igccg--emit-call
- visitor
- (aref (igccg--scan-method-spec visitor "x" l) 0)
- "v" (igccg--layout.ctype l)))))
+ (mapcar (lambda (l) (igccg--scan-vectorlike-case visitor l))
layouts)
- (list (cons 'PVEC_FREE (lambda () (igccg--emit-abort)))))))))))
+ (list `(case PVEC_FREE ,#'igccg--emit-abort)))))))))
(cl-defgeneric igccg--scan-object-spec (visitor))
(cl-defgeneric igccg--scan-vectorlike-spec (visitor))
@@ -327,28 +346,33 @@ igccg--emit-quirks
(cl-defmethod igccg--emit-quirks ((v (eql 'mirror)) l obj)
)
+
+ (cl-defmethod igccg--emit-quirks ((v (eql 'mirror)) (l (eql 'buffer)) obj)
+ (igccg--emit-line (format "mirror_buffer_quirks (%s);" obj)))
)
(defun igccg--scan-method-case (visitor obj layout)
- (cons
- (symbol-name (igccg--layout.header layout))
- (lambda ()
- (igccg--emit-call visitor
- (aref (igccg--scan-method-spec visitor "o" layout) 0)
- obj
- (igccg--layout.ctype layout)))))
-
+ (let ((case `(case ,(igccg--layout.type layout)
+ ,(lambda ()
+ (igccg--emit-call
+ visitor
+ (aref (igccg--scan-method-spec visitor "o" layout) 0)
+ obj
+ (igccg--layout.ctype layout))))))
+ (cond ((igccg--layout.cfg layout)
+ `(cfg ,(igccg--layout.cfg layout) ,case))
+ (t case))))
(defun igccg--scan-method-vectorlike-case (visitor obj)
- (cons "IGC_OBJ_VECTOR"
- (lambda ()
- (igccg--emit-call visitor
- (aref (igccg--scan-vectorlike-spec visitor) 0)
- obj
+ `(case IGC_OBJ_VECTOR
+ ,(lambda ()
+ (igccg--emit-call visitor
+ (aref (igccg--scan-vectorlike-spec visitor) 0)
+ obj
'(struct Lisp_Vector)))))
(defun igccg--emit-scan-object-body (visitor layouts)
- (let* ((alist (seq-group-by #'igccg--layout.header layouts))
+ (let* ((alist (seq-group-by #'igccg--layout.type layouts))
(pvecs (assq 'IGC_OBJ_VECTOR alist))
(nonpvecs (mapcar (lambda (p)
(pcase-exhaustive p
@@ -368,14 +392,12 @@ igccg--emit-scan-object-body
(igccg--scan-method-case visitor "client" layout))
nonpvecs)
(list (igccg--scan-method-vectorlike-case visitor "client"))
- (mapcar (lambda (type) (cons (symbol-name type) (lambda ())))
- ignored)
- (mapcar (lambda (type) (cons (symbol-name type) #'igccg--emit-abort))
- unhandled)))))
+ (mapcar (lambda (type) `(case ,type ,(lambda ()))) ignored)
+ (mapcar (lambda (type) `(case ,type ,#'igccg--emit-abort)) unhandled)))))
(defun igccg--emit-scan-object (visitor layouts)
(mapc (lambda (l) (igccg--emit-scan-method visitor l)) layouts)
- (let* ((alist (seq-group-by #'igccg--layout.header layouts))
+ (let* ((alist (seq-group-by #'igccg--layout.type layouts))
(pvecs (cdr (assq 'IGC_OBJ_VECTOR alist))))
(igccg--emit-scan-vectorlike visitor pvecs)
(igccg--emit-function
@@ -389,12 +411,12 @@ igccg--emit-scan-object
(defvar igccg--layouts
(list
(igccg--make-layout
- 'cons 'IGC_OBJ_CONS nil 'Lisp_Cons '(struct Lisp_Cons)
+ 'cons 'IGC_OBJ_CONS nil 'Lisp_Cons nil '(struct Lisp_Cons)
'((tagged (path u s car))
(tagged (path u s u cdr))))
(igccg--make-layout
- 'symbol 'IGC_OBJ_SYMBOL nil 'Lisp_Symbol '(struct Lisp_Symbol)
+ 'symbol 'IGC_OBJ_SYMBOL nil 'Lisp_Symbol nil '(struct Lisp_Symbol)
'((tagged (path u s name))
(tagged (path u s function))
(tagged (path u s plist))
@@ -419,7 +441,7 @@ igccg--layouts
->predicate")))))))
(igccg--make-layout
- 'interval 'IGC_OBJ_INTERVAL nil nil '(struct interval)
+ 'interval 'IGC_OBJ_INTERVAL nil nil nil '(struct interval)
'((untagged left)
(untagged right)
(switch up_obj
@@ -428,26 +450,26 @@ igccg--layouts
(tagged plist)))
(igccg--make-layout
- 'string 'IGC_OBJ_STRING nil 'Lisp_String '(struct Lisp_String)
+ 'string 'IGC_OBJ_STRING nil 'Lisp_String nil '(struct Lisp_String)
'((untagged (path u s data))
(untagged (path u s intervals))))
(igccg--make-layout
- 'string_data 'IGC_OBJ_STRING_DATA nil nil '(array uint8_t) nil)
+ 'string_data 'IGC_OBJ_STRING_DATA nil nil nil '(array uint8_t) nil)
(igccg--make-layout
- 'itree_tree 'IGC_OBJ_ITREE_TREE nil nil '(struct itree_tree)
+ 'itree_tree 'IGC_OBJ_ITREE_TREE nil nil nil '(struct itree_tree)
'((untagged root)))
(igccg--make-layout
- 'itree_node 'IGC_OBJ_ITREE_NODE nil nil '(struct itree_node)
+ 'itree_node 'IGC_OBJ_ITREE_NODE nil nil nil '(struct itree_node)
'((untagged parent)
(untagged left)
(untagged right)
(tagged data)))
(igccg--make-layout
- 'image 'IGC_OBJ_IMAGE nil nil '(struct image)
+ 'image 'IGC_OBJ_IMAGE nil nil 'HAVE_WINDOW_SYSTEM '(struct image)
'((tagged spec)
(tagged dependencies)
(tagged lisp_data)
@@ -455,12 +477,13 @@ igccg--layouts
(untagged prev)))
(igccg--make-layout
- 'image_cache 'IGC_OBJ_IMAGE_CACHE nil nil '(struct image_cache)
+ 'image_cache 'IGC_OBJ_IMAGE_CACHE nil nil 'HAVE_WINDOW_SYSTEM
+ '(struct image_cache)
'((untagged images)
(untagged buckets)))
(igccg--make-layout
- 'face 'IGC_OBJ_FACE nil nil '(struct face)
+ 'face 'IGC_OBJ_FACE nil nil nil '(struct face)
'((array tagged lface "ARRAYELTS (%s->lface)")
(untagged font)
(untagged next)
@@ -471,98 +494,94 @@ igccg--layouts
(untagged extra))))
(igccg--make-layout
- 'face_cache 'IGC_OBJ_FACE_CACHE nil nil '(struct face_cache)
+ 'face_cache 'IGC_OBJ_FACE_CACHE nil nil nil '(struct face_cache)
'((untagged f)
(untagged faces_by_id)
(untagged buckets)))
(igccg--make-layout
- 'float 'IGC_OBJ_FLOAT nil 'Lisp_Float '(struct Lisp_Float)
+ 'float 'IGC_OBJ_FLOAT nil 'Lisp_Float nil '(struct Lisp_Float)
'())
(igccg--make-layout
- 'blv 'IGC_OBJ_BLV nil nil '(struct Lisp_Buffer_Local_Value)
+ 'blv 'IGC_OBJ_BLV nil nil nil '(struct Lisp_Buffer_Local_Value)
'((tagged where)
(tagged defcell)
(tagged valcell)))
- ;; (igccg--make-layout
- ;; 'weak_ref 'IGC_OBJ_WEAK 'Lisp_Vectorlike '(struct Lisp_Weak_Ref)
- ;; '((tagged ref)))
-
(igccg--make-layout
- 'ptr_vec 'IGC_OBJ_PTR_VEC nil nil '(* void)
+ 'ptr_vec 'IGC_OBJ_PTR_VEC nil nil nil '(* void)
'((array untagged "%s" (igc-header-len))))
(igccg--make-layout
- 'obj_vec 'IGC_OBJ_OBJ_VEC nil nil 'Lisp_Object
+ 'obj_vec 'IGC_OBJ_OBJ_VEC nil nil nil 'Lisp_Object
'((array tagged "%s" (igc-header-len))))
(igccg--make-layout
- 'handler 'IGC_OBJ_HANDLER nil nil '(struct handler)
+ 'handler 'IGC_OBJ_HANDLER nil nil nil '(struct handler)
'((tagged tag_or_ch)
(tagged val)
(untagged next)
(untagged nextfree)))
(igccg--make-layout
- 'bytes 'IGC_OBJ_BYTES nil nil '(array uint8_t) nil)
+ 'bytes 'IGC_OBJ_BYTES nil nil nil '(array uint8_t) nil)
(igccg--make-layout
- 'normal_vector 'IGC_OBJ_VECTOR 'PVEC_NORMAL_VECTOR 'Lisp_Vectorlike
+ 'normal_vector 'IGC_OBJ_VECTOR 'PVEC_NORMAL_VECTOR 'Lisp_Vectorlike nil
'(struct Lisp_Vector) '((array tagged contents (path header size))))
(igccg--make-layout
- 'weak_vector 'IGC_OBJ_VECTOR_WEAK 'PVEC_NORMAL_VECTOR 'Lisp_Vectorlike
+ 'weak_vector 'IGC_OBJ_VECTOR_WEAK 'PVEC_NORMAL_VECTOR 'Lisp_Vectorlike nil
'(struct Lisp_Vector) '((array tagged contents (path header size))))
(igccg--make-layout
- 'bignum 'IGC_OBJ_VECTOR 'PVEC_BIGNUM 'Lisp_Vectorlike
+ 'bignum 'IGC_OBJ_VECTOR 'PVEC_BIGNUM 'Lisp_Vectorlike nil
'(struct Lisp_Bignum) '())
(igccg--make-layout
- 'marker 'IGC_OBJ_VECTOR 'PVEC_MARKER 'Lisp_Vectorlike
+ 'marker 'IGC_OBJ_VECTOR 'PVEC_MARKER 'Lisp_Vectorlike nil
'(struct Lisp_Marker)
'((untagged buffer)
;;(untagged next)
))
(igccg--make-layout
- 'overlay 'IGC_OBJ_VECTOR 'PVEC_OVERLAY 'Lisp_Vectorlike
+ 'overlay 'IGC_OBJ_VECTOR 'PVEC_OVERLAY 'Lisp_Vectorlike nil
'(struct Lisp_Overlay)
'((untagged buffer)
(tagged plist)
(untagged interval)))
(igccg--make-layout
- 'finalizer 'IGC_OBJ_VECTOR 'PVEC_FINALIZER 'Lisp_Vectorlike
+ 'finalizer 'IGC_OBJ_VECTOR 'PVEC_FINALIZER 'Lisp_Vectorlike nil
'(struct Lisp_Finalizer)
'((tagged function)
(untagged next)
(untagged prev)))
(igccg--make-layout
- 'symbol_with_pos 'IGC_OBJ_VECTOR 'PVEC_SYMBOL_WITH_POS 'Lisp_Vectorlike
+ 'symbol_with_pos 'IGC_OBJ_VECTOR 'PVEC_SYMBOL_WITH_POS 'Lisp_Vectorlike nil
'(struct Lisp_Symbol_With_Pos)
'((vectorlike)))
(igccg--make-layout
- 'misc_ptr 'IGC_OBJ_VECTOR 'PVEC_MISC_PTR 'Lisp_Vectorlike
+ 'misc_ptr 'IGC_OBJ_VECTOR 'PVEC_MISC_PTR 'Lisp_Vectorlike nil
'(struct Lisp_Misc_Ptr)
'())
(igccg--make-layout
- 'user_ptr 'IGC_OBJ_VECTOR 'PVEC_USER_PTR 'Lisp_Vectorlike
+ 'user_ptr 'IGC_OBJ_VECTOR 'PVEC_USER_PTR 'Lisp_Vectorlike nil
'(struct Lisp_User_Ptr)
'())
(igccg--make-layout
- 'process 'IGC_OBJ_VECTOR 'PVEC_PROCESS 'Lisp_Vectorlike
+ 'process 'IGC_OBJ_VECTOR 'PVEC_PROCESS 'Lisp_Vectorlike nil
'(struct Lisp_Process)
'((vectorlike)))
(igccg--make-layout
- 'frame 'IGC_OBJ_VECTOR 'PVEC_FRAME 'Lisp_Vectorlike
+ 'frame 'IGC_OBJ_VECTOR 'PVEC_FRAME 'Lisp_Vectorlike nil
'(struct frame)
'((vectorlike)
(untagged face_cache)
@@ -570,7 +589,7 @@ igccg--layouts
(quirks)))
(igccg--make-layout
- 'window 'IGC_OBJ_VECTOR 'PVEC_WINDOW 'Lisp_Vectorlike
+ 'window 'IGC_OBJ_VECTOR 'PVEC_WINDOW 'Lisp_Vectorlike nil
'(struct window)
'((vectorlike)
(tagged prev_buffers)
@@ -578,12 +597,12 @@ igccg--layouts
(quirks)))
(igccg--make-layout
- 'bool_vector 'IGC_OBJ_VECTOR 'PVEC_BOOL_VECTOR 'Lisp_Vectorlike
+ 'bool_vector 'IGC_OBJ_VECTOR 'PVEC_BOOL_VECTOR 'Lisp_Vectorlike nil
'(struct Lisp_Bool_Vector)
'())
(igccg--make-layout
- 'buffer 'IGC_OBJ_VECTOR 'PVEC_BUFFER 'Lisp_Vectorlike
+ 'buffer 'IGC_OBJ_VECTOR 'PVEC_BUFFER 'Lisp_Vectorlike nil
'(struct buffer)
'((vectorlike)
(untagged (path own_text intervals))
@@ -595,7 +614,7 @@ igccg--layouts
(quirks)))
(igccg--make-layout
- 'hash_table 'IGC_OBJ_VECTOR 'PVEC_HASH_TABLE 'Lisp_Vectorlike
+ 'hash_table 'IGC_OBJ_VECTOR 'PVEC_HASH_TABLE 'Lisp_Vectorlike nil
'(struct Lisp_Hash_Table)
'((untagged key)
(untagged value)
@@ -604,12 +623,12 @@ igccg--layouts
(untagged index)))
(igccg--make-layout
- 'obarray 'IGC_OBJ_VECTOR 'PVEC_OBARRAY 'Lisp_Vectorlike
+ 'obarray 'IGC_OBJ_VECTOR 'PVEC_OBARRAY 'Lisp_Vectorlike '(not IN_MY_FORK)
'(struct Lisp_Obarray)
'((untagged buckets)))
(igccg--make-layout
- 'terminal 'IGC_OBJ_VECTOR 'PVEC_TERMINAL 'Lisp_Vectorlike
+ 'terminal 'IGC_OBJ_VECTOR 'PVEC_TERMINAL 'Lisp_Vectorlike nil
'(struct terminal)
'((vectorlike)
(untagged next_terminal)
@@ -619,12 +638,12 @@ igccg--layouts
(igccg--make-layout
'window_configuraion 'IGC_OBJ_VECTOR 'PVEC_WINDOW_CONFIGURATION
- 'Lisp_Vectorlike
+ 'Lisp_Vectorlike nil
'vectorlike_header
'((vectorlike)))
(igccg--make-layout
- 'subr 'IGC_OBJ_VECTOR 'PVEC_SUBR 'Lisp_Vectorlike
+ 'subr 'IGC_OBJ_VECTOR 'PVEC_SUBR 'Lisp_Vectorlike nil
'(struct Lisp_Subr)
'((tagged command_modes)
(cfg
@@ -635,22 +654,22 @@ igccg--layouts
(tagged type))))
(igccg--make-layout
- 'other 'IGC_OBJ_VECTOR 'PVEC_OTHER 'Lisp_Vectorlike
+ 'other 'IGC_OBJ_VECTOR 'PVEC_OTHER 'Lisp_Vectorlike nil
'(struct scroll_bar)
'((vectorlike)))
(igccg--make-layout
- 'xwidget 'IGC_OBJ_VECTOR 'PVEC_XWIDGET 'Lisp_Vectorlike
+ 'xwidget 'IGC_OBJ_VECTOR 'PVEC_XWIDGET 'Lisp_Vectorlike nil
'vectorlike_header
'((vectorlike)))
(igccg--make-layout
- 'xwidget_view 'IGC_OBJ_VECTOR 'PVEC_XWIDGET_VIEW 'Lisp_Vectorlike
+ 'xwidget_view 'IGC_OBJ_VECTOR 'PVEC_XWIDGET_VIEW 'Lisp_Vectorlike nil
'vectorlike_header
'((vectorlike)))
(igccg--make-layout
- 'thread 'IGC_OBJ_VECTOR 'PVEC_THREAD 'Lisp_Vectorlike
+ 'thread 'IGC_OBJ_VECTOR 'PVEC_THREAD 'Lisp_Vectorlike nil
'(struct thread_state)
'((vectorlike)
(untagged m_current_buffer)
@@ -658,90 +677,95 @@ igccg--layouts
(untagged m_handlerlist)))
(igccg--make-layout
- 'mutex 'IGC_OBJ_VECTOR 'PVEC_MUTEX 'Lisp_Vectorlike
+ 'mutex 'IGC_OBJ_VECTOR 'PVEC_MUTEX 'Lisp_Vectorlike nil
'(struct Lisp_Mutex)
'((vectorlike)))
(igccg--make-layout
- 'condvar 'IGC_OBJ_VECTOR 'PVEC_CONDVAR 'Lisp_Vectorlike
+ 'condvar 'IGC_OBJ_VECTOR 'PVEC_CONDVAR 'Lisp_Vectorlike nil
'(struct Lisp_CondVar)
'((vectorlike)))
(igccg--make-layout
- 'module_function 'IGC_OBJ_VECTOR 'PVEC_MODULE_FUNCTION 'Lisp_Vectorlike
+ 'module_function 'IGC_OBJ_VECTOR 'PVEC_MODULE_FUNCTION 'Lisp_Vectorlike nil
'(struct module_global_reference)
'((vectorlike)))
(igccg--make-layout
'module_global_reference 'IGC_OBJ_VECTOR 'PVEC_MODULE_GLOBAL_REFERENCE
- 'Lisp_Vectorlike
+ 'Lisp_Vectorlike nil
'vectorlike_header
'((vectorlike)))
(igccg--make-layout
'comp_unit 'IGC_OBJ_VECTOR 'PVEC_NATIVE_COMP_UNIT
- 'Lisp_Vectorlike
+ 'Lisp_Vectorlike nil
'(struct Lisp_Native_Comp_Unit)
'((vectorlike)))
(igccg--make-layout
'ts_parser 'IGC_OBJ_VECTOR 'PVEC_TS_PARSER
- 'Lisp_Vectorlike
+ 'Lisp_Vectorlike nil
'(struct Lisp_TS_Parser)
'((vectorlike)))
(igccg--make-layout
'ts_node 'IGC_OBJ_VECTOR 'PVEC_TS_NODE
- 'Lisp_Vectorlike
+ 'Lisp_Vectorlike nil
'(struct Lisp_TS_Node)
'((vectorlike)))
(igccg--make-layout
'ts_query 'IGC_OBJ_VECTOR 'PVEC_TS_COMPILED_QUERY
- 'Lisp_Vectorlike
+ 'Lisp_Vectorlike nil
'(struct Lisp_TS_Query)
'((vectorlike)))
(igccg--make-layout
'sqlite 'IGC_OBJ_VECTOR 'PVEC_SQLITE
- 'Lisp_Vectorlike
+ 'Lisp_Vectorlike nil
'(struct Lisp_Sqlite)
'((vectorlike)))
- ;; (PVEC_WEAK_REF (struct Lisp_Weak_Ref))
-
(igccg--make-layout
'closure 'IGC_OBJ_VECTOR 'PVEC_CLOSURE
- 'Lisp_Vectorlike
+ 'Lisp_Vectorlike nil
'vectorlike_header
'((vectorlike)))
(igccg--make-layout
'char_table 'IGC_OBJ_VECTOR 'PVEC_CHAR_TABLE
- 'Lisp_Vectorlike
+ 'Lisp_Vectorlike nil
'(struct Lisp_Char_Table)
'((vectorlike)))
(igccg--make-layout
'sub_char_table 'IGC_OBJ_VECTOR 'PVEC_SUB_CHAR_TABLE
- 'Lisp_Vectorlike
+ 'Lisp_Vectorlike nil
'(struct Lisp_Sub_Char_Table)
'((array tagged contents (sub-char-table-len))))
(igccg--make-layout
- 'record 'IGC_OBJ_VECTOR 'PVEC_RECORD 'Lisp_Vectorlike
+ 'record 'IGC_OBJ_VECTOR 'PVEC_RECORD 'Lisp_Vectorlike nil
'vectorlike_header
'((vectorlike)))
(igccg--make-layout
- 'font 'IGC_OBJ_VECTOR 'PVEC_FONT 'Lisp_Vectorlike
+ 'font 'IGC_OBJ_VECTOR 'PVEC_FONT 'Lisp_Vectorlike nil
'(struct Lisp_Vector)
'((vectorlike)
(switch (pvec-header-size)
(FONT_SPEC_MAX)
(FONT_ENTITY_MAX)
(FONT_OBJECT_MAX (quirks))
- (default (abort)))))))
+ (default (abort)))))
+
+ (igccg--make-layout
+ 'package 'IGC_OBJ_VECTOR 'PVEC_PACKAGE 'Lisp_Vectorlike 'IN_MY_FORK
+ 'vectorlike_header
+ '((vectorlike)))
+
+ ))
(defun igccg-main ()
(igccg--emit-line "/* Generated by igc-codegen.el */")
@@ -750,5 +774,3 @@ igccg-main
(igccg--emit-scan-object 'dflt igccg--layouts)
(igccg--emit-scan-object 'mirror igccg--layouts)
(igccg--emit-line "#pragma GCC diagnostic pop"))
-
-;; (igccg-main)
diff --git a/src/igc.c b/src/igc.c
index 12d2472bc69..7f213909677 100644
--- a/src/igc.c
+++ b/src/igc.c
@@ -992,6 +992,15 @@ fix_font_quirks (mps_ss_t ss, struct font *f)
static void mirror_nobj (struct igc_mirror *m, Lisp_Object *array, size_t n);
static void mirror_nraw (struct igc_mirror *m, mps_addr_t array[], size_t n);
+static void
+mirror_buffer_quirks (struct buffer *b)
+{
+ if (b->base_buffer)
+ b->text = &b->base_buffer->own_text;
+ else
+ b->text = &b->own_text;
+}
+
#include "igc-generated.c"
static mps_res_t
--
2.39.2
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #5: 0004-Fix-code-genarator.patch --]
[-- Type: text/x-diff, Size: 2424 bytes --]
From 1b1a63d3231d7928ec843d8bdca24cee9bdc6289 Mon Sep 17 00:00:00 2001
From: Helmut Eller <eller.helmut@gmail.com>
Date: Thu, 13 Jun 2024 10:24:53 +0200
Subject: [PATCH 4/5] Fix code genarator
* admin/igc-codegen.el (igccg--obj-types)
(igccg--layouts): Add IGC_OBJ_HASH_VEC.
* src/igc.c (dflt_scanx_obj): Fix nbytes.
---
admin/igc-codegen.el | 10 +++++++++-
src/igc.c | 4 ++--
2 files changed, 11 insertions(+), 3 deletions(-)
diff --git a/admin/igc-codegen.el b/admin/igc-codegen.el
index f9a6c02827a..e83279dd9c2 100644
--- a/admin/igc-codegen.el
+++ b/admin/igc-codegen.el
@@ -24,6 +24,7 @@ igccg--obj-types
IGC_OBJ_BLV
IGC_OBJ_PTR_VEC
IGC_OBJ_OBJ_VEC
+ IGC_OBJ_HASH_VEC
IGC_OBJ_HANDLER
IGC_OBJ_BYTES
IGC_OBJ_BUILTIN_SYMBOL
@@ -420,7 +421,10 @@ igccg--layouts
'((tagged (path u s name))
(tagged (path u s function))
(tagged (path u s plist))
- (untagged (path u s next))
+ (cfg (not IN_MY_FORK)
+ (untagged (path u s next)))
+ (cfg IN_MY_FORK
+ (tagged (path u s package)))
(switch
(path u s redirect)
(SYMBOL_PLAINVAL (tagged (path u s val value)))
@@ -517,6 +521,10 @@ igccg--layouts
'obj_vec 'IGC_OBJ_OBJ_VEC nil nil nil 'Lisp_Object
'((array tagged "%s" (igc-header-len))))
+ (igccg--make-layout
+ 'hash_vec 'IGC_OBJ_HASH_VEC nil nil nil 'Lisp_Object
+ '((array tagged "%s" (igc-header-len))))
+
(igccg--make-layout
'handler 'IGC_OBJ_HANDLER nil nil nil '(struct handler)
'((tagged tag_or_ch)
diff --git a/src/igc.c b/src/igc.c
index 7f213909677..41d99419dbd 100644
--- a/src/igc.c
+++ b/src/igc.c
@@ -1655,14 +1655,14 @@ dflt_scanx_obj (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
struct igc_stats *st = closure;
mps_word_t obj_type = header->obj_type;
igc_assert (obj_type < IGC_OBJ_NUM_TYPES);
- st->obj[obj_type].nwords += header->nwords;
+ st->obj[obj_type].nbytes += header_nbytes (header);
st->obj[obj_type].nobjs += 1;
if (obj_type == IGC_OBJ_VECTOR)
{
struct Lisp_Vector *v = (struct Lisp_Vector *)client;
enum pvec_type pvec_type = pseudo_vector_type (v->header);
igc_assert (0 <= pvec_type && pvec_type <= PVEC_TAG_MAX);
- st->pvec[pvec_type].nwords += header->nwords;
+ st->pvec[pvec_type].nbytes += header_nbytes (header);
st->pvec[pvec_type].nobjs += 1;
}
}
--
2.39.2
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #6: 0005-Remove-the-code-that-is-now-generated.patch --]
[-- Type: text/x-diff, Size: 45973 bytes --]
From 0ef81303fb6a0cb1b52e0e3483907eb4a02064a7 Mon Sep 17 00:00:00 2001
From: Helmut Eller <eller.helmut@gmail.com>
Date: Thu, 13 Jun 2024 10:59:39 +0200
Subject: [PATCH 5/5] Remove the code that is now generated
* src/igc.c:
---
src/igc.c | 1824 ++++++-----------------------------------------------
1 file changed, 177 insertions(+), 1647 deletions(-)
diff --git a/src/igc.c b/src/igc.c
index 41d99419dbd..7d16449d6a7 100644
--- a/src/igc.c
+++ b/src/igc.c
@@ -745,78 +745,6 @@ scan_staticvec (mps_ss_t ss, void *start, void *end, void *closure)
return MPS_RES_OK;
}
-#if 0
-static mps_res_t
-fix_fwd (mps_ss_t ss, lispfwd fwd)
-{
- MPS_SCAN_BEGIN (ss)
- {
- switch (XFWDTYPE (fwd))
- {
- case Lisp_Fwd_Int:
- case Lisp_Fwd_Bool:
- case Lisp_Fwd_Kboard_Obj:
- break;
-
- case Lisp_Fwd_Obj:
- {
- /* It is not guaranteed that we see all of these when
- scanning staticvec because of DEFVAR_LISP_NOPRO. */
- struct Lisp_Objfwd *o = (void *) fwd.fwdptr;
- IGC_FIX12_OBJ (ss, o->objvar);
- }
- break;
-
- case Lisp_Fwd_Buffer_Obj:
- {
- struct Lisp_Buffer_Objfwd *b = (void *) fwd.fwdptr;
- IGC_FIX12_OBJ (ss, &b->predicate);
- }
- break;
- }
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_symbol (mps_ss_t ss, struct Lisp_Symbol *sym)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX12_OBJ (ss, &sym->u.s.name);
- IGC_FIX12_OBJ (ss, &sym->u.s.function);
- IGC_FIX12_OBJ (ss, &sym->u.s.plist);
-#ifdef IN_MY_FORK
- IGC_FIX12_OBJ (ss, &sym->u.s.package);
-#else
- IGC_FIX12_RAW (ss, &sym->u.s.next);
-#endif
- switch (sym->u.s.redirect)
- {
- case SYMBOL_PLAINVAL:
- IGC_FIX12_OBJ (ss, &sym->u.s.val.value);
- break;
-
- case SYMBOL_VARALIAS:
- IGC_FIX12_RAW (ss, &sym->u.s.val.alias);
- break;
-
- case SYMBOL_LOCALIZED:
- IGC_FIX12_RAW (ss, &sym->u.s.val.blv);
- break;
-
- case SYMBOL_FORWARDED:
- IGC_FIX_CALL (ss, fix_fwd (ss, sym->u.s.val.fwd));
- break;
- }
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
/* This exists because we need access to a threads' current specpdl
pointer, which means we need access to the thread_state, which can
@@ -1306,1055 +1234,221 @@ dflt_skip (mps_addr_t base_addr)
return next;
}
-#if 0
static mps_res_t
-fix_string (mps_ss_t ss, struct Lisp_String *s)
+dflt_scanx_obj (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
+ void *closure)
{
MPS_SCAN_BEGIN (ss)
{
- IGC_FIX12_RAW (ss, &s->u.s.data);
- IGC_FIX12_RAW (ss, &s->u.s.intervals);
+ mps_addr_t base = base_start;
+ mps_addr_t client = base_to_client (base);
+ struct igc_header *header = base;
+
+ if (closure)
+ {
+ struct igc_stats *st = closure;
+ mps_word_t obj_type = header->obj_type;
+ igc_assert (obj_type < IGC_OBJ_NUM_TYPES);
+ st->obj[obj_type].nbytes += header_nbytes (header);
+ st->obj[obj_type].nobjs += 1;
+ if (obj_type == IGC_OBJ_VECTOR)
+ {
+ struct Lisp_Vector *v = (struct Lisp_Vector *)client;
+ enum pvec_type pvec_type = pseudo_vector_type (v->header);
+ igc_assert (0 <= pvec_type && pvec_type <= PVEC_TAG_MAX);
+ st->pvec[pvec_type].nbytes += header_nbytes (header);
+ st->pvec[pvec_type].nobjs += 1;
+ }
+ }
+
+ IGC_FIX_CALL (ss, dflt_scan_object (ss, base));
}
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
-#endif
-#if 0
static mps_res_t
-fix_interval (mps_ss_t ss, struct interval *iv)
+dflt_scanx (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
+ void *closure)
{
MPS_SCAN_BEGIN (ss)
{
- IGC_FIX12_RAW (ss, &iv->left);
- IGC_FIX12_RAW (ss, &iv->right);
- if (iv->up_obj)
- IGC_FIX12_OBJ (ss, &iv->up.obj);
- else if (iv->up.interval)
- IGC_FIX12_RAW (ss, &iv->up.interval);
- IGC_FIX12_OBJ (ss, &iv->plist);
+ for (mps_addr_t base = base_start; base < base_limit;
+ base = dflt_skip (base))
+ IGC_FIX_CALL (ss, dflt_scanx_obj (ss, base, base_limit, closure));
}
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
-#endif
-#if 0
static mps_res_t
-fix_itree_tree (mps_ss_t ss, struct itree_tree *t)
+dflt_scan (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit)
{
MPS_SCAN_BEGIN (ss)
{
- if (t->root)
- IGC_FIX12_RAW (ss, &t->root);
+ for (mps_addr_t base = base_start; base < base_limit;
+ base = dflt_skip (base))
+ IGC_FIX_CALL (ss, dflt_scan_object (ss, base));
}
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
-#endif
-#if 0
+/* This is here because main_thread is, for some reason, a variable in
+ the data segment, and not like other threads. */
+
static mps_res_t
-fix_itree_node (mps_ss_t ss, struct itree_node *n)
+scan_main_thread (mps_ss_t ss, void *start, void *end, void *closure)
{
+ igc_assert (start == (void *) &main_thread);
MPS_SCAN_BEGIN (ss)
{
- if (n->parent)
- IGC_FIX12_RAW (ss, &n->parent);
- if (n->left)
- IGC_FIX12_RAW (ss, &n->left);
- if (n->right)
- IGC_FIX12_RAW (ss, &n->right);
- IGC_FIX12_OBJ (ss, &n->data);
+ struct thread_state *s = start;
+ IGC_FIX_CALL (ss, fix_thread (ss, s));
}
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
-#endif
-#if 0
+#ifdef HAVE_XWIDGETS
+
static mps_res_t
-fix_image (mps_ss_t ss, struct image *i)
+fix_xwidget (mps_ss_t ss, struct xwidget *w)
{
MPS_SCAN_BEGIN (ss)
{
-#ifdef HAVE_WINDOW_SYSTEM
- IGC_FIX12_OBJ (ss, &i->spec);
- IGC_FIX12_OBJ (ss, &i->dependencies);
- IGC_FIX12_OBJ (ss, &i->lisp_data);
- IGC_FIX12_RAW (ss, &i->next);
- IGC_FIX12_RAW (ss, &i->prev);
-#endif
+ IGC_FIX_CALL_FN (ss, struct Lisp_Vector, w, fix_vectorlike);
+ igc_assert (!"xwidget");
}
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
-#endif
-#if 0
static mps_res_t
-fix_image_cache (mps_ss_t ss, struct image_cache *c)
+fix_xwidget_view (mps_ss_t ss, struct xwidget_view *v)
{
MPS_SCAN_BEGIN (ss)
{
-#ifdef HAVE_WINDOW_SYSTEM
- IGC_FIX12_RAW (ss, &c->images);
- IGC_FIX12_RAW (ss, &c->buckets);
-#endif
+ IGC_FIX_CALL_FN (ss, struct Lisp_Vector, v, fix_vectorlike);
+ igc_assert (!"xwidget_view");
}
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
-#endif
-#if 0
-static mps_res_t
-fix_face (mps_ss_t ss, struct face *f)
+#endif // HAVE_XWIDGETS
+
+static igc_scan_result_t
+scan_cell_callback (struct igc_opaque *op, Lisp_Object *addr)
{
+ mps_ss_t ss = (mps_ss_t)op;
MPS_SCAN_BEGIN (ss)
{
- IGC_FIX12_NOBJS (ss, f->lface, ARRAYELTS (f->lface));
- IGC_FIX12_RAW (ss, &f->font);
- IGC_FIX12_RAW (ss, &f->next);
- IGC_FIX12_RAW (ss, &f->prev);
- IGC_FIX12_RAW (ss, &f->ascii_face);
-#if defined HAVE_XFT || defined HAVE_FREETYPE
- IGC_FIX12_RAW (ss, &f->extra);
-#endif
+ IGC_FIX12_OBJ (ss, addr);
}
MPS_SCAN_END (ss);
return MPS_RES_OK;
}
-#endif
-#if 0
-static mps_res_t
-fix_face_cache (mps_ss_t ss, struct face_cache *c)
+#pragma GCC diagnostic pop
+
+static igc_root_list *
+root_create (struct igc *gc, void *start, void *end, mps_rank_t rank,
+ mps_area_scan_t scan, void *closure, bool ambig)
{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX12_RAW (ss, &c->f);
- IGC_FIX12_RAW (ss, &c->faces_by_id);
- IGC_FIX12_RAW (ss, &c->buckets);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
+ mps_root_t root;
+ mps_res_t res
+ = mps_root_create_area (&root, gc->arena, rank, 0, start, end, scan,
+ closure);
+ IGC_CHECK_RES (res);
+ return register_root (gc, root, start, end, ambig);
}
-#endif
-#if 0
-static mps_res_t
-fix_ptr_vec (mps_ss_t ss, void *client)
+static igc_root_list *
+root_create_ambig (struct igc *gc, void *start, void *end)
{
- MPS_SCAN_BEGIN (ss)
- {
- void **v = client;
- size_t n = object_nelems (client, sizeof *v);
- for (size_t i = 0; i < n; ++i)
- IGC_FIX12_RAW (ss, &v[i]);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
+ return root_create (gc, start, end, mps_rank_ambig (), scan_ambig, NULL,
+ true);
}
-#endif
-#if 0
-static mps_res_t
-fix_obj_vec (mps_ss_t ss, Lisp_Object *v)
+static igc_root_list *
+root_create_exact (struct igc *gc, void *start, void *end,
+ mps_area_scan_t scan)
{
- MPS_SCAN_BEGIN (ss)
- {
- size_t n = object_nelems (v, sizeof *v);
- for (size_t i = 0; i < n; ++i)
- IGC_FIX12_OBJ (ss, &v[i]);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
+ return root_create (gc, start, end, mps_rank_exact (), scan, NULL, false);
}
-#endif
-#if 0
-static mps_res_t
-fix_cons (mps_ss_t ss, struct Lisp_Cons *cons)
+static void
+root_create_staticvec (struct igc *gc)
{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX12_OBJ (ss, &cons->u.s.car);
- IGC_FIX12_OBJ (ss, &cons->u.s.u.cdr);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
+ root_create_exact (gc, staticvec, staticvec + ARRAYELTS (staticvec),
+ scan_staticvec);
}
-#endif
-#if 0
-static mps_res_t
-fix_blv (mps_ss_t ss, struct Lisp_Buffer_Local_Value *blv)
+static void
+root_create_lispsym (struct igc *gc)
{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX12_OBJ (ss, &blv->where);
- IGC_FIX12_OBJ (ss, &blv->defcell);
- IGC_FIX12_OBJ (ss, &blv->valcell);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
+ root_create_exact (gc, lispsym, lispsym + ARRAYELTS (lispsym), scan_lispsym);
}
-#endif
-#if 0
-static mps_res_t
-fix_handler (mps_ss_t ss, struct handler *h)
+static void
+root_create_buffer (struct igc *gc, struct buffer *b)
{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX12_OBJ (ss, &h->tag_or_ch);
- IGC_FIX12_OBJ (ss, &h->val);
- IGC_FIX12_RAW (ss, &h->next);
- IGC_FIX12_RAW (ss, &h->nextfree);
- // FIXME: What about bytecode_top?
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
+ void *start = &b->name_, *end = &b->own_text;
+ root_create_ambig (gc, start, end);
}
-#endif
-
-#if 0
-static mps_res_t fix_vector (mps_ss_t ss, struct Lisp_Vector *v);
-#endif
-#if 0
-static mps_res_t
-dflt_scan_obj (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
- void *closure)
+static void
+root_create_terminal_list (struct igc *gc)
{
- MPS_SCAN_BEGIN (ss)
- {
- mps_addr_t base = base_start;
- mps_addr_t client = base_to_client (base);
- struct igc_header *header = base;
+ void *start = &terminal_list;
+ void *end = (char *) start + sizeof (terminal_list);
+ root_create_ambig (gc, start, end);
+}
- if (closure)
- {
- struct igc_stats *st = closure;
- mps_word_t obj_type = header->obj_type;
- igc_assert (obj_type < IGC_OBJ_NUM_TYPES);
- st->obj[obj_type].nbytes += header_nbytes (header);
- st->obj[obj_type].nobjs += 1;
- if (obj_type == IGC_OBJ_VECTOR)
- {
- struct Lisp_Vector* v = (struct Lisp_Vector*) client;
- enum pvec_type pvec_type = pseudo_vector_type (v);
- igc_assert (0 <= pvec_type && pvec_type <= PVEC_TAG_MAX);
- st->pvec[pvec_type].nbytes += header_nbytes (header);
- st->pvec[pvec_type].nobjs += 1;
- }
- }
+static void
+root_create_main_thread (struct igc *gc)
+{
+ void *start = &main_thread;
+ void *end = (char *) &main_thread + sizeof (main_thread);
+ root_create_exact (gc, start, end, scan_main_thread);
+}
- switch (header->obj_type)
- {
- case IGC_OBJ_INVALID:
- case IGC_OBJ_BUILTIN_SYMBOL:
- case IGC_OBJ_BUILTIN_THREAD:
- case IGC_OBJ_BUILTIN_SUBR:
- emacs_abort ();
-
- case IGC_OBJ_PAD:
- case IGC_OBJ_FWD:
- continue;
+void
+igc_root_create_ambig (void *start, void *end)
+{
+ root_create_ambig (global_igc, start, end);
+}
- case IGC_OBJ_HANDLER:
- IGC_FIX_CALL_FN (ss, struct handler, client, fix_handler);
- break;
+void
+igc_root_create_exact (Lisp_Object *start, Lisp_Object *end)
+{
+ root_create_exact (global_igc, start, end, scan_exact);
+}
- case IGC_OBJ_PTR_VEC:
- IGC_FIX_CALL_FN (ss, void *, client, fix_ptr_vec);
- break;
+void
+igc_root_create_exact_ptr (void *var_addr)
+{
+ void *start = var_addr;
+ void *end = (char *) start + sizeof (void *);
+ root_create_exact (global_igc, start, end, scan_ptr_exact);
+}
- case IGC_OBJ_OBJ_VEC:
- case IGC_OBJ_HASH_VEC:
- IGC_FIX_CALL_FN (ss, Lisp_Object, client, fix_obj_vec);
- break;
-
- case IGC_OBJ_CONS:
- IGC_FIX_CALL_FN (ss, struct Lisp_Cons, client, fix_cons);
- break;
-
- case IGC_OBJ_STRING_DATA:
- case IGC_OBJ_FLOAT:
- case IGC_OBJ_BYTES:
- /* Can occur in the dump. */
- break;
-
- case IGC_OBJ_NUM_TYPES:
- emacs_abort ();
-
- case IGC_OBJ_SYMBOL:
- IGC_FIX_CALL_FN (ss, struct Lisp_Symbol, client, fix_symbol);
- break;
-
- case IGC_OBJ_INTERVAL:
- IGC_FIX_CALL_FN (ss, struct interval, client, fix_interval);
- break;
-
- case IGC_OBJ_STRING:
- IGC_FIX_CALL_FN (ss, struct Lisp_String, client, fix_string);
- break;
-
- case IGC_OBJ_VECTOR:
- case IGC_OBJ_VECTOR_WEAK:
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, client, fix_vector);
- break;
-
- case IGC_OBJ_ITREE_TREE:
- IGC_FIX_CALL_FN (ss, struct itree_tree, client, fix_itree_tree);
- break;
-
- case IGC_OBJ_ITREE_NODE:
- IGC_FIX_CALL_FN (ss, struct itree_node, client, fix_itree_node);
- break;
-
- case IGC_OBJ_IMAGE:
- IGC_FIX_CALL_FN (ss, struct image, client, fix_image);
- break;
-
- case IGC_OBJ_IMAGE_CACHE:
- IGC_FIX_CALL_FN (ss, struct image_cache, client, fix_image_cache);
- break;
-
- case IGC_OBJ_FACE:
- IGC_FIX_CALL_FN (ss, struct face, client, fix_face);
- break;
-
- case IGC_OBJ_FACE_CACHE:
- IGC_FIX_CALL_FN (ss, struct face_cache, client, fix_face_cache);
- break;
-
- case IGC_OBJ_BLV:
- IGC_FIX_CALL_FN (ss, struct Lisp_Buffer_Local_Value, client, fix_blv);
- break;
- }
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-static mps_res_t
-dflt_scanx_obj (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
- void *closure)
-{
- MPS_SCAN_BEGIN (ss)
- {
- mps_addr_t base = base_start;
- mps_addr_t client = base_to_client (base);
- struct igc_header *header = base;
-
- if (closure)
- {
- struct igc_stats *st = closure;
- mps_word_t obj_type = header->obj_type;
- igc_assert (obj_type < IGC_OBJ_NUM_TYPES);
- st->obj[obj_type].nbytes += header_nbytes (header);
- st->obj[obj_type].nobjs += 1;
- if (obj_type == IGC_OBJ_VECTOR)
- {
- struct Lisp_Vector *v = (struct Lisp_Vector *)client;
- enum pvec_type pvec_type = pseudo_vector_type (v->header);
- igc_assert (0 <= pvec_type && pvec_type <= PVEC_TAG_MAX);
- st->pvec[pvec_type].nbytes += header_nbytes (header);
- st->pvec[pvec_type].nobjs += 1;
- }
- }
-
- IGC_FIX_CALL (ss, dflt_scan_object (ss, base));
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-
-static mps_res_t
-dflt_scanx (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
- void *closure)
-{
- MPS_SCAN_BEGIN (ss)
- {
- for (mps_addr_t base = base_start; base < base_limit;
- base = dflt_skip (base))
- IGC_FIX_CALL (ss, dflt_scanx_obj (ss, base, base_limit, closure));
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-
-static mps_res_t
-dflt_scan (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit)
-{
- MPS_SCAN_BEGIN (ss)
- {
- for (mps_addr_t base = base_start; base < base_limit;
- base = dflt_skip (base))
- IGC_FIX_CALL (ss, dflt_scan_object (ss, base));
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-
-#if 0
-static mps_res_t
-fix_vectorlike (mps_ss_t ss, struct Lisp_Vector *v)
-{
- MPS_SCAN_BEGIN (ss)
- {
- size_t size = vector_size (v);
- IGC_FIX12_NOBJS (ss, v->contents, size);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_buffer (mps_ss_t ss, struct buffer *b)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, b, fix_vectorlike);
- IGC_FIX12_RAW (ss, &b->own_text.intervals);
- IGC_FIX12_OBJ (ss, &b->own_text.markers);
- IGC_FIX12_RAW (ss, &b->overlays);
-
- IGC_FIX12_RAW (ss, &b->base_buffer);
- if (b->base_buffer)
- b->text = &b->base_buffer->own_text;
- else
- b->text = &b->own_text;
-
- // FIXME: special handling of undo_list?
- IGC_FIX12_OBJ (ss, &b->undo_list_);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_frame (mps_ss_t ss, struct frame *f)
-{
- MPS_SCAN_BEGIN (ss)
- {
- // FIXME
- // output_data;
- // terminal
- // glyph_pool
- // glyph matrices
- // struct font_driver_list *font_driver_list;
- // struct text_conversion_state conversion;
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, f, fix_vectorlike);
- IGC_FIX12_RAW (ss, &f->face_cache);
- if (f->terminal)
- IGC_FIX12_RAW (ss, &f->terminal);
- IGC_FIX_CALL_FN (ss, struct frame, f, fix_frame_quirks);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_window (mps_ss_t ss, struct window *w)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, w, fix_vectorlike);
- if (w->current_matrix)
- IGC_FIX_CALL (ss, fix_glyph_matrix (ss, w->current_matrix));
- if (w->desired_matrix)
- IGC_FIX_CALL (ss, fix_glyph_matrix (ss, w->desired_matrix));
-
- /* FIXME: The following two are handled specially in the old GC:
- Both are lists from which entries for non-live buffers are
- removed (mark_window -> mark_discard_killed_buffers).
- So, they are kind of weak lists. I think this could be done
- from a timer. */
- IGC_FIX12_OBJ (ss, &w->prev_buffers);
- IGC_FIX12_OBJ (ss, &w->next_buffers);
-
-#ifdef HAVE_NS
- void *pr[4];
- int n = ns_emacs_scroller_refs (w, pr, ARRAYELTS (pr));
- for (int i = 0; i < n; ++i)
- IGC_FIX12_RAW (ss, pr[i]);
-#endif
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_hash_table (mps_ss_t ss, struct Lisp_Hash_Table *h)
-{
- MPS_SCAN_BEGIN (ss)
- {
- // FIXME: weak
- IGC_FIX12_RAW (ss, &h->key);
- IGC_FIX12_RAW (ss, &h->value);
- IGC_FIX12_RAW (ss, &h->hash);
- IGC_FIX12_RAW (ss, &h->next);
- IGC_FIX12_RAW (ss, &h->index);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_char_table (mps_ss_t ss, struct Lisp_Char_Table *v)
-{
- MPS_SCAN_BEGIN (ss)
- {
- for (size_t i = vector_start (v), n = vector_size (v); i < n; ++i)
- IGC_FIX12_OBJ (ss, &v->contents[i]);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_sub_char_table (mps_ss_t ss, struct Lisp_Sub_Char_Table *v)
-{
- MPS_SCAN_BEGIN (ss)
- {
- int size = v->header.size & PSEUDOVECTOR_SIZE_MASK;
- IGC_FIX12_NOBJS (ss, v->contents, size - SUB_CHAR_TABLE_OFFSET);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_overlay (mps_ss_t ss, struct Lisp_Overlay *o)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX12_RAW (ss, &o->buffer);
- IGC_FIX12_OBJ (ss, &o->plist);
- IGC_FIX12_RAW (ss, &o->interval);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_subr (mps_ss_t ss, struct Lisp_Subr *s)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX12_OBJ (ss, &s->command_modes);
-#ifdef HAVE_NATIVE_COMP
- IGC_FIX12_OBJ (ss, &s->intspec.native);
- IGC_FIX12_OBJ (ss, &s->command_modes);
- IGC_FIX12_OBJ (ss, &s->native_comp_u);
- IGC_FIX12_OBJ (ss, &s->lambda_list);
- IGC_FIX12_OBJ (ss, &s->type);
-#endif
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_misc_ptr (mps_ss_t ss, struct Lisp_Misc_Ptr *p)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, p, fix_vectorlike);
- IGC_FIX12_RAW (ss, &p->pointer);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_user_ptr (mps_ss_t ss, struct Lisp_User_Ptr *p)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, p, fix_vectorlike);
- IGC_FIX12_RAW (ss, &p->p);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_thread (mps_ss_t ss, struct thread_state *s)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, s, fix_vectorlike);
- IGC_FIX12_RAW (ss, &s->m_current_buffer);
- IGC_FIX12_RAW (ss, &s->next_thread);
- IGC_FIX12_RAW (ss, &s->m_handlerlist);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-/* This is here because main_thread is, for some reason, a variable in
- the data segment, and not like other threads. */
-
-static mps_res_t
-scan_main_thread (mps_ss_t ss, void *start, void *end, void *closure)
-{
- igc_assert (start == (void *) &main_thread);
- MPS_SCAN_BEGIN (ss)
- {
- struct thread_state *s = start;
- IGC_FIX_CALL (ss, fix_thread (ss, s));
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-
-#if 0
-static mps_res_t
-fix_mutex (mps_ss_t ss, struct Lisp_Mutex *m)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, m, fix_vectorlike);
- IGC_FIX12_RAW (ss, &m->name);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_terminal (mps_ss_t ss, struct terminal *t)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, t, fix_vectorlike);
- IGC_FIX12_RAW (ss, &t->next_terminal);
-#ifdef HAVE_WINDOW_SYSTEM
- IGC_FIX12_RAW (ss, &t->image_cache);
-#endif
- // These are malloc'd, so they can be accessed.
- IGC_FIX_CALL_FN (ss, struct coding_system, t->keyboard_coding, fix_coding);
- IGC_FIX_CALL_FN (ss, struct coding_system, t->terminal_coding, fix_coding);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_marker (mps_ss_t ss, struct Lisp_Marker *m)
-{
- MPS_SCAN_BEGIN (ss)
- {
- if (m->buffer)
- IGC_FIX12_RAW (ss, &m->buffer);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_finalizer (mps_ss_t ss, struct Lisp_Finalizer *f)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, f, fix_vectorlike);
- IGC_FIX12_RAW (ss, &f->next);
- IGC_FIX12_RAW (ss, &f->prev);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#if 0
-static mps_res_t
-fix_comp_unit (mps_ss_t ss, struct Lisp_Native_Comp_Unit *u)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, u, fix_vectorlike);
- /* FIXME: Cannot scan things within the shared object because we
- don't have exclusive (synchronized) access to them. Instead of
- storing Lisp_Object references in vectors in the dylib data
- segment it would be much nicer to store them in MPS and give
- the dylib a pointer to them. */
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-#ifdef HAVE_XWIDGETS
-
-static mps_res_t
-fix_xwidget (mps_ss_t ss, struct xwidget *w)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, w, fix_vectorlike);
- igc_assert (!"xwidget");
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-
-static mps_res_t
-fix_xwidget_view (mps_ss_t ss, struct xwidget_view *v)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, v, fix_vectorlike);
- igc_assert (!"xwidget_view");
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-
-#endif // HAVE_XWIDGETS
-
-#ifdef HAVE_MODULES
-#if 0
-static mps_res_t
-fix_global_ref (mps_ss_t ss, struct module_global_reference *r)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, r, fix_vectorlike);
- IGC_FIX12_OBJ (ss, &r->value.v);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-#endif
-
-#ifndef IN_MY_FORK
-#if 0
-static mps_res_t
-fix_obarray (mps_ss_t ss, struct Lisp_Obarray *o)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX12_RAW (ss, &o->buckets);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-#endif
-
-#if 0
-static mps_res_t
-fix_font (mps_ss_t ss, struct Lisp_Vector *v)
-{
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, v, fix_vectorlike);
- /* See font.h for the magic numbers. */
- switch (vector_size (v))
- {
- case FONT_SPEC_MAX:
- case FONT_ENTITY_MAX:
- break;
- case FONT_OBJECT_MAX:
- {
- struct font *f = (struct font *)v;
- const Lisp_Object *type = &f->driver->type;
- IGC_FIX12_OBJ (ss, igc_const_cast (Lisp_Object *, type));
- }
- break;
- default:
- emacs_abort ();
- }
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-/* Note that there is a small window after committing a vectorlike
- allocation where the object is zeroed, and so the vector header is
- also zero. This doesn't have an adverse effect. */
-
-#if 0
-static mps_res_t
-fix_vector (mps_ss_t ss, struct Lisp_Vector *v)
-{
- MPS_SCAN_BEGIN (ss)
- {
- switch (pseudo_vector_type (v->header))
- {
-#ifndef IN_MY_FORK
- case PVEC_OBARRAY:
- IGC_FIX_CALL_FN (ss, struct Lisp_Obarray, v, fix_obarray);
- break;
-#endif
-
- case PVEC_BUFFER:
- IGC_FIX_CALL_FN (ss, struct buffer, v, fix_buffer);
- break;
-
- case PVEC_FRAME:
- IGC_FIX_CALL_FN (ss, struct frame, v, fix_frame);
- break;
-
- case PVEC_WINDOW:
- IGC_FIX_CALL_FN (ss, struct window, v, fix_window);
- break;
-
- case PVEC_HASH_TABLE:
- IGC_FIX_CALL_FN (ss, struct Lisp_Hash_Table, v, fix_hash_table);
- break;
-
- case PVEC_CHAR_TABLE:
- IGC_FIX_CALL_FN (ss, struct Lisp_Char_Table, v, fix_char_table);
- break;
-
- case PVEC_SUB_CHAR_TABLE:
- IGC_FIX_CALL_FN (ss, struct Lisp_Sub_Char_Table, v,
- fix_sub_char_table);
- break;
-
- case PVEC_BOOL_VECTOR:
- break;
-
- case PVEC_OVERLAY:
- IGC_FIX_CALL_FN (ss, struct Lisp_Overlay, v, fix_overlay);
- break;
-
- case PVEC_SUBR:
- IGC_FIX_CALL_FN (ss, struct Lisp_Subr, v, fix_subr);
- break;
-
- case PVEC_FREE:
- emacs_abort ();
-
- case PVEC_FINALIZER:
- IGC_FIX_CALL_FN (ss, struct Lisp_Finalizer, v, fix_finalizer);
- break;
-
- case PVEC_MISC_PTR:
- IGC_FIX_CALL_FN (ss, struct Lisp_Misc_Ptr, v, fix_misc_ptr);
- break;
-
- case PVEC_USER_PTR:
- IGC_FIX_CALL_FN (ss, struct Lisp_User_Ptr, v, fix_user_ptr);
- break;
-
-#ifdef HAVE_XWIDGETS
- case PVEC_XWIDGET:
- IGC_FIX_CALL_FN (ss, struct xwidget, v, fix_xwidget);
- break;
-
- case PVEC_XWIDGET_VIEW:
- IGC_FIX_CALL_FN (ss, struct xwidget_view, v, fix_xwidget_view);
- break;
-#endif
-
- case PVEC_THREAD:
- IGC_FIX_CALL_FN (ss, struct thread_state, v, fix_thread);
- break;
-
- case PVEC_MUTEX:
- IGC_FIX_CALL_FN (ss, struct Lisp_Mutex, v, fix_mutex);
- break;
-
- case PVEC_TERMINAL:
- IGC_FIX_CALL_FN (ss, struct terminal, v, fix_terminal);
- break;
-
- case PVEC_MARKER:
- IGC_FIX_CALL_FN (ss, struct Lisp_Marker, v, fix_marker);
- break;
-
- case PVEC_BIGNUM:
- break;
-
- case PVEC_NATIVE_COMP_UNIT:
- IGC_FIX_CALL_FN (ss, struct Lisp_Native_Comp_Unit, v, fix_comp_unit);
- break;
-
- case PVEC_MODULE_GLOBAL_REFERENCE:
-#ifdef HAVE_MODULES
- IGC_FIX_CALL_FN (ss, struct module_global_reference, v, fix_global_ref);
-#endif
- break;
-
- case PVEC_FONT:
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, v, fix_font);
- break;
-
- case PVEC_NORMAL_VECTOR:
- case PVEC_SYMBOL_WITH_POS:
- case PVEC_PROCESS:
- case PVEC_WINDOW_CONFIGURATION:
- case PVEC_XWIDGET:
- case PVEC_XWIDGET_VIEW:
- case PVEC_MODULE_FUNCTION:
- case PVEC_CONDVAR:
- case PVEC_TS_COMPILED_QUERY:
- case PVEC_TS_NODE:
- case PVEC_TS_PARSER:
- case PVEC_SQLITE:
- case PVEC_CLOSURE:
- case PVEC_RECORD:
- case PVEC_OTHER:
-#ifdef IN_MY_FORK
- case PVEC_PACKAGE:
-#endif
- IGC_FIX_CALL_FN (ss, struct Lisp_Vector, v, fix_vectorlike);
- break;
- }
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-#endif
-
-static igc_scan_result_t
-scan_cell_callback (struct igc_opaque *op, Lisp_Object *addr)
-{
- mps_ss_t ss = (mps_ss_t)op;
- MPS_SCAN_BEGIN (ss)
- {
- IGC_FIX12_OBJ (ss, addr);
- }
- MPS_SCAN_END (ss);
- return MPS_RES_OK;
-}
-
-#pragma GCC diagnostic pop
-
-static igc_root_list *
-root_create (struct igc *gc, void *start, void *end, mps_rank_t rank,
- mps_area_scan_t scan, void *closure, bool ambig)
-{
- mps_root_t root;
- mps_res_t res
- = mps_root_create_area (&root, gc->arena, rank, 0, start, end, scan,
- closure);
- IGC_CHECK_RES (res);
- return register_root (gc, root, start, end, ambig);
-}
-
-static igc_root_list *
-root_create_ambig (struct igc *gc, void *start, void *end)
-{
- return root_create (gc, start, end, mps_rank_ambig (), scan_ambig, NULL,
- true);
-}
-
-static igc_root_list *
-root_create_exact (struct igc *gc, void *start, void *end,
- mps_area_scan_t scan)
-{
- return root_create (gc, start, end, mps_rank_exact (), scan, NULL, false);
-}
-
-static void
-root_create_staticvec (struct igc *gc)
-{
- root_create_exact (gc, staticvec, staticvec + ARRAYELTS (staticvec),
- scan_staticvec);
-}
-
-static void
-root_create_lispsym (struct igc *gc)
-{
- root_create_exact (gc, lispsym, lispsym + ARRAYELTS (lispsym), scan_lispsym);
-}
-
-static void
-root_create_buffer (struct igc *gc, struct buffer *b)
-{
- void *start = &b->name_, *end = &b->own_text;
- root_create_ambig (gc, start, end);
-}
-
-static void
-root_create_terminal_list (struct igc *gc)
-{
- void *start = &terminal_list;
- void *end = (char *) start + sizeof (terminal_list);
- root_create_ambig (gc, start, end);
-}
-
-static void
-root_create_main_thread (struct igc *gc)
-{
- void *start = &main_thread;
- void *end = (char *) &main_thread + sizeof (main_thread);
- root_create_exact (gc, start, end, scan_main_thread);
-}
-
-void
-igc_root_create_ambig (void *start, void *end)
-{
- root_create_ambig (global_igc, start, end);
-}
-
-void
-igc_root_create_exact (Lisp_Object *start, Lisp_Object *end)
-{
- root_create_exact (global_igc, start, end, scan_exact);
-}
-
-void
-igc_root_create_exact_ptr (void *var_addr)
-{
- void *start = var_addr;
- void *end = (char *) start + sizeof (void *);
- root_create_exact (global_igc, start, end, scan_ptr_exact);
-}
-
-static void
-root_create_specpdl (struct igc_thread_list *t)
-{
- struct igc *gc = t->d.gc;
- struct thread_state *ts = t->d.ts;
- igc_assert (ts->m_specpdl != NULL);
- igc_assert (t->d.specpdl_root == NULL);
- mps_root_t root;
- mps_res_t res
- = mps_root_create_area (&root, gc->arena, mps_rank_exact (), 0,
- ts->m_specpdl, ts->m_specpdl_end, scan_specpdl, t);
- IGC_CHECK_RES (res);
- t->d.specpdl_root
- = register_root (gc, root, ts->m_specpdl, ts->m_specpdl_end, false);
-}
+static void
+root_create_specpdl (struct igc_thread_list *t)
+{
+ struct igc *gc = t->d.gc;
+ struct thread_state *ts = t->d.ts;
+ igc_assert (ts->m_specpdl != NULL);
+ igc_assert (t->d.specpdl_root == NULL);
+ mps_root_t root;
+ mps_res_t res
+ = mps_root_create_area (&root, gc->arena, mps_rank_exact (), 0,
+ ts->m_specpdl, ts->m_specpdl_end, scan_specpdl, t);
+ IGC_CHECK_RES (res);
+ t->d.specpdl_root
+ = register_root (gc, root, ts->m_specpdl, ts->m_specpdl_end, false);
+}
static void
root_create_bc (struct igc_thread_list *t)
@@ -4146,430 +3240,81 @@ mirror_lisp_obj (struct igc_mirror *m, Lisp_Object *pobj)
{
mps_addr_t base = client_to_base (client);
mps_addr_t mirror = lookup_copy (m, base);
- igc_assert (mirror != NULL);
- client = base_to_client (mirror);
- *p = (mps_word_t) client | tag;
- }
- }
-}
-
-static void
-mirror_raw (struct igc_mirror *m, mps_addr_t *p)
-{
- mps_addr_t client = *p;
- if (pdumper_object_p (client))
- {
- mps_addr_t base = client_to_base (client);
- mps_addr_t mirror = lookup_copy (m, base);
- igc_assert (mirror != NULL);
- *p = base_to_client (mirror);
- }
-}
-
-#define IGC_MIRROR_OBJ(m, obj) mirror_lisp_obj ((m), (obj))
-#define IGC_MIRROR_RAW(m, pp) mirror_raw ((m), (mps_addr_t *) (pp))
-
-static void
-mirror_nobj (struct igc_mirror *m, Lisp_Object *array, size_t n)
-{
- for (size_t i = 0; i < n; ++i)
- IGC_MIRROR_OBJ (m, &array[i]);
-}
-
-static void
-mirror_nraw (struct igc_mirror *m, mps_addr_t array[], size_t n)
-{
- for (size_t i = 0; i < n; ++i)
- mirror_raw (m, &array[i]);
-}
-
-#define IGC_MIRROR_NOBJS(m, a, n) mirror_nobj (m, a, n)
-
-static void
-mirror_fwd (struct igc_mirror *m, lispfwd fwd)
-{
- switch (XFWDTYPE (fwd))
- {
- case Lisp_Fwd_Int:
- case Lisp_Fwd_Bool:
- case Lisp_Fwd_Kboard_Obj:
- break;
-
- case Lisp_Fwd_Obj:
- {
- struct Lisp_Objfwd *o = (void *) fwd.fwdptr;
- IGC_MIRROR_OBJ (m, o->objvar);
- }
- break;
-
- case Lisp_Fwd_Buffer_Obj:
- {
- struct Lisp_Buffer_Objfwd *b = (void *) fwd.fwdptr;
- IGC_MIRROR_OBJ (m, &b->predicate);
- }
- break;
- }
-}
-
-#if 0
-static void
-mirror_symbol (struct igc_mirror *m, struct Lisp_Symbol *sym)
-{
- IGC_MIRROR_OBJ (m, &sym->u.s.name);
- IGC_MIRROR_OBJ (m, &sym->u.s.function);
- IGC_MIRROR_OBJ (m, &sym->u.s.plist);
-#ifdef IN_MY_FORK
- IGC_MIRROR_OBJ (m, &sym->u.s.package);
-#else
- IGC_MIRROR_RAW (m, &sym->u.s.next);
-#endif
- switch (sym->u.s.redirect)
- {
- case SYMBOL_PLAINVAL:
- IGC_MIRROR_OBJ (m, &sym->u.s.val.value);
- break;
-
- case SYMBOL_VARALIAS:
- IGC_MIRROR_RAW (m, &sym->u.s.val.alias);
- break;
-
- case SYMBOL_LOCALIZED:
- IGC_MIRROR_RAW (m, &sym->u.s.val.blv);
- break;
-
- case SYMBOL_FORWARDED:
- mirror_fwd (m, sym->u.s.val.fwd);
- break;
- }
-}
-#endif
-
-#if 0
-static void
-mirror_string (struct igc_mirror *m, struct Lisp_String *s)
-{
- IGC_MIRROR_RAW (m, &s->u.s.data);
- IGC_MIRROR_RAW (m, &s->u.s.intervals);
-}
-#endif
-
-#if 0
-static void
-mirror_interval (struct igc_mirror *m, struct interval *i)
-{
- IGC_MIRROR_RAW (m, &i->left);
- IGC_MIRROR_RAW (m, &i->right);
- if (i->up_obj)
- IGC_MIRROR_OBJ (m, &i->up.obj);
- else if (i->up.interval)
- IGC_MIRROR_RAW (m, &i->up.interval);
- IGC_MIRROR_OBJ (m, &i->plist);
-}
-#endif
-
-#if 0
-static void
-mirror_itree_tree (struct igc_mirror *m, struct itree_tree *t)
-{
- IGC_NOT_IMPLEMENTED ();
-}
-#endif
-
-#if 0
-static void
-mirror_itree_node (struct igc_mirror *m, struct itree_node *n)
-{
- if (n->parent)
- IGC_MIRROR_RAW (m, &n->parent);
- if (n->left)
- IGC_MIRROR_RAW (m, &n->left);
- if (n->right)
- IGC_MIRROR_RAW (m, &n->right);
- IGC_MIRROR_OBJ (m, &n->data);
-}
-#endif
-
-#if 0
-static void
-mirror_image (struct igc_mirror *m, struct image *i)
-{
- IGC_NOT_IMPLEMENTED ();
-}
-#endif
-
-#if 0
-static void
-mirror_image_cache (struct igc_mirror *m, struct image_cache *c)
-{
- IGC_NOT_IMPLEMENTED ();
-}
-#endif
-
-#if 0
-static void
-mirror_face (struct igc_mirror *m, struct face *f)
-{
- IGC_NOT_IMPLEMENTED ();
-}
-#endif
-
-#if 0
-static void
-mirror_face_cache (struct igc_mirror *m, struct face_cache *c)
-{
- IGC_NOT_IMPLEMENTED ();
-}
-#endif
-
-#if 0
-static void
-mirror_ptr_vec (struct igc_mirror *m, void *p)
-{
- IGC_NOT_IMPLEMENTED ();
-}
-#endif
-
-#if 0
-static void
-mirror_obj_vec (struct igc_mirror *m, Lisp_Object *v)
-{
- size_t n = object_nelems (v, sizeof *v);
- for (size_t i = 0; i < n; ++i)
- IGC_MIRROR_OBJ (m, &v[i]);
-}
-#endif
-
-#if 0
-static void
-mirror_handler (struct igc_mirror *m, struct handler *h)
-{
- IGC_NOT_IMPLEMENTED ();
-}
-#endif
-
-#if 0
-static void
-mirror_cons (struct igc_mirror *m, struct Lisp_Cons *c)
-{
- IGC_MIRROR_OBJ (m, &c->u.s.car);
- IGC_MIRROR_OBJ (m, &c->u.s.u.cdr);
-}
-#endif
-
-#if 0
-static void
-mirror_blv (struct igc_mirror *m, struct Lisp_Buffer_Local_Value *blv)
-{
- IGC_MIRROR_OBJ (m, &blv->where);
- IGC_MIRROR_OBJ (m, &blv->defcell);
- IGC_MIRROR_OBJ (m, &blv->valcell);
-}
-#endif
-
-static void
-mirror_vectorlike_ (struct igc_mirror *m, struct Lisp_Vector *v)
-{
- ptrdiff_t size = vector_size (v);
- IGC_MIRROR_NOBJS (m, v->contents, size);
-}
-
-#define IGC_MIRROR_VECTORLIKE(m, v) \
- mirror_vectorlike_ ((m), (struct Lisp_Vector *) (v))
-
-#ifndef IN_MY_FORK
-#if 0
-static void
-mirror_obarray (struct igc_mirror *m, struct Lisp_Obarray *o)
-{
- IGC_MIRROR_RAW (m, &o->buckets);
-}
-#endif
-#endif
-
-#if 0
-static void
-mirror_font (struct igc_mirror *m, struct Lisp_Vector *v)
-{
- IGC_MIRROR_VECTORLIKE (m, v);
- switch (vector_size (v))
- {
- case FONT_SPEC_MAX:
- case FONT_ENTITY_MAX:
- break;
-
- case FONT_OBJECT_MAX:
- {
- struct font *f = (struct font *) v;
- Lisp_Object const *type = &f->driver->type;
- IGC_MIRROR_OBJ (m, igc_const_cast (Lisp_Object *, type));
- }
- break;
-
- default:
- emacs_abort ();
- }
-}
-#endif
-
-#if 0
-static void
-mirror_mutex (struct igc_mirror *m, struct Lisp_Mutex *x)
-{
- IGC_NOT_IMPLEMENTED ();
-}
-#endif
-
-#if 0
-static void
-mirror_buffer (struct igc_mirror *m, struct buffer *b)
-{
- IGC_MIRROR_VECTORLIKE (m, b);
- IGC_MIRROR_RAW (m, &b->own_text.intervals);
- IGC_MIRROR_OBJ (m, &b->own_text.markers);
- IGC_MIRROR_RAW (m, &b->overlays);
-
- IGC_MIRROR_RAW (m, &b->base_buffer);
- if (b->base_buffer)
- b->text = &b->base_buffer->own_text;
- else
- b->text = &b->own_text;
-
- IGC_MIRROR_OBJ (m, &b->undo_list_);
-}
-#endif
-
-#if 0
-static void
-mirror_frame (struct igc_mirror *m, struct frame *f)
-{
- IGC_MIRROR_VECTORLIKE (m, f);
- IGC_MIRROR_RAW (m, &f->face_cache);
- if (f->terminal)
- IGC_MIRROR_RAW (m, &f->terminal);
-#ifdef HAVE_WINDOW_SYSTEM
- igc_assert (!FRAME_WINDOW_P (f));
-#endif
-}
-#endif
-
-#if 0
-static void
-mirror_window (struct igc_mirror *m, struct window *w)
-{
- IGC_MIRROR_VECTORLIKE (m, w);
- igc_assert (w->current_matrix == NULL);
- igc_assert (w->desired_matrix == NULL);
- IGC_MIRROR_OBJ (m, &w->prev_buffers);
- IGC_MIRROR_OBJ (m, &w->next_buffers);
+ igc_assert (mirror != NULL);
+ client = base_to_client (mirror);
+ *p = (mps_word_t) client | tag;
+ }
+ }
}
-#endif
-#if 0
static void
-mirror_hash_table (struct igc_mirror *m, struct Lisp_Hash_Table *h)
+mirror_raw (struct igc_mirror *m, mps_addr_t *p)
{
- IGC_MIRROR_RAW (m, &h->key);
- IGC_MIRROR_RAW (m, &h->value);
- IGC_MIRROR_RAW (m, &h->hash);
- IGC_MIRROR_RAW (m, &h->next);
- IGC_MIRROR_RAW (m, &h->index);
- igc_assert (!pdumper_object_p (h->key));
- igc_assert (!pdumper_object_p (h->value));
+ mps_addr_t client = *p;
+ if (pdumper_object_p (client))
+ {
+ mps_addr_t base = client_to_base (client);
+ mps_addr_t mirror = lookup_copy (m, base);
+ igc_assert (mirror != NULL);
+ *p = base_to_client (mirror);
+ }
}
-#endif
-#if 0
-static void
-mirror_char_table (struct igc_mirror *m, struct Lisp_Vector *v)
-{
- for (size_t i = vector_start (v), n = vector_size (v); i < n; ++i)
- IGC_MIRROR_OBJ (m, &v->contents[i]);
-}
-#endif
+#define IGC_MIRROR_OBJ(m, obj) mirror_lisp_obj ((m), (obj))
+#define IGC_MIRROR_RAW(m, pp) mirror_raw ((m), (mps_addr_t *) (pp))
-#if 0
static void
-mirror_overlay (struct igc_mirror *m, struct Lisp_Overlay *o)
+mirror_nobj (struct igc_mirror *m, Lisp_Object *array, size_t n)
{
- IGC_MIRROR_RAW (m, &o->buffer);
- IGC_MIRROR_OBJ (m, &o->plist);
- IGC_MIRROR_RAW (m, &o->interval);
+ for (size_t i = 0; i < n; ++i)
+ IGC_MIRROR_OBJ (m, &array[i]);
}
-#endif
-#if 0
static void
-mirror_subr (struct igc_mirror *m, struct Lisp_Subr *s)
+mirror_nraw (struct igc_mirror *m, mps_addr_t array[], size_t n)
{
- IGC_MIRROR_OBJ (m, &s->command_modes);
-#ifdef HAVE_NATIVE_COMP
- IGC_MIRROR_OBJ (m, &s->intspec.native);
- IGC_MIRROR_OBJ (m, &s->command_modes);
- IGC_MIRROR_OBJ (m, &s->native_comp_u);
- IGC_MIRROR_OBJ (m, &s->lambda_list);
- IGC_MIRROR_OBJ (m, &s->type);
-#endif
+ for (size_t i = 0; i < n; ++i)
+ mirror_raw (m, &array[i]);
}
-#endif
-#if 0
-static void
-mirror_misc_ptr (struct igc_mirror *m, struct Lisp_Misc_Ptr *p)
-{
- IGC_NOT_IMPLEMENTED ();
-}
-#endif
+#define IGC_MIRROR_NOBJS(m, a, n) mirror_nobj (m, a, n)
-#if 0
static void
-mirror_user_ptr (struct igc_mirror *m, struct Lisp_User_Ptr *p)
+mirror_fwd (struct igc_mirror *m, lispfwd fwd)
{
- IGC_NOT_IMPLEMENTED ();
-}
-#endif
+ switch (XFWDTYPE (fwd))
+ {
+ case Lisp_Fwd_Int:
+ case Lisp_Fwd_Bool:
+ case Lisp_Fwd_Kboard_Obj:
+ break;
-#if 0
-static void
-mirror_thread (struct igc_mirror *m, struct thread_state *s)
-{
- IGC_MIRROR_VECTORLIKE (m, s);
- IGC_MIRROR_RAW (m, &s->m_current_buffer);
- IGC_MIRROR_RAW (m, &s->next_thread);
- IGC_MIRROR_RAW (m, &s->m_handlerlist);
-}
-#endif
+ case Lisp_Fwd_Obj:
+ {
+ struct Lisp_Objfwd *o = (void *) fwd.fwdptr;
+ IGC_MIRROR_OBJ (m, o->objvar);
+ }
+ break;
-#if 0
-static void
-mirror_terminal (struct igc_mirror *m, struct terminal *t)
-{
- IGC_NOT_IMPLEMENTED ();
+ case Lisp_Fwd_Buffer_Obj:
+ {
+ struct Lisp_Buffer_Objfwd *b = (void *) fwd.fwdptr;
+ IGC_MIRROR_OBJ (m, &b->predicate);
+ }
+ break;
+ }
}
-#endif
-#if 0
static void
-mirror_marker (struct igc_mirror *m, struct Lisp_Marker *ma)
+mirror_vectorlike_ (struct igc_mirror *m, struct Lisp_Vector *v)
{
- IGC_MIRROR_RAW (m, &ma->buffer);
+ ptrdiff_t size = vector_size (v);
+ IGC_MIRROR_NOBJS (m, v->contents, size);
}
-#endif
-#if 0
-static void
-mirror_finalizer (struct igc_mirror *m, struct Lisp_Finalizer *f)
-{
- IGC_NOT_IMPLEMENTED ();
-}
-#endif
+#define IGC_MIRROR_VECTORLIKE(m, v) \
+ mirror_vectorlike_ ((m), (struct Lisp_Vector *) (v))
-#if 0
-static void
-mirror_comp_unit (struct igc_mirror *m, struct Lisp_Native_Comp_Unit *u)
-{
- IGC_MIRROR_VECTORLIKE (m, u);
-}
-#endif
#ifdef HAVE_XWIDGETS
static void
@@ -4593,221 +3338,6 @@ mirror_global_ref (struct igc_mirror *m, struct module_global_reference *r)
}
#endif
-#if 0
-static void
-mirror_vector (struct igc_mirror *m, struct Lisp_Vector *client)
-{
- switch (pseudo_vector_type (client->header))
- {
-#ifndef IN_MY_FORK
- case PVEC_OBARRAY:
- mirror_obarray (m, client);
- break;
-#endif
-
- case PVEC_BUFFER:
- mirror_buffer (m, client);
- break;
-
- case PVEC_FRAME:
- mirror_frame (m, client);
- break;
-
- case PVEC_WINDOW:
- mirror_window (m, client);
- break;
-
- case PVEC_HASH_TABLE:
- mirror_hash_table (m, client);
- break;
-
- case PVEC_CHAR_TABLE:
- case PVEC_SUB_CHAR_TABLE:
- mirror_char_table (m, client);
- break;
-
- case PVEC_BOOL_VECTOR:
- break;
-
- case PVEC_OVERLAY:
- mirror_overlay (m, client);
- break;
-
- case PVEC_SUBR:
- mirror_subr (m, client);
- break;
-
- case PVEC_FREE:
- emacs_abort ();
-
- case PVEC_FINALIZER:
- mirror_finalizer (m, client);
- break;
-
- case PVEC_MISC_PTR:
- mirror_misc_ptr (m, client);
- break;
-
- case PVEC_USER_PTR:
- mirror_user_ptr (m, client);
- break;
-
-#ifdef HAVE_XWIDGETS
- case PVEC_XWIDGET:
- mirror_xwidget (c, client);
- break;
-
- case PVEC_XWIDGET_VIEW:
- mirror_widget_view (c, client);
- break;
-#endif
-
- case PVEC_THREAD:
- mirror_thread (m, client);
- break;
-
- case PVEC_MUTEX:
- mirror_mutex (m, client);
- break;
-
- case PVEC_TERMINAL:
- mirror_terminal (m, client);
- break;
-
- case PVEC_MARKER:
- mirror_marker (m, client);
- break;
-
- case PVEC_BIGNUM:
- break;
-
- case PVEC_NATIVE_COMP_UNIT:
- mirror_comp_unit (m, client);
- break;
-
- case PVEC_MODULE_GLOBAL_REFERENCE:
-#ifdef HAVE_MODULES
- mirror_global_ref (m, client);
-#endif
- break;
-
- case PVEC_FONT:
- mirror_font (m, client);
- break;
-
- case PVEC_NORMAL_VECTOR:
- case PVEC_SYMBOL_WITH_POS:
- case PVEC_PROCESS:
- case PVEC_WINDOW_CONFIGURATION:
- case PVEC_XWIDGET:
- case PVEC_XWIDGET_VIEW:
- case PVEC_MODULE_FUNCTION:
- case PVEC_CONDVAR:
- case PVEC_TS_COMPILED_QUERY:
- case PVEC_TS_NODE:
- case PVEC_TS_PARSER:
- case PVEC_SQLITE:
- case PVEC_CLOSURE:
- case PVEC_RECORD:
- case PVEC_OTHER:
-#ifdef IN_MY_FORK
- case PVEC_PACKAGE:
-#endif
- IGC_MIRROR_VECTORLIKE (m, client);
- break;
- }
-}
-#endif
-
-#if 0
-static void
-mirror (struct igc_mirror *m, void *org_base, void *copy_base)
-{
- void *client = base_to_client (copy_base);
- struct igc_header *h = copy_base;
- switch (h->obj_type)
- {
- case IGC_OBJ_BUILTIN_SYMBOL:
- case IGC_OBJ_BUILTIN_THREAD:
- case IGC_OBJ_BUILTIN_SUBR:
- break;
-
- case IGC_OBJ_PAD:
- case IGC_OBJ_FWD:
- case IGC_OBJ_INVALID:
- case IGC_OBJ_NUM_TYPES:
- emacs_abort ();
-
- case IGC_OBJ_OBJ_VEC:
- case IGC_OBJ_HASH_VEC:
- mirror_obj_vec (m, client);
- break;
-
- case IGC_OBJ_HANDLER:
- mirror_handler (m, client);
- break;
-
- case IGC_OBJ_PTR_VEC:
- mirror_ptr_vec (m, client);
- break;
-
- case IGC_OBJ_CONS:
- mirror_cons (m, client);
- break;
-
- case IGC_OBJ_STRING_DATA:
- case IGC_OBJ_FLOAT:
- case IGC_OBJ_BYTES:
- break;
-
- case IGC_OBJ_SYMBOL:
- mirror_symbol (m, client);
- break;
-
- case IGC_OBJ_INTERVAL:
- mirror_interval (m, client);
- break;
-
- case IGC_OBJ_STRING:
- mirror_string (m, client);
- break;
-
- case IGC_OBJ_VECTOR:
- case IGC_OBJ_VECTOR_WEAK:
- mirror_vector (m, client);
- break;
-
- case IGC_OBJ_ITREE_TREE:
- mirror_itree_tree (m, client);
- break;
-
- case IGC_OBJ_ITREE_NODE:
- mirror_itree_node (m, client);
- break;
-
- case IGC_OBJ_IMAGE:
- mirror_image (m, client);
- break;
-
- case IGC_OBJ_IMAGE_CACHE:
- mirror_image_cache (m, client);
- break;
-
- case IGC_OBJ_FACE:
- mirror_face (m, client);
- break;
-
- case IGC_OBJ_FACE_CACHE:
- mirror_face_cache (m, client);
- break;
-
- case IGC_OBJ_BLV:
- mirror_blv (m, client);
- break;
- }
-}
-#endif
-
static void
mirror_references (struct igc_mirror *m)
{
--
2.39.2
^ permalink raw reply related [flat|nested] 62+ messages in thread