From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Helmut Eller Newsgroups: gmane.emacs.devel Subject: Re: MPS: Loaded pdump Date: Sat, 18 May 2024 20:55:45 +0200 Message-ID: <87y187lzke.fsf@gmail.com> References: <87bk5fp0km.fsf@gmail.com> <87seyrni6f.fsf@gmail.com> <87msoygkb5.fsf@gmail.com> <86seyq3qvr.fsf@gnu.org> <871q61etma.fsf@gmail.com> <87msop4j99.fsf@gmail.com> <86eda1gebd.fsf@gnu.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="21028"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Cc: gerd.moellmann@gmail.com, acorallo@gnu.org, emacs-devel@gnu.org To: Eli Zaretskii Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Sat May 18 20:56:41 2024 Return-path: Envelope-to: ged-emacs-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1s8PEX-0005MW-1c for ged-emacs-devel@m.gmane-mx.org; Sat, 18 May 2024 20:56:41 +0200 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1s8PDm-0003sC-BF; Sat, 18 May 2024 14:55:54 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1s8PDk-0003rN-3N for emacs-devel@gnu.org; Sat, 18 May 2024 14:55:52 -0400 Original-Received: from mail-wm1-x330.google.com ([2a00:1450:4864:20::330]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1s8PDh-00013n-Sl; Sat, 18 May 2024 14:55:51 -0400 Original-Received: by mail-wm1-x330.google.com with SMTP id 5b1f17b1804b1-4202cea98daso9781825e9.0; Sat, 18 May 2024 11:55:48 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1716058547; x=1716663347; darn=gnu.org; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:from:to:cc:subject:date:message-id:reply-to; bh=io488EsjpwN4dphSOkxpBJwV8m7eFRkgdLQwuZDuaGk=; b=DQp5xA5i6UasPd+7EZOBnMXE6J1QQUIxb4YEaUgOGI5ycw1Bsscu9jgyOtM8ykyXT9 vDtv8bMgq0KvtU257zWePBvklC6wUqxdGJL8r62u8PwVJmXeX6OWznvBrVl5iJ7q7d23 C4zxTWnNZsL/yVIADcL7P84PVrbPx9gHP8wFG7iOZU3FxvvmWO2xWi9G9B0I4er8129O OPl4/C/49CGQE9JbRBy+gWfuhHmT646hL8pILp+55CwY6RzVZWHll8yl/2AHKmpVZjx5 MMEMQJoyY/1Djeeows1LTUWTOyqbCeA5SnMycnc5fvpdpsi/Rchz2j3sHMKqFMbqu3IS zecw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1716058547; x=1716663347; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:x-gm-message-state:from:to:cc:subject:date :message-id:reply-to; bh=io488EsjpwN4dphSOkxpBJwV8m7eFRkgdLQwuZDuaGk=; b=SRNNDd4TMRzXAj1qS8m5dEC0jGi8cOtqiJsKxnHgacXxiOeuSKODO6DiKb6cUDGowU jO9D7xCoKGlfzi9YF899M/kms1u4UxBJwanqWYVIlONAvuVc4wimpGX7Dubby5yMSHvD /MXM6xdYuzeM6N87xZUVPh917qR15mcjCKDnnD+t1UOoC2Wer4swTDy5vK+bMBHqyK7X +6gk2Bd0uJsUrZtQqIUadLSVdHJ+jJvOO/3pzVEUzx3mV0JDHIk6ewbMUAE/plJQ88MW LWdDo+17BwH2i4VgC2RKT1rP1mtybnUfOtabIvsdPgckSM+RAGiA66RszljriBgo0i5P zoHw== X-Forwarded-Encrypted: i=1; AJvYcCVpGAX0Q4pk7609S3jQjmZmbSB4JwI2EKb2bdPM6XmW4CKWjIv8yUUuLNyimWCEmN7JofqnrIouslDAMuh61PYAZ9sdNPIYLghSdwARkxb7u67cr/z/ X-Gm-Message-State: AOJu0YysLHXH+dUvtCl54kcROImrAhfeJaGbbdwt3Jt7/O1Uf64Rxg9H UIrWd7i6XP09wd8PR1VOXQUbKNzMndNaFkI6jp6ZXGuBaX5pW3Vsbp3n5Q== X-Google-Smtp-Source: AGHT+IEM7XcbJDCclItw9xC+ST+aj00OoMMQzaI+Aq42VdT+iywMVwEarpqej2Kj0J+ZE2ZDQdiXvg== X-Received: by 2002:a05:600c:a42:b0:41f:ed4c:b8b6 with SMTP id 5b1f17b1804b1-41fed4ce79dmr220929855e9.38.1716058547087; Sat, 18 May 2024 11:55:47 -0700 (PDT) Original-Received: from caladan ([89.107.106.224]) by smtp.gmail.com with ESMTPSA id 5b1f17b1804b1-41fd11ef80esm352000545e9.39.2024.05.18.11.55.46 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sat, 18 May 2024 11:55:46 -0700 (PDT) In-Reply-To: <86eda1gebd.fsf@gnu.org> (Eli Zaretskii's message of "Fri, 17 May 2024 09:09:10 +0300") Received-SPF: pass client-ip=2a00:1450:4864:20::330; envelope-from=eller.helmut@gmail.com; helo=mail-wm1-x330.google.com X-Spam_score_int: -20 X-Spam_score: -2.1 X-Spam_bar: -- X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.emacs.devel:319352 Archived-At: --=-=-= Content-Type: text/plain On Fri, May 17 2024, Eli Zaretskii wrote: > As a one-time thing, I don't think anyone will care how the code was > obtained, as long as it is maintained by hand henceforth. > > But if you suggest this as a permanent inclusion into Emacs, then I > don't think we can go that way, since the tools to produce this are > neither standard ones available everywhere, nor something we can > include with Emacs. I think the goal is not to edit the generated code manually but to keep the code generator around and edit that if needed. > Given that Emacs now has tree-sitter bindings, I wonder whether the > same can be done in Emacs Lisp using tree-sitter for parsing. That'd > be acceptable, I think. That's an interesting idea. I tried to rewrite the Python code in Elisp and it works, after a fashion. The tree-sitter syntax tree is at a lower level than what libclang offers and I had to rewrite the tree quite a bit to make it easier to use. I also pipe the C source code through the preprocessor first, so that tree-sitter doesn't see macros. With macros, it's even harder to get some easy to use data structures out of it. I'm not sure how to proceed from here. Anyway the code is here: --=-=-= Content-Type: application/emacs-lisp Content-Disposition: attachment; filename=igc-codegen.el Content-Transfer-Encoding: quoted-printable ;; -*- lexical-binding: t -*- (require 'treesit) (require 'project) (defconst igccg--mps-structs '("Lisp_Symbol" "Lisp_String" "interval" "itree_node" "image" "Lisp_Cons")) (defun igccg--parse-c-code () (with-current-buffer (generate-new-buffer " igccg") (let* ((srcdir (expand-file-name "src/" (project-root (project-current)= ))) (status (call-process "make" nil t nil "-C" srcdir "--quiet" "--eval" "preproc-igc:\n\t$(CC) $(ALL_CFLAGS) -E -P igc.c\n" "preproc-igc"))) (cl-assert (equal status 0)) (treesit-parser-root-node (treesit-parser-create 'c))))) (defconst igccg--root (igccg--parse-c-code)) (defun igccg--lookup-struct-specifier (name) (let ((l (treesit-query-capture igccg--root `((struct_specifier name: (_) @name (:equal ,name @name) body: (_)))))) (when (null l) (error "Struct specifier not found: %s" name)) (treesit-node-parent (cdr (car l))))) ;;(igccg--lookup-struct-specifier "Lisp_Cons") (defun igccg--lookup-type-definition (name) (let ((l (treesit-query-capture igccg--root `((type_definition "typedef" type: (_) @type declarator: [(type_identifier) @name (pointer_declarator "*" declarator: (type_identifier) @name= )] (:equal ,name @name)))))) (when (null l) (error "Type definition not found: %s" name)) (treesit-node-parent (cdr (car l))))) ;;(igccg--lookup-type-definition "Lisp_Object") ;;(igccg--lookup-type-definition "Lisp_Word") ;;(igccg--lookup-type-definition "INTERVAL") ;; Convert a treesit-node to an sexp. Sexps are easier to match. (defun igccg--to-sexp (node) (let* ((type (intern (treesit-node-type node))) (children (treesit-node-children node))) (cons type (cond ((null children) (treesit-node-text node)) (t (mapcar (lambda (child) (let* ((name (treesit-node-field-name child)) (sexp (igccg--to-sexp child))) (cond (name (list (intern (concat name ":")) sexp)) (t sexp)))) children)))))) ;;(igccg--to-sexp (igccg--lookup-struct-specifier "Lisp_Cons")) (defun igccg--parse-field-declarator (decl type) (pcase-exhaustive decl (`(field_identifier . ,name) `(field ,name ,type)) (`(pointer_declarator (* . "*") (declarator: ,decl)) (igccg--parse-field-declarator decl `(* ,type))) (`(array_declarator (declarator: ,decl) (\[ . "[") (size: (number_literal . ,size)) (\] . "]")) (igccg--parse-field-declarator decl `(array ,type ,size))))) (defun igccg--parse-field-decl (fdecl) (pcase-exhaustive fdecl (`((type: ,type) (declarator: ,decl) (\; . ";")) (list (igccg--parse-field-declarator decl (igccg--parse-type type)))) (`((type: ,type) (declarator: (attribute_specifier . ,_)) ,decl (\; . "= ;")) (list (igccg--parse-field-declarator decl (igccg--parse-type type)))) (`((type: ,type) (declarator: (type_qualifier ,_)) ,decl (\; . ";")) (list (igccg--parse-field-declarator decl (igccg--parse-type type)))) (`((type: ,type) (declarator: ,decl) (bitfield_clause (: . ":") (number_literal . ,size)) (\; . ";")) (pcase-exhaustive (igccg--parse-field-declarator decl (igccg--parse-type ty= pe)) (`(field ,name ,type) (list `(field ,name (bitfield ,type ,size)))))) (`((type: ,type) (declarator: ,d1) (,'\, . ",") ,d2 . ,rest) (cons (igccg--parse-field-declarator d1 (igccg--parse-type type)) (igccg--parse-field-decl `((type: ,type) (declarator: ,d2) . ,rest)))) (`((type: ,type) (declarator: ,d1) (bitfield_clause (: . ,_) (number_literal . ,s1)) (,'\, . ",") ,d2 . ,rest) (pcase-exhaustive (igccg--parse-field-declarator d1 (igccg--parse-type ty= pe)) (`(field ,name ,ptype) (cons `(field ,name (bitfield ,ptype ,s1)) (igccg--parse-field-decl `((type: ,type) (declarator: ,d2) . ,rest)))))))) (defun igccg--unwrap-\#if (if) (pcase-exhaustive if (`((\#endif . ,_)) '()) (`(,x . ,rest) (cons x (igccg--unwrap-\#if rest))))) (defun igccg--parse-field-decls (fdecls) (pcase-exhaustive fdecls (`((field_declaration . ,fdecl) . ,rest) (append (igccg--parse-field-decl fdecl) (igccg--parse-field-decls rest))) (`((comment . ,_) . ,rest) (igccg--parse-field-decls rest)) (`((preproc_ifdef (\#ifdef . ,_) (name: ,_) . ,ifdef) . ,rest) (igccg--parse-field-decls (append (igccg--unwrap-\#if ifdef) rest))) (`((preproc_if (\#if . ,_) (condition: . ,_) . ,if) . ,rest) (igccg--parse-field-decls (append (igccg--unwrap-\#if if) rest))) (`((preproc_def . ,_) . ,rest) (igccg--parse-field-decls rest)) (`((\ . ,_) . ,rest) (igccg--parse-field-decls rest)) ('((} . "}")) '()))) (defun igccg--parse-field-decl-list (body) (pcase-exhaustive body (`(field_declaration_list ({ . "{") . ,fdecls) (igccg--parse-field-decls fdecls)))) (defun igccg--parse-type-declarator (decl type) (pcase-exhaustive decl (`(type_identifier . ,_) type) (`(pointer_declarator (* . "*") (declarator: ,decl)) (igccg--parse-type-declarator decl `(* ,type))))) (defun igccg--parse-typedef (typedef) (pcase-exhaustive typedef (`((type: ,type) (declarator: ,decl) (\; . ";")) (igccg--parse-type-declarator decl (igccg--parse-type type))))) (defun igccg--parse-struct (name-and-body) (pcase-exhaustive name-and-body (`((name: (type_identifier . ,name)) (body: ,body)) `(struct ,name ,(igccg--parse-field-decl-list body))) (`((body: ,body)) `(struct name ,(igccg--parse-field-decl-list body))) (`((name: (type_identifier . ,name))) `(struct-ref ,name)))) (defconst igccg--typedef-whitelist '("INTERVAL")) (defun igccg--resolve-type-ref (name) (cond ((member name igccg--typedef-whitelist) (igccg--parse-type (igccg--to-sexp (igccg--lookup-type-definition name)))) (t `(type-ref ,name)))) ;; Convert the sexp TYPE-SPECIFIER to a type. ;; Where type =3D (struct name fields) ;; | (union name fields) ;; | (type-ref name) ;; | (struct-ref name) ;; | (union-ref name) ;; | (enum-ref name) ;; | (primitive name) ;; | (* type) ;; | (array type size) ;; | (bitfield type size) ;; and fields =3D ((field name type) ...) (defun igccg--parse-type (type-specifier) (pcase-exhaustive type-specifier (`(struct_specifier (struct . "struct") . ,rest) (igccg--parse-struct rest)) (`(union_specifier (union . "union") (body: (field_declaration_list ({ . "{") . ,fdecls))) `(union nil ,(igccg--parse-field-decls fdecls))) (`(type_identifier . ,name) (igccg--resolve-type-ref name)) (`(type_definition (typedef . "typedef") . ,rest) (igccg--parse-typedef rest)) (`(enum_specifier (enum . "enum") (name: (type_identifier . ,name))) `(enum-ref ,name)) (`(primitive_type . ,name) `(primitive ,name)) (`(sized_type_specifier . ,name) `(primitive ,name)))) (defun igccg--parse-struct-type (name) (let* ((node (igccg--lookup-struct-specifier name)) (sexp (igccg--to-sexp node))) (igccg--parse-type sexp))) ;; (igccg--parse-struct-type (elt igccg--mps-structs 5)) ;; (mapcar #'igccg--parse-struct-type igccg--mps-structs) ;; Return the fields for TYPE. The result is non-empty only for structs ;; and unions. (defun igccg--type-fields (type) (pcase-exhaustive type (`(struct ,_ ,fields) fields) (`(union ,_ ,fields) fields) (`(type-ref ,_) '()) (`(struct-ref ,_) '()) (`(* ,_) '()) (`(array . ,_) '()) (`(primitive ,_) '()) (`(bitfield . ,_) '()))) (defun igccg--type-field-paths (type) (let* ((l1 (mapcar (lambda (field) (pcase-exhaustive field (`(field ,name ,type) `(field-path ,(list name) ,type)))) (igccg--type-fields type))) (l2 (seq-mapcat (lambda (fpath1) (pcase-exhaustive fpath1 (`(field-path ,path1 ,type1) (mapcar (lambda (fpath2) (pcase-exhaustive fpath2 (`(field-path ,path2 ,type2) `(field-path ,(append path1 path= 2) ,type2)))) (igccg--type-field-paths type1))))) l1))) (append l1 l2))) (when nil (igccg--type-field-paths (igccg--parse-struct-type (elt igccg--mps-structs 5)))) (defun igccg--mps-ref-type-p (type) (pcase-exhaustive type (`(type-ref "Lisp_Object") t) (`(type-ref ,_) nil) (`(* (struct-ref ,name)) (member name igccg--mps-structs)) (`(* ,_) nil) (`(array . ,_) nil) (`(struct . ,_) nil) (`(struct-ref . ,_) nil) (`(union . ,_) nil) (`(primitive . ,_) nil) (`(bitfield . ,_) nil))) ;; Return those fields in the structure TYPE that contain references to ;; GC managed objects. (defun igccg--type-ref-fields (type) (seq-filter (lambda (fpath) (pcase-exhaustive fpath (`(field-path ,_ ,type) (igccg--mps-ref-type-p type)))) (igccg--type-field-paths type))) (when nil (igccg--type-ref-fields (igccg--parse-struct-type (elt igccg--mps-structs 5)))) (defun igccg--emit-mirror (name type) (princ (format "static void mirror_%s (struct igc_mirror *m, struct %s *x) { " name name)) (pcase-dolist (`(field-path ,path ,type) (igccg--type-ref-fields type)) (princ (pcase-exhaustive type ('(type-ref "Lisp_Object") (format " mirror_lisp_obj (m, &x->%s);\n" (string-join path "."))) (_ (format " mirror_ptr (m, &x->%s);\n" (string-join path ".")))))) (princ "}\n")) (defun igccg-main () (dolist (name igccg--mps-structs) (let* ((type (igccg--parse-struct-type name))) (igccg--emit-mirror name type)))) ;; (igccg-main) --=-=-=--