contrib/mdcompact/mdcompact.el

   1 ;;; -*- lexical-binding: t; -*-
   2
   3 ;; Author: Andrea Corallo <andrea.corallo@arm.com>
   4 ;; Package: mdcompact
   5 ;; Keywords: languages, extensions
   6 ;; Package-Requires: ((emacs "29"))
   7
   8 ;; This file is part of GCC.
   9
  10 ;; GCC is free software: you can redistribute it and/or modify it
  11 ;; under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GCC is distributed in the hope that it will be useful, but WITHOUT
  16 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  17 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  18 ;; License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GCC.  If not, see <https://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; Convert multi choice GCC machine description patterns to compact
  26 ;; syntax.
  27
  28 ;;; Usage:
  29
  30 ;; With the point on a pattern run 'M-x mdcomp-run-at-point' to
  31 ;; convert that pattern.
  32
  33 ;; Run 'M-x mdcomp-run-buffer' to convert all convertible patterns in
  34 ;; the current buffer.
  35
  36 ;; Run 'M-x mdcomp-run-directory' to convert all convertible patterns
  37 ;; in a directory.
  38
  39 ;; One can invoke the tool from shell as well, ex for running it on
  40 ;; the arm backend from the GCC checkout directory:
  41 ;; emacs -batch -l ./contrib/mdcompact/mdcompact.el -f mdcomp-run-directory ./gcc/config/arm/
  42
  43 ;;; Code:
  44
  45 (require 'cl-lib)
  46 (require 'rx)
  47
  48 (defconst
  49   mdcomp-constr-rx
  50   (rx "(match_operand" (? ":" (1+ (or punct alnum)))
  51       (1+ space) (group-n 1 num) (1+ space) "\""
  52       (1+ (or alnum "_" "<" ">")) "\""
  53       (group-n 2 (1+ space) "\"" (group-n 3 (0+ (not "\""))) "\"")
  54       ")"))
  55
  56 (cl-defstruct mdcomp-operand
  57   num
  58   cstr)
  59
  60 (cl-defstruct mdcomp-attr
  61   name
  62   vals)
  63
  64 ;; A reasonable name
  65 (rx-define mdcomp-name (1+ (or alnum "_")))
  66
  67 (defconst mdcomp-attr-rx
  68   (rx "(set_attr" (1+ space) "\""
  69       (group-n 1 mdcomp-name)
  70       "\"" (1+ space) "\""
  71       (group-n 2 (1+ (not ")")))
  72       "\"" (0+ space) ")"))
  73
  74 (defun mdcomp-parse-delete-attr ()
  75   (save-match-data
  76     (when (re-search-forward mdcomp-attr-rx nil t)
  77       (let ((res (save-match-data
  78                    (make-mdcomp-attr
  79                     :name (match-string-no-properties 1)
  80                     :vals (cl-delete-if #'string-empty-p
  81                                         (split-string
  82                                          (replace-regexp-in-string
  83                                           (rx "\\") ""
  84                                           (match-string-no-properties 2))
  85                                                       (rx (1+ (or space ",")))))))))
  86         (if (length= (mdcomp-attr-vals res) 1)
  87             'short
  88           (delete-region (match-beginning 0) (match-end 0))
  89           res)))))
  90
  91 (defun mdcomp-parse-attrs ()
  92   (save-excursion
  93     (let* ((res (cl-loop for x = (mdcomp-parse-delete-attr)
  94                          while x
  95                          collect x))
  96            (beg (re-search-backward (rx bol (1+ space) "["))))
  97       (unless (memq 'short res)
  98         (when res
  99           (delete-region beg (re-search-forward (rx "]")))))
 100       (cl-delete 'short res))))
 101
 102 (defun mdcomp-remove-quoting (beg)
 103   (save-excursion
 104     (save-match-data
 105       (replace-regexp-in-region (regexp-quote "\\\\") "\\\\" beg (point-max))
 106       (replace-regexp-in-region (regexp-quote "\\\"") "\"" beg (point-max)))))
 107
 108 (defun mdcomp-remove-escaped-newlines (beg)
 109   (save-excursion
 110     (save-match-data
 111       (replace-regexp-in-region (rx "\\" eol (0+ space)) " " beg (point-max)))))
 112
 113 (defun mdcomp-parse-delete-cstr ()
 114   (cl-loop while (re-search-forward mdcomp-constr-rx nil t)
 115            unless (string= "" (match-string-no-properties 3))
 116              collect (save-match-data
 117                        (make-mdcomp-operand
 118                         :num (string-to-number (match-string-no-properties 1))
 119                         :cstr (cl-delete-if #'string-empty-p
 120                                             (split-string
 121                                              (replace-regexp-in-string " " ""
 122                                                                        (match-string-no-properties 3))
 123                                              (rx (1+ ","))))))
 124            do (delete-region (match-beginning 2) (match-end 2))))
 125
 126 (defun mdcomp-run* ()
 127   (let* ((ops (mdcomp-parse-delete-cstr))
 128              (attrs (mdcomp-parse-attrs))
 129              (beg (re-search-forward "\"@")))
 130         (cl-sort ops (lambda (x y)
 131                        (< (mdcomp-operand-num x) (mdcomp-operand-num y))))
 132         (mdcomp-remove-escaped-newlines beg)
 133         (save-match-data
 134           (save-excursion
 135             (left-char 2)
 136             (forward-sexp)
 137             (left-char 1)
 138             (delete-char 1)
 139             (insert "\n  }")))
 140         (mdcomp-remove-quoting beg)
 141         (replace-match "{@")
 142         (re-search-forward (rx (or "\"" ")")))
 143         (re-search-backward "@")
 144         (right-char 1)
 145         (insert "[ cons: ")
 146         (cl-loop
 147          for op in ops
 148          when (string-match "=" (cl-first (mdcomp-operand-cstr op)))
 149          do (insert "=")
 150          do (insert (number-to-string (mdcomp-operand-num op)) ", ")
 151          finally
 152          (progn
 153            ;; In case add attributes names
 154            (when attrs
 155              (delete-char -2)
 156              (insert "; attrs: ")
 157              (cl-loop for attr in attrs
 158                       do (insert (mdcomp-attr-name attr) ", ")))
 159            (delete-char -2)
 160            (insert "]")))
 161         (cl-loop
 162          while (re-search-forward (rx bol (0+ space) (or (group-n 1 "* return")
 163                                                          (group-n 2 "}")
 164                                                          "#" alpha "<"))
 165                                   nil t)
 166          for i from 0
 167          when (match-string 2)
 168            do (cl-return)
 169          when (match-string 1)
 170            do (progn
 171                 (delete-region (match-beginning 1) (+ (match-beginning 1) (length "* return")))
 172                 (insert "<<")
 173                 (left-char 1))
 174          do
 175          (progn
 176            (left-char 1)
 177            (cl-loop
 178             initially (insert " [ ")
 179             for op in ops
 180             for c = (nth i (mdcomp-operand-cstr op))
 181             unless c
 182               do (cl-return)
 183             do (insert (if (string-match "=" c)
 184                            (substring c 1 nil)
 185                          c)
 186                        ", ")
 187             finally (progn
 188                       (when attrs
 189                         (delete-char -2)
 190                         (insert "; ")
 191                         (cl-loop for attr in attrs
 192                                  for str = (nth i (mdcomp-attr-vals attr))
 193                                  when str
 194                                    do (insert str)
 195                                  do (insert ", ")))
 196                       (delete-char -2)
 197                       (insert " ] ")
 198                       (move-end-of-line 1)))))
 199         ;; remove everything after ] align what needs to be aligned
 200         ;; and re-add the asm template
 201         (re-search-backward (regexp-quote "@[ cons:"))
 202         (let* ((n (length (mdcomp-operand-cstr (car ops))))
 203                (asms (cl-loop
 204                       initially (re-search-forward "]")
 205                       repeat n
 206                       collect (let* ((beg (re-search-forward "]"))
 207                                      (end (re-search-forward (rx eol)))
 208                                      (str (buffer-substring-no-properties beg end)))
 209                                 (delete-region beg end)
 210                                 str)))
 211                (beg (re-search-backward (regexp-quote "@[ cons:")))
 212                (indent-tabs-mode nil))
 213           (re-search-forward "}")
 214           (align-regexp beg (point) (rx  (group-n 1 "") "["))
 215           (align-regexp beg (point) (rx  (group-n 1 "") (or "," ";")) nil nil t)
 216           (align-regexp beg (point) (rx  (group-n 1 "") "]"))
 217           (goto-char beg)
 218           (cl-loop
 219            initially (re-search-forward "]")
 220            for i below n
 221            do (progn
 222                 (re-search-forward "]")
 223                 (insert (nth i asms))))
 224           (when (re-search-forward (rx (1+ (or space eol)) ")") nil t)
 225             (replace-match "\n)" nil t)))))
 226
 227 (defun mdcomp-narrow-to-md-pattern ()
 228   (condition-case nil
 229       (let ((beg (re-search-forward "\n("))
 230             (end (re-search-forward (rx bol (1+ ")")))))
 231         (narrow-to-region beg end))
 232     (error
 233      (narrow-to-defun))))
 234
 235 (defun mdcomp-run-at-point ()
 236   "Convert the multi choice top-level form around point to compact syntax."
 237   (interactive)
 238   (save-restriction
 239     (save-mark-and-excursion
 240       (mdcomp-narrow-to-md-pattern)
 241       (goto-char (point-min))
 242       (let ((pattern-name (save-excursion
 243                             (re-search-forward (rx "\"" (group-n 1 (1+ (not "\""))) "\""))
 244                             (match-string-no-properties 1)))
 245             (orig-text (buffer-substring-no-properties (point-min) (point-max))))
 246         (condition-case nil
 247             (progn
 248               (mdcomp-run*)
 249               (message "Converted: %s" pattern-name))
 250           (error
 251            (message "Skipping convertion for: %s" pattern-name)
 252            (delete-region (point-min) (point-max))
 253            (insert orig-text)
 254            'fail))))))
 255
 256 (defun mdcomp-run-buffer ()
 257   "Convert the multi choice top-level forms in the buffer to compact syntax."
 258   (interactive)
 259   (save-excursion
 260     (message "Conversion for buffer %s started" (buffer-file-name))
 261     (goto-char (point-min))
 262     (while (re-search-forward
 263             (rx "match_operand" (1+ any) letter (0+ space) "," (0+ space) letter) nil t)
 264       (when (eq (mdcomp-run-at-point) 'fail)
 265         (condition-case nil
 266             (forward-sexp)
 267           (error
 268            ;; If forward-sexp fails falls back.
 269            (re-search-forward (rx ")" eol eol))))))
 270     (message "Conversion done")))
 271
 272 (defconst mdcomp-file-rx (rx bol alpha (0+ not-newline) ".md" eol))
 273
 274 (defun mdcomp-run-directory (folder &optional recursive)
 275   "Run el mdcompact on a FOLDER possibly in a RECURSIVE fashion."
 276   (interactive "D")
 277   (let ((before-save-hook nil)
 278         (init-time (current-time)))
 279     (mapc (lambda (f)
 280             (with-temp-file f
 281               (message "Working on %s" f)
 282               (insert-file-contents f)
 283               (mdcomp-run-buffer)
 284               (message "Done with %s" f)))
 285           (if recursive
 286               (directory-files-recursively folder mdcomp-file-rx)
 287             (directory-files folder t mdcomp-file-rx)))
 288     (message "Converted in %f sec" (float-time (time-since init-time)))))
 289
 290 (defun mdcomp-batch-run-directory ()
 291   "Same as `mdcomp-run-directory' but use cmd line args."
 292   (mdcomp-run-directory (nth 0 argv) (nth 1 argv)))
 293
 294 (provide 'mdcompact)
 295
 296 ;;; mdcompact.el ends here