From 6c50ae682cd7f78954bab97f72c586acdf92be1f Mon Sep 17 00:00:00 2001 From: Helmut Eller 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