Category Archives: 未分類

2022-11-19

新しいPCのセットアップ

新しい おもちゃ サブ機が届いたのでセットアップした。

  • winget install -e --id Google.Chrome
  • winget install -e --id Dropbox.Dropbox
  • regedit SwapCtrlCaps_EscZenkaku.reg
    ……で済むと思いきや、キー配列的にESCと全角半角は入れ替える必要が無かった。

    Windows Registry Editor Version 5.00
    
    [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Keyboard Layout]
    "Scancode Map"=hex:00,00,00,00,00,00,00,00,05,00,00,00,29,00,01,00,3a,00,1d,00,\
      01,00,29,00,1d,00,3a,00,00,00,00,00
    

    05→03にして29,00,01,00と01,00,29,00を削除。

  • 手動インストール:kanalock
  • 手動インストール:XKeymacs
  • winget install -e --id Microsoft.VCRedist.2015+.x86
    winget install -e --id Microsoft.VCRedist.2015+.x64
    (Xkeymacsに必要だったので)
  • 手動インストール:ATOK
  • 手動インストール:Git for Windows
    (wingetだと–location=が効かない。初期設定も出来ない)
  • winget install -e --id Microsoft.WindowsTerminal
  • Windows標準のOpenSSHをアンインストール。
  • winget install -e --id msys2.msys2 --location "c:\app\msys64"
    • ユーザ環境変数設定
      • HOME=場所を指定
      • MSYSTEM=UCRT64
      • MSYSTEM_CARCH=x86_64
      • LANG=ja_JP.CP932
      • PATH=色々追加
    • etc/fstabで/homeをHOMEの場所にマッピング。
    • pacman -Syuuで先にパッケージデータベースを最新にしておく。
    • pacman -S <package-name>
      • openssh
      • unzip
      • zip
      • rsync
      • base-devel
      • msys2-devel
      • msys2-runtime-devel
      • mingw-w64-ucrt-x86_64-toolchain
      • mingw-w64-ucrt-x86_64-gnupg
      • mingw-w64-ucrt-x86_64-emacs
      • mingw-w64-ucrt-x86_64-imagemagick
      • mingw-w64-ucrt-x86_64-librsvg
      • mingw-w64-ucrt-x86_64-graphviz
      • mingw-w64-ucrt-x86_64-clang
      • mingw-w64-ucrt-x86_64-clang-tools-extra (clangd)
      • mingw-w64-ucrt-x86_64-7zip
      • mingw-w64-ucrt-x86_64-wget2
      • mingw-w64-ucrt-x86_64-ripgrep
      • mingw-w64-ucrt-x86_64-emacs-pdf-tools-server
      • libiconv-devel
      • mingw-w64-ucrt-x86_64-boost
    • ssh-keygenして公開鍵をGitサーバ(GitHub等)に登録。
    • Emacsの設定をチェックアウト。
    • .bashrcとかの設定。
    • ビルド&インストール(usr/local/bin)
      • (UCRT64)nkf (CFLAGSに-DDEFAULT_CODE_UTF8=1を指定したバージョンも作る)
      • (MSYS2)git-encwrapper
      • (MSYS2)win-ssh-agent (環境変数をフルパスで設定するように修正)
  • winget install -e --id evernote.evernote
  • winget install -e --id IrfanSkiljan.IrfanView
  • winget install -e --id Adobe.Acrobat.Reader.64-bit
  • 後は必要に応じて。SSD容量がそれほど無いので。
  • reg add "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\DWM" /v "AccentColorInactive" /t REG_DWORD /d 0x00ffffff
    Chromeが非アクティブの時のタブバーの色を設定。エクスプローラのタブバーはアクティブ時にアクセントカラーにならないのかしら。

最初はやっぱりキーボードの設定。まずは全角半角-ESCとCtrl-Capsの入れ替え……ってEscが1の真上にある。全角半角はその右。これは入れ替えなくて良いかな。後はXKeymacsと自作のカナロックアプリ。未だに動いてくれるのはありがたいね。

今回はwingetを積極的に使ってみてるけどなんか微妙。普通のインストーラをダウンロードしてサイレントインストールしてくれるけど、たまに–location=が無視されるし、セットアップ中の細かい設定が出来ないしで結局自分で落としてインストールした方が早いのではと思うことがたまにある。でも基本的には良いものだと思う。特に既存のインストーラシステムを尊重しているところが。それ故うまく行かないところがあるのも仕方なし。Windows SDKのバージョン違いが複数入っているとずっとアップグレード対象になってしまうのは既知の問題みたい。

今回はCygwinは入れないでMSYS2だけで環境を構築してみることにした。同じような物を二つも入れておくことに近年疑問を持っていたので。環境はMinGW64ではなくUCRT64を選択。最近はUCRT64が推奨環境らしいので。今のところ特に問題なし。

Emacsはmingw-w64-ucrt-x86_64-emacsを使用。MSYSのEmacsパッケージを常用するのは初めて。これまではIMEパッチを当てて自分でビルドするか、配布のバイナリを使ってきたので。ネイティブコンパイルは普通にしてくれる。librsvgは自動で入らないのね。mingw-w64-ucrt-x86_64-gnupgを入れないとpackage-install-selected-packagesが出来ないので焦った。

初Windows11環境。相変わらずタスクバーやスタートメニューが変わっているけど問題なし。どうせCtrl+Esc(またはWin)で開いてアプリ名を数文字入れるのにしか使っていない。あ、ucrt64/bin/runemacs.exeへのショートカットを作ってemacsにリネームしてスタートメニューに入れておく作業を書いていなかった。他と被らない二文字をショートカットのファイル名にしてスタートメニューに入れておいたりも良くする。二文字打ってEnterすれば実行できるので。Win95の頃はスタートメニューに検索機能は無かったけど、フォルダ名やショートカットファイル名の先頭文字を工夫することで同じ事が出来た(その時はEnterは不要で本当に二文字で起動できたはず。例えばフォルダ名がMicrosoft→ショートカットファイル名がExcelなら Ctrl+Esc m e で Excelが起動できたり。今は Ctrl+Esc e x Enter くらい。Enterが余計)。

2022-11-13

Windows上のMagitでコミットメッセージを編集できるようになるまでが遅すぎるので調査してテキトーキャッシュで改善してみた

別に今に始まったことでは無いのですがMagitが遅すぎるんですよ。MS-Windowsで。stageした後、c cを押してからコミットメッセージが書けるようになるまでにいったい何秒待たされることか。待っている間に何を書こうとしたか忘れるくらい遅いんです。一回だけならまだ我慢しましょう。でも変更点を部分的にstageしてコミット、それを何度も繰り返すようなときはかなりウンザリします。

最近VCを試しました。Emacsに昔から標準で入っているバージョンコントロール機能です。私は昔からこれを避けてきました。ちゃんと動かないことが多かったので。CVSにせよSVNにせよ専用のクライアント(pcl-cvs.elやpsvn.el)が軽快に動作していましたし。Gitになってからも試しましたが文字化けしていたので直さないとなと思いつつ放置していました。最近再び試したところ意外なことにちゃんと動くではありませんか。それもMagitのように遅くありません。軽快に動きます。

もうこれで良いんじゃないかとも思いましたが、やはりMagitの機能は魅力的です。特に部分的なstageはもはや手放せません。

そうしてMagitに戻ってみると、コミット時の待ち時間があまりにも長いことが気になってきました。やることと言えば単にコミットメッセージを入力するバッファを開くというだけです。まだコミットすらしていない段階です。それだけで8秒かかります。

絶対におかしい。やっていることに比して時間がかかりすぎです。ということで調査してみました。

マニュアルに書かれている対策

パフォーマンスについてはマニュアルに少し記載があります。

Performance (Magit User Manual)

Windows向けのGitの設定。

git config --global core.preloadindex true   # default since v2.1
git config --global core.fscache true        # default since v2.8
git config --global gc.auto 256

コミット時にdiffを自動的に表示しない設定。

(remove-hook 'server-switch-hook 'magit-commit-diff)
(remove-hook 'with-editor-filter-visit-hook 'magit-commit-diff)

もちろんこれらを試してみましたが、まだまだ全然遅いです。

コミット時の流れを把握

Magitのバッファからc cを押すと実行されるのが magit-commit-create です。この関数(コマンド)は基本的に git commit を非同期で実行するだけです。

この部分の面白いところは with-editor という仕組み(マクロ)を使用している点です。 with-editor は、Emacsから外部コマンド(今回の場合は git commit)を呼び出してそのコマンドがエディタを起動するときに自身がそのエディタになる(コマンドを呼び出したEmacsのプロセスでファイルを開くようにする)ための仕掛けです。具体的には次のような流れになります。

  1. Emacsサーバを起動します。
  2. 環境変数GIT_EDITORにemacsclientを指定します。1で起動したサーバの情報も付け加えて確実にemacsclientがそのサーバと接続出来るようにします。
  3. 非同期でgit commitを起動します。git-commit-createはすぐに終了します。
  4. gitはコミットメッセージを求めてエディタを起動します。起動するのはGIT_EDITORに書かれているemacsclientです。エディタへの引数としてコミットメッセージを書くためのファイル(.git/COMMIT_EDITMSG)を指定します。
  5. emacsclientはEmacsサーバに接続してCOMMIT_EDITMSGを開くよう要求します。
  6. gitを起動したEmacs側では、Emacsサーバがその要求を認識してCOMMIT_EDITMSGを開きます。

こんなまどろっこしいことをしなくてもgit起動時に直接コミットメッセージを渡せば良いと思うかもしれませんが、gitはCOMMIT_EDITMSGに色々な情報をコメントで付け加えてからエディタを起動するので、その情報が欲しいと言うことなのでしょう。

実はここまでであればそれほど遅くはありません。試しにまだmagitが読み込まれていない状態で M-: (progn (require 'with-editor) (with-editor "GIT_EDITOR" (start-process "git-proc-name" "git-output-buffer" "git" "commit"))) などと実行すると割とすぐ(1秒くらい?)にCOMMIT_EDITMSGファイルが開きます。問題はどうもその後にあるようです。

magitが読み込まれていると、サーバがCOMMIT_EDITMSGを開く段階で次の関数(主にgit-commit.el内)が実行されます。

  • git-commit-setup (global-git-commit-modeによってfind-file-hookにadd-hookされる関数)
  • git-commit-setup-font-lock (git-commit.elロード時にafter-change-major-mode-hookにadd-hookされる関数)
  • magit-auto-revert-mode-enable-in-buffers (magit-auto-revert-modeによってafter-change-major-mode-hookにadd-hookされる関数)

どれもファイルを開いた事によるフックによって自動的に呼び出されます。

なのでこれらの関数をフックから外してしまえばその処理は行われません。

(with-eval-after-load "git-commit"
  (global-git-commit-mode -1)
  (remove-hook 'after-change-major-mode-hook #'git-commit-setup-font-lock-in-buffer))
(with-eval-after-load "magit"
  (magit-auto-revert-mode -1))

結果、c cでコミットメッセージを書くバッファが開くまでの時間が大幅に短縮されました。めでたしめでたし。

と終わっても良いのですが、これだと色々な機能が利用できなくなってしまいます。

これらの関数が中で何をするのかもう少し調べてみます。

コミット時の流れを計測

トレースと計測のためにmy-profiler.elを作りました。

まずは全体的な流れを把握。

;; 調査用コード
(require 'my-profiler)
(my-profiler-instrument-all
 '((magit-commit-create . start) ;;ここで計測開始
   (server-execute . stop) ;;ここで計測終了
   magit-commit-diff
   git-commit-setup
   (git-commit-setup-font-lock-in-buffer . short)
   (magit-auto-revert-mode-enable-in-buffers . short)
   normal-mode))
(progn
  (switch-to-buffer "magit: my-test-git-repository") ;;既に開いてstageしてあるMagitのバッファを表に出す。
  (magit-commit-create)) ;;そのバッファ上でmagit-commit-createを実行する。
TM startからの経過時間 前計測点からの経過時間 関数内の滞在時間
TM	     0.014	+     0.014	          	Enter #<subr magit-commit-create>
TM	   806.706	+   806.692	   806.641	Leave #<subr magit-commit-create>
TM	   988.713	+   182.007	          	Enter #<subr server-execute>
TM	   996.355	+     7.642	          	Enter  #<subr normal-mode>
TM	  1209.287	+   212.932	   212.859	Eval    #<subr git-commit-setup-font-lock-in-buffer>
TM	  1675.698	+   466.411	   466.354	Eval    #<subr magit-auto-revert-mode-enable-in-buffers>
TM	  1896.232	+   220.534	   217.599	Eval    #<subr git-commit-setup-font-lock-in-buffer>
TM	  2364.570	+   468.338	   468.274	Eval    #<subr magit-auto-revert-mode-enable-in-buffers>
TM	  2365.017	+     0.447	  1368.649	Leave  #<subr normal-mode>
TM	  2365.066	+     0.049	          	Enter  #<subr git-commit-setup>
TM	  2365.100	+     0.034	          	Enter   #<subr normal-mode>
TM	  2587.760	+   222.660	   222.564	Eval     #<subr git-commit-setup-font-lock-in-buffer>
TM	  3060.027	+   472.267	   472.190	Eval     #<subr magit-auto-revert-mode-enable-in-buffers>
TM	  3325.810	+   265.783	   262.448	Eval     #<subr git-commit-setup-font-lock-in-buffer>
TM	  3782.673	+   456.863	   456.770	Eval     #<subr magit-auto-revert-mode-enable-in-buffers>
TM	  3783.060	+     0.387	  1417.947	Leave   #<subr normal-mode>
TM	  4899.085	+  1116.025	  2533.975	Leave  #<subr git-commit-setup>
TM	  4899.128	+     0.043	     0.001	Eval   #<subr magit-auto-revert-mode-enable-in-buffers>
TM	  5122.180	+   223.052	          	Enter  #<subr magit-commit-diff>
TM	  7588.585	+  2466.405	     0.001	Eval    #<subr git-commit-setup-font-lock-in-buffer>
TM	  7588.614	+     0.029	     0.003	Eval    #<subr magit-auto-revert-mode-enable-in-buffers>
TM	  7821.368	+   232.754	  2699.136	Leave  #<subr magit-commit-diff>
TM	  7822.309	+     0.941	  6833.551	Leave #<subr server-execute>
  1. まずmagit-commit-createが終わるまでに800msかかります。
  2. serverがemacsclientからの要求を受けてserver-executeを実行するのが約1s経過時点。以下server-executeの中で6.8sかかります。
  3. ファイルを開いてメジャーモードが切り替わるので、normal-mode関数によってafter-change-major-mode-hookが実行されます。フックに設定されているgit-commit-setup-font-lock-in-bufferとmagit-auto-revert-mode-enable-in-buffersが呼ばれます。一回のnormal-modeで二回も。
  4. git-commit-setupに入る時点で既に2.3s経過。
  5. git-commit-major-modeの設定に従ってメジャーモードを変更するのでまたafter-change-major-mode-hookが実行されます。
  6. そしてgit-commit-diffでdiffを出力し、終わるのが開始から7.8s後。

どの関数でも数百msもの時間がかかっています。

また、計上されていない時間もあり状況がよく分かりません。なのでそれらの関数の中身を読んで詳しく調べました。

すると多数のgitコマンドの実行が見つかりました。例えばgit-commit-setup-font-lock関数内には次のようなコードがあります。

    (setq-local comment-start
                (or (with-temp-buffer
                      (and (zerop
                            (call-process
                             (git-commit-executable) nil (list t nil) nil
                             "config" "core.commentchar")) ;;←ここ★
                           (not (bobp))
                           (progn
                             (goto-char (point-min))
                             (buffer-substring (point) (line-end-position)))))
                    "#"))

このコードは git config core.commentchar を実行してコメントに使う文字をgitから取得しています。

また、git-commit-setup関数内には次のようなコードがあります。

  (let ((default-directory
         (or (and (not (file-exists-p ".dir-locals.el"))
                  ;; When $GIT_DIR/.dir-locals.el doesn't exist,
                  ;; fallback to $GIT_WORK_TREE/.dir-locals.el,
                  ;; because the maintainer can use the latter
                  ;; to enforce conventions, while s/he has no
                  ;; control over the former.
                  (fboundp 'magit-toplevel)  ; silence byte-compiler
                  (magit-toplevel)) ;;←ここ★
             default-directory)))

ここでは(magit-toplevel)という関数が使われています。この関数はリポジトリの最上位のディレクトリを返しますが、内部で git rev-parse --show-toplevel というコマンドを実行しています。

このようにあちこちから気軽にgitコマンドが実行されているので全てを把握するのが困難です。

そこで次のような計測を行ってcall-processの呼び出し状況を調べてみました。

;; 調査用コード
(require 'my-profiler)
(my-profiler-instrument-all
 '((magit-commit-create . start)
   (server-execute . stop)
   magit-commit-diff
   git-commit-setup
   git-commit-setup-font-lock-in-buffer
   magit-auto-revert-mode-enable-in-buffers
   normal-mode
   (call-process . short))) ;;←これを追加
(progn
  (switch-to-buffer "magit: my-test-git-repository") ;;既に開いてstageしてあるMagitのバッファを表に出す。
  (magit-commit-create)) ;;そのバッファ上でmagit-commit-createを実行する。
TM	     0.067	+     0.067	          	Enter magit-commit-create
TM	   165.595	+   165.528	   128.970	Eval   call-process
TM	   276.355	+   110.760	   110.152	Eval   call-process
TM	   383.838	+   107.483	   106.953	Eval   call-process
TM	   492.492	+   108.654	   108.011	Eval   call-process
TM	   597.941	+   105.449	   103.835	Eval   call-process
TM	   702.018	+   104.077	   103.379	Eval   call-process
TM	   806.025	+   104.007	   103.550	Eval   call-process
TM	   818.413	+    12.388	   818.277	Leave magit-commit-create
TM	   998.803	+   180.390	          	Enter server-execute
TM	  1006.222	+     7.419	          	Enter  normal-mode
TM	  1006.265	+     0.043	          	Enter   git-commit-setup-font-lock-in-buffer
TM	  1116.712	+   110.447	   110.347	Eval     call-process
TM	  1225.767	+   109.055	   108.696	Eval     call-process
TM	  1226.047	+     0.280	   219.770	Leave   git-commit-setup-font-lock-in-buffer
TM	  1226.065	+     0.018	          	Enter   magit-auto-revert-mode-enable-in-buffers
TM	  1350.425	+   124.360	   114.586	Eval     call-process
TM	  1457.264	+   106.839	   106.571	Eval     call-process
TM	  1569.336	+   112.072	   111.709	Eval     call-process
TM	  1683.220	+   113.884	   113.402	Eval     call-process
TM	  1683.250	+     0.030	   457.178	Leave   magit-auto-revert-mode-enable-in-buffers
TM	  1686.554	+     3.304	          	Enter   git-commit-setup-font-lock-in-buffer
TM	  1794.665	+   108.111	   107.975	Eval     call-process
TM	  1910.274	+   115.609	   115.262	Eval     call-process
TM	  1910.601	+     0.327	   224.034	Leave   git-commit-setup-font-lock-in-buffer
TM	  1910.632	+     0.031	          	Enter   magit-auto-revert-mode-enable-in-buffers
TM	  2039.771	+   129.139	   119.084	Eval     call-process
TM	  2154.799	+   115.028	   114.813	Eval     call-process
TM	  2263.058	+   108.259	   107.883	Eval     call-process
TM	  2374.596	+   111.538	   111.138	Eval     call-process
TM	  2374.652	+     0.056	   464.004	Leave   magit-auto-revert-mode-enable-in-buffers
TM	  2375.022	+     0.370	  1368.786	Leave  normal-mode
TM	  2375.053	+     0.031	          	Enter  git-commit-setup
TM	  2375.080	+     0.027	          	Enter   normal-mode
TM	  2375.131	+     0.051	          	Enter    git-commit-setup-font-lock-in-buffer
TM	  2481.555	+   106.424	   106.317	Eval      call-process
TM	  2590.186	+   108.631	   108.101	Eval      call-process
TM	  2590.481	+     0.295	   215.338	Leave    git-commit-setup-font-lock-in-buffer
TM	  2590.498	+     0.017	          	Enter    magit-auto-revert-mode-enable-in-buffers
TM	  2714.161	+   123.663	   113.784	Eval      call-process
TM	  2825.484	+   111.323	   111.140	Eval      call-process
TM	  2931.823	+   106.339	   105.959	Eval      call-process
TM	  3046.016	+   114.193	   113.908	Eval      call-process
TM	  3046.080	+     0.064	   455.567	Leave    magit-auto-revert-mode-enable-in-buffers
TM	  3048.839	+     2.759	          	Enter    git-commit-setup-font-lock-in-buffer
TM	  3159.395	+   110.556	   110.437	Eval      call-process
TM	  3269.152	+   109.757	   109.407	Eval      call-process
TM	  3269.528	+     0.376	   220.675	Leave    git-commit-setup-font-lock-in-buffer
TM	  3269.548	+     0.020	          	Enter    magit-auto-revert-mode-enable-in-buffers
TM	  3398.770	+   129.222	   119.693	Eval      call-process
TM	  3504.807	+   106.037	   105.769	Eval      call-process
TM	  3615.480	+   110.673	   110.212	Eval      call-process
TM	  3727.668	+   112.188	   111.808	Eval      call-process
TM	  3727.712	+     0.044	   458.142	Leave    magit-auto-revert-mode-enable-in-buffers
TM	  3728.222	+     0.510	  1353.118	Leave   normal-mode
TM	  3843.396	+   115.174	   114.663	Eval    call-process
TM	  3954.347	+   110.951	   110.736	Eval    call-process
TM	  4063.458	+   109.111	   108.434	Eval    call-process
TM	  4173.732	+   110.274	   109.117	Eval    call-process
TM	  4277.008	+   103.276	   101.671	Eval    call-process
TM	  4386.951	+   109.943	   109.613	Eval    call-process
TM	  4496.227	+   109.276	   102.939	Eval    call-process
TM	  4607.267	+   111.040	   110.903	Eval    call-process
TM	  4735.445	+   128.178	   123.408	Eval    call-process
TM	  4846.907	+   111.462	   110.492	Eval    call-process
TM	  4847.823	+     0.916	  2472.720	Leave  git-commit-setup
TM	  4847.862	+     0.039	          	Enter  magit-auto-revert-mode-enable-in-buffers
TM	  4847.882	+     0.020	     0.012	Leave  magit-auto-revert-mode-enable-in-buffers
TM	  4957.249	+   109.367	   105.964	Eval   call-process
TM	  5071.761	+   114.512	   114.348	Eval   call-process
TM	  5075.277	+     3.516	          	Enter  magit-commit-diff
TM	  5190.165	+   114.888	   114.456	Eval    call-process
TM	  5299.389	+   109.224	   108.968	Eval    call-process
TM	  5406.564	+   107.175	   106.868	Eval    call-process
TM	  5523.598	+   117.034	   116.481	Eval    call-process
TM	  5628.045	+   104.447	   104.183	Eval    call-process
TM	  5733.773	+   105.728	   105.326	Eval    call-process
TM	  5854.707	+   120.934	   118.859	Eval    call-process
TM	  5961.210	+   106.503	   106.278	Eval    call-process
TM	  6074.760	+   113.550	   112.966	Eval    call-process
TM	  6204.416	+   129.656	   129.186	Eval    call-process
TM	  6320.894	+   116.478	   116.091	Eval    call-process
TM	  6426.537	+   105.643	   105.306	Eval    call-process
TM	  6531.705	+   105.168	   104.829	Eval    call-process
TM	  6653.648	+   121.943	   121.594	Eval    call-process
TM	  6766.164	+   112.516	   112.064	Eval    call-process
TM	  6883.633	+   117.469	   116.855	Eval    call-process
TM	  6996.202	+   112.569	   112.346	Eval    call-process
TM	  7105.460	+   109.258	   108.693	Eval    call-process
TM	  7223.988	+   118.528	   117.887	Eval    call-process
TM	  7330.973	+   106.985	   106.761	Eval    call-process
TM	  7475.212	+   144.239	   143.927	Eval    call-process
TM	  7595.205	+   119.993	   118.270	Eval    call-process
TM	  7595.306	+     0.101	          	Enter   git-commit-setup-font-lock-in-buffer
TM	  7595.332	+     0.026	     0.019	Leave   git-commit-setup-font-lock-in-buffer
TM	  7595.346	+     0.014	          	Enter   magit-auto-revert-mode-enable-in-buffers
TM	  7595.362	+     0.016	     0.010	Leave   magit-auto-revert-mode-enable-in-buffers
TM	  7701.903	+   106.541	   106.110	Eval    call-process
TM	  7825.783	+   123.880	   123.021	Eval    call-process
TM	  7827.148	+     1.365	  2751.850	Leave  magit-commit-diff
TM	  7828.413	+     1.265	  6829.588	Leave server-execute

非常に多くのcall-processが呼ばれていることが分かります。その数なんと67回(この数は現在開いているファイルなどEmacs全体の状態によって多少変わります)。

1回につきだいたい100msは持って行かれています。それが67回ですから、そりゃ遅いわけです。

call-processを全てチェックする

どのような引数でcall-processが呼ばれているのかを詳しく調査してみます。

call-processに細工をして、渡された引数と処理時間を出力できるようにしました。

;; 調査用コード
(defun my-watch-call-process (orig-func program infile destination display &rest args)
  (let* ((start-time (current-time))
         (result (apply orig-func program infile destination display args))
         (end-time (current-time))
         (str (format "%10.3f\tcall %s dir=%s args:%s infile=%s dest=%s display=%s"
                      (* 1000.0 (float-time (time-subtract end-time start-time)))
                      program
                      (expand-file-name default-directory)
                      args
                      infile
                      destination
                      display)))
    ;;(message "%s" str)
    (with-current-buffer (get-buffer-create "*Watch Call Process*")
      (insert str "\n"))
    result))
(advice-add #'call-process :around #'my-watch-call-process)
(progn
  (switch-to-buffer "magit: my-test-git-repository") ;;既に開いてstageしてあるMagitのバッファを表に出す。
  (magit-commit-create)) ;;そのバッファ上でmagit-commit-createを実行する。
;; (advice-remove #'call-process #'my-watch-call-process)

実行結果:

  127.805	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 diff --quiet --cached --) infile=nil dest=nil display=nil
  107.044	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  107.562	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  112.606	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
  110.020	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  109.413	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  107.641	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  104.655	call git-encwrapper dir=c:/my-test-git-repository/ args:(config core.commentchar) infile=nil dest=(t nil) display=nil
  108.715	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 for-each-ref --format=%(refname:short) refs/heads) infile=nil dest=(t nil) display=nil
  115.636	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  109.609	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
  111.605	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --is-bare-repository) infile=nil dest=(t nil) display=nil
  112.741	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 ls-files --error-unmatch c:/my-test-git-repository/.git/COMMIT_EDITMSG) infile=nil dest=nil display=nil
  111.269	call git-encwrapper dir=c:/my-test-git-repository/ args:(config core.commentchar) infile=nil dest=(t nil) display=nil
  114.393	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 for-each-ref --format=%(refname:short) refs/heads) infile=nil dest=(t nil) display=nil
  116.784	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  106.856	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
  111.306	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --is-bare-repository) infile=nil dest=(t nil) display=nil
  113.603	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 ls-files --error-unmatch c:/my-test-git-repository/.git/COMMIT_EDITMSG) infile=nil dest=nil display=nil
  110.811	call git-encwrapper dir=c:/my-test-git-repository/ args:(config core.commentchar) infile=nil dest=(t nil) display=nil
  108.250	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 for-each-ref --format=%(refname:short) refs/heads) infile=nil dest=(t nil) display=nil
  123.924	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  111.405	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
  114.570	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --is-bare-repository) infile=nil dest=(t nil) display=nil
  113.685	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 ls-files --error-unmatch c:/my-test-git-repository/.git/COMMIT_EDITMSG) infile=nil dest=nil display=nil
  103.513	call git-encwrapper dir=c:/my-test-git-repository/ args:(config core.commentchar) infile=nil dest=(t nil) display=nil
  109.157	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 for-each-ref --format=%(refname:short) refs/heads) infile=nil dest=(t nil) display=nil
  112.987	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  106.662	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
  104.755	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --is-bare-repository) infile=nil dest=(t nil) display=nil
  117.193	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 ls-files --error-unmatch c:/my-test-git-repository/.git/COMMIT_EDITMSG) infile=nil dest=nil display=nil
  119.297	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  107.351	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
  108.289	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --is-bare-repository) infile=nil dest=(t nil) display=nil
  114.332	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse HEAD) infile=nil dest=(t nil) display=nil
  103.471	call git-encwrapper dir=c:/my-test-git-repository/ args:(config core.commentchar) infile=nil dest=(t nil) display=nil
  111.284	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 for-each-ref --format=%(refname:short) refs/heads) infile=nil dest=(t nil) display=nil
  108.283	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager ls-files -c -z -- .git/COMMIT_EDITMSG) infile=nil dest=(t nil) display=nil
  109.082	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager ls-tree --name-only -z HEAD -- .git/COMMIT_EDITMSG) infile=nil dest=(t nil) display=nil
  113.619	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager remote get-url upstream) infile=nil dest=t display=nil
  107.181	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager remote get-url origin) infile=nil dest=t display=nil
  114.011	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager ls-files -c -z -- .git/COMMIT_EDITMSG) infile=nil dest=(t nil) display=nil
  108.958	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager ls-tree --name-only -z HEAD -- .git/COMMIT_EDITMSG) infile=nil dest=(t nil) display=nil
  118.451	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  112.981	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
  105.087	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --is-bare-repository) infile=nil dest=(t nil) display=nil
  121.276	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  104.412	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
  109.560	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --is-bare-repository) infile=nil dest=(t nil) display=nil
  116.268	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  111.705	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
  106.008	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --is-bare-repository) infile=nil dest=(t nil) display=nil
  122.337	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 diff --quiet --cached --) infile=nil dest=nil display=nil
  118.292	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  117.703	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
  107.558	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --is-bare-repository) infile=nil dest=(t nil) display=nil
  122.989	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 diff --quiet --) infile=nil dest=nil display=nil
  114.488	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
  110.997	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  113.395	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
  107.008	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --is-bare-repository) infile=nil dest=(t nil) display=nil
  115.545	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  124.748	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
  113.055	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --is-bare-repository) infile=nil dest=(t nil) display=nil
  116.179	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 config -z --get-all magit.extension) infile=nil dest=(t nil) display=nil
  117.604	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
  126.063	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 diff --ita-visible-in-index -p --no-prefix --numstat --cached --stat --no-ext-diff --) infile=nil dest=(t nil) display=nil

同じ引数のものをまとめてみます。

回数	平均時間	引数
1	 126.063	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 diff --ita-visible-in-index -p --no-prefix --numstat --cached --stat --no-ext-diff --) infile=nil dest=(t nil) display=nil
1	 116.179	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 config -z --get-all magit.extension) infile=nil dest=(t nil) display=nil
1	 122.989	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 diff --quiet --) infile=nil dest=nil display=nil
1	 107.181	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager remote get-url origin) infile=nil dest=t display=nil
1	 113.619	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager remote get-url upstream) infile=nil dest=t display=nil
2	 109.020	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager ls-tree --name-only -z HEAD -- .git/COMMIT_EDITMSG) infile=nil dest=(t nil) display=nil
2	 111.147	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager ls-files -c -z -- .git/COMMIT_EDITMSG) infile=nil dest=(t nil) display=nil
1	 114.332	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse HEAD) infile=nil dest=(t nil) display=nil
4	 114.305	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 ls-files --error-unmatch c:/my-test-git-repository/.git/COMMIT_EDITMSG) infile=nil dest=nil display=nil
11	 108.982	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --is-bare-repository) infile=nil dest=(t nil) display=nil
5	 110.360	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 for-each-ref --format=%(refname:short) refs/heads) infile=nil dest=(t nil) display=nil
5	 106.744	call git-encwrapper dir=c:/my-test-git-repository/ args:(config core.commentchar) infile=nil dest=(t nil) display=nil
13	 111.840	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
17	 114.632	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
2	 125.071	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 diff --quiet --cached --) infile=nil dest=nil display=nil
  • 合計で7535.042ms(call-processの中だけで)
  • 呼び出し回数は67回
  • 平均で一回あたり112.463ms
  • パターンは15種類
  • 実行時間はどれも大差なし
  • infileは全てnil(入力無し)
  • destinationはnil, t, (t nil)のいずれか(破棄、標準出力とエラー出力をミックス、エラーだけ破棄のいずれか)
  • displayは全てnil

とにかくプロセスの起動が多すぎます。それも同じ情報を10回以上問い合わせている箇所が3件もあります。

プロセスの起動速度

それにしてもプロセスの起動に100msというのはかなり遅いです。いったいどうなっているのでしょうか。

様々な方法でプロセスを起動してみてその実行時間を計測してみました。計測は次のコードで行い、100回繰り返したときの平均時間を求めました。

(benchmark-run 100 (call-process "git-encwrapper" nil (list t nil) nil "config" "core.commentchar"))

結果は平均106.37ms。私のEmacsはプロセスの起動まわりに色々細工をしてあるのでemacs -Qで起動したものでも試してみたところ平均104.78msでした。

git-encwrapperでは無く素のgitで試してみたところ、平均76.60ms(emacs -Qで76.22ms)。

私が使っているGitはGit for Windowsですが、Git/cmd(またはGit/bin)にあるgit.exeとGit/mingw64/binにあるgit.exeが別物です。前者は後者を呼び出すラッパーとなっています。通常PATHが通っているのは前者なので、後者を直接起動してみたところ、平均56.76msまで縮まりました(emacs -Qで55.19ms)。このラッパーには色々な役割があって、環境変数の調整なども行っているようなので直接呼び出して大丈夫なのかは分かりません。

  常用環境 emacs -Q環境
git-encwrapper.exe 106.37 104.78
Git/cmd/git.exe 76.60 76.22
Git/mingw64/bin/git.exe 56.76 55.19

以上はEmacsを経由して起動した場合の時間です。

Windowsはプロセスの起動が遅いとはよく言われていることです。しかし本当にWindowsだけの問題なのでしょうか。Emacs側には問題は無いのでしょうか。試しに次のようなバッチファイルを作成してcmd.exeから起動してみました。

echo %TIME%
>"test.log" (for /L %%a in (1,1,100) do "git.exe" config core.commentchar)
echo %TIME%

結果:

  • git-encwrapper 67.1ms
  • git.exe 31.4ms
  • mingw64/bin/git.exe 17.1ms
  常用環境 emacs -Q環境 cmd.exe
git-encwrapper.exe 106.37 104.78 67.1
Git/bin/git.exe 76.60 76.22 31.4
Git/mingw64/bin/git.exe 56.76 55.19 17.1

こうしてみるとプロセス起動が遅い原因を全てWindowsのせいにして良いのか疑問が湧いてきます。git-encwrapperが遅いのは、まぁ、私のせいです(笑)。とはいっても文字エンコーディングが複数混在しているプロジェクトで素のGitやMagitが使いづらいのは私のせいではありません。Emacsとcmd.exeの差(約40ms)を見るに、Emacs自体にも何か遅くなる原因がありそうです。Git for windowsのラッパーは意外に大きな差を生んでいます(約20ms)。GitにせよEmacsにせよUNIX系のOSで使われている物を無理矢理Windows上に持ってきているので色々と調整のためのコードが挟まっているのかもしれません。

ちなみにVirtualBoxに入っていたUbuntu 21とEmacs27.1で試したところ、2.1msくらいでした。10倍くらいの差があります。実際の所Windowsのプロセス起動がLinuxと比べて遅いのは確かです。

私の所限定の話になりますが、diffとapplyのとき以外はgit-encwrapperは必要ないので直接gitを呼び出して構いません。概ね次のようなコードで切り替えられそうです。

(defun my-call-process-for-bypassing-git-encwrapper (original-call-process program infile destination display &rest args)
  (when (and (equal program "git-encwrapper")
             ;; ↓オプション内にdiffやapplyという文字列が含まれていると誤判定するが、遅くなるだけで実害は無い。
             (not (and (member "diff" args) destination)) ;;diffでも出力を捨てる場合は素のgitで良い
             (not (member "apply" args)))
    (setq program "git"))
  (apply original-call-process program infile destination display args))
(advice-add #'call-process :around #'my-call-process-for-bypassing-git-encwrapper)
;;(advice-remove #'call-process #'my-call-process-for-bypassing-git-encwrapper)

Git/mingw64/bin/git.exeを直接呼ぶかどうかはGit/cmd/git.exeが何をしているかをよく調査してから判断すべきでしょう。ソースは MINGW-packages/git-wrapper.c at main · git-for-windows/MINGW-packages にあるようです。環境変数を事前に調整してやれば直接呼べるかもしれません。

call-processの結果をキャッシュする

プロセスの起動が遅いというのはとりあえず受け入れるとして、それならどうすれば良いでしょうか。

もちろん起動する回数を減らすよりありません。幸い同じ情報を何度も問い合わせている箇所があり、それらをまとめれば大幅な時間短縮が望めそうです。

一番手っ取り早いのはcall-process自体にキャッシュ機能を付けてしまうことでしょう。call-processの書式は次の通りです(Synchronous Processes (GNU Emacs Lisp Reference Manual)より)。

(call-process program &optional infile destination display &rest args)

programがgit(またはmagit-git-executableの値)のときに、default-directory(カレントディレクトリ)とargs、destinationをキーにして、結果となる終了ステータスとバッファに出力された文字列をキャッシュします。

もちろん結果は常に一定とは限りません。何か変更操作をした後は結果が変化するでしょう。どのタイミングでキャッシュをフラッシュ(クリア)するかが悩み所です。

とはいえ、コミットメッセージを入力する部分だけに限定するのであれば、その間に変更操作は無いのでクリアせずにずっと保持してしまって大丈夫でしょう。

というわけで作ったのが次のEmacs Lispです。

my-magit-speedup-for-windows/my-magit-process-cache.el at main · misohena/my-magit-speedup-for-windows

基本的な使い方:

  • my-magit-process-cache-turn-on でキャッシュを有効化(+キャッシュをクリア)
  • my-magit-process-cache-turn-off でキャッシュを無効化(+キャッシュをクリア)
  • my-magit-process-cache-clear-cache-all でキャッシュをクリア

これだけだと使い物にならないのでグローバルモードにしてみました。

git-commit-createのときだけキャッシュするモード(my-magit-process-cache-commit-msg-mode)

my-magit-process-cache-commit-msg-mode は magit-commit-create の実行開始から編集バッファが出るところまでの間でGitの実行結果をキャッシュするモードです。リポジトリを変更しないことが分かっている期間なので安全にキャッシュできますが、それ以前(例えば直前のgit-refresh時)に取得した情報を再利用することはできません。

このモードを有効にした後にcall-processを記録した結果が次です。

   126.944	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 diff --quiet --cached --) infile=nil dest=nil display=nil
   114.978	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
   108.789	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
   111.174	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(config core.commentchar) infile=nil dest=(t nil) display=nil
   110.404	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 for-each-ref --format=%(refname:short) refs/heads) infile=nil dest=(t nil) display=nil
   119.540	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
   107.830	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
   106.409	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --is-bare-repository) infile=nil dest=(t nil) display=nil
   110.727	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 ls-files --error-unmatch c:/my-test-git-repository/.git/COMMIT_EDITMSG) infile=nil dest=nil display=nil
   113.143	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse HEAD) infile=nil dest=(t nil) display=nil
   103.890	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager ls-files -c -z -- .git/COMMIT_EDITMSG) infile=nil dest=(t nil) display=nil
   108.034	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager ls-tree --name-only -z HEAD -- .git/COMMIT_EDITMSG) infile=nil dest=(t nil) display=nil
   114.293	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager remote get-url upstream) infile=nil dest=t display=nil
   106.079	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager remote get-url origin) infile=nil dest=t display=nil
   142.861	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 diff --quiet --cached --) infile=nil dest=nil display=nil
   117.363	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 diff --quiet --) infile=nil dest=nil display=nil
   111.601	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 config -z --get-all magit.extension) infile=nil dest=(t nil) display=nil
   122.322	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 diff --ita-visible-in-index -p --no-prefix --numstat --cached --stat --no-ext-diff --) infile=nil dest=(t nil) display=nil
  • 合計所要時間: 2056.381ms
  • 平均所要時間: 114.243ms
  • 呼び出し回数: 18回
  • パターン: 18種類

キャッシュされているので各パターン1回ずつの呼び出しになっています。

git-refreshでキャッシュをクリアするモード(my-magit-process-cache-clear-on-refresh-mode)

my-magit-process-cache-clear-on-refresh-mode は常にキャッシュを有効化し、git-refreshを実行するときにキャッシュをクリアするモードです。

次はこのモードを有効にして、git-refreshした直後にgit-commit-createを実行した結果です。

   127.341	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 diff --quiet --cached --) infile=nil dest=nil display=nil
   107.335	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(config core.commentchar) infile=nil dest=(t nil) display=nil
   109.548	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 for-each-ref --format=%(refname:short) refs/heads) infile=nil dest=(t nil) display=nil
   113.989	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --show-toplevel) infile=nil dest=(t nil) display=nil
   108.152	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --git-dir) infile=nil dest=(t nil) display=nil
   104.489	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse --is-bare-repository) infile=nil dest=(t nil) display=nil
   109.008	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 ls-files --error-unmatch c:/my-test-git-repository/.git/COMMIT_EDITMSG) infile=nil dest=nil display=nil
   107.208	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 rev-parse HEAD) infile=nil dest=(t nil) display=nil
   109.791	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager ls-files -c -z -- .git/COMMIT_EDITMSG) infile=nil dest=(t nil) display=nil
   108.371	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager ls-tree --name-only -z HEAD -- .git/COMMIT_EDITMSG) infile=nil dest=(t nil) display=nil
   119.849	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager remote get-url upstream) infile=nil dest=t display=nil
   151.523	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager remote get-url origin) infile=nil dest=t display=nil
   124.484	call git-encwrapper dir=c:/my-test-git-repository/.git/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 diff --quiet --cached --) infile=nil dest=nil display=nil
   117.872	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 diff --quiet --) infile=nil dest=nil display=nil
   110.447	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager --literal-pathspecs -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 config -z --get-all magit.extension) infile=nil dest=(t nil) display=nil
   122.532	call git-encwrapper dir=c:/my-test-git-repository/ args:(--no-pager -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 --no-pager -c core.preloadindex=true -c log.showSignature=false -c color.ui=false -c color.diff=false -c i18n.logOutputEncoding=UTF-8 diff --ita-visible-in-index -p --no-prefix --numstat --cached --stat --no-ext-diff --) infile=nil dest=(t nil) display=nil
  • 合計所要時間: 1851.939ms
  • 平均所要時間: 115.746ms
  • 呼び出し回数: 16回
  • パターン: 16種類

思ったよりも減りませんでした。magit-refreshで取得する情報とそれほど重複がないのでしょう。

このモードはgit-refresh時にしかキャッシュをクリアしないので動作の正しさが保証できません。Magitが何かの変更操作をした後、かつ、git-refreshでキャッシュをクリアする前にその変更に関連する状態を取得しようとしていると、変更前の状態を取得してしまう可能性があります。

全てのコマンドや使い方を確認していないので、そのような問題を引き起こす箇所があるかどうかは分かりません。また、Magitの外で何か変更を加えたときにも問題が生じます。

手動でキャッシュをクリアするモード(my-magit-process-cache-mode)

my-magit-process-cache-mode は、常にキャッシュを有効にし一切クリアしないモードです。

全てがキャッシュに乗りさえすれば笑ってしまうくらい速いです。Linuxでの体感速度に近いですね。

もちろんコミットなど変更操作をした後は手動で更新しないと正しい情報が表示されません。閲覧だけなら問題なし?

いつキャッシュをクリアするか

結局キモはキャッシュした情報が無効になるタイミングを正確に把握できるかどうかです。それが出来れば最高のパフォーマンスが得られるでしょう。Magit外での操作まで考慮すると難しいでしょうが、Magit内だけであれば不可能ではないかもしれません。

Magitのキャッシュ機能

ちなみに、Magitにはプロセスの結果を一時的にキャッシュする仕組みが既にあります。magit-git.elに (magit--with-refresh-cache key &rest body) というマクロがあります。このマクロはbodyを評価した結果を変数 magit--refresh-cache にキャッシュするというものです。すでにキャッシュされている結果を持っている場合は単にそれを返します。keyは主にdefault-directoryやargsを含むリストです。このマクロを使ってキャッシュに値を格納する関数は主にGitを呼び出して文字列を返す関数群のようです。 magit--refresh-cache がnilのときは何もしないので、キャッシュするにはあらかじめletで適当なリストを割り当てておく必要があるようです。例えばmagit-statusの先頭に (let ((magit--refresh-cache (list (cons 0 0)))) のようなコードがあります。つまり、特定の範囲だけ今回と同じようなキャッシュをする仕組みです。

残念ながらこの仕組みは非同期の処理の全体には適用出来ません。また、フックの中からGitを呼び出すような状況でも活用(他の部分とのキャッシュの共有)が難しいでしょう。

今回の場合時間がかかっている部分はserver-executeから呼ばれる関数に集中しているので、server-executeを (let ((magit--refresh-cache (list (cons 0 0)))) (apply original-fun args) ) と:around adviceで無理矢理囲むという手もあるかもしれません。

キャッシュ以外の可能性

もし一回のプロセス起動で複数の情報を取得出来たらかなりの高速化が望めそうです。Gitにそのような機能はあるのでしょうか。またはlibgitを使えばそのようなプログラムを作成できるでしょうか。全ての操作をスクリプト化して一回の呼び出しで実行できればかなり速くなるでしょう。

また、libgitをdynamic module化してEmacsに組み込んでしまう試みが存在するようです。これならそもそもプロセスの呼び出し自体が必要ありません。

magit/libegit2: Emacs bindings for libgit2

ただし問題も多く優先順位も低いためあまり進んでいないようです。

Implement an Elisp binding for libgit2 · Issue #2959 · magit/magit

試してみようと思ったのですが、Emacs Lispからの呼び出し部分が出来ていないように見えます。

個別の改善

ここまででかなりの数のプロセス起動を削減できましたが、まだ1回のコミットメッセージを書くまでに16回のプロセス起動が残っています。

実行されたgitコマンドだけ見てもそれが何のための物なのか分からないので、呼び出し元をbacktraceで表示させてみました。

;; 調査用コード
(require 'backtrace)
(defun my-watch-call-process-with-backtrace (orig-func program infile destination display &rest args)
  (let* ((trace (let ((after-change-major-mode-hook nil))
                  (backtrace-to-string)))
         (str (format "call dir=%s from=\n%s"
                      (expand-file-name default-directory)
                      (replace-regexp-in-string
                       "\\`\\(.\\|\n\\)*?\n\\(  call-process\\)" "\\2"
                       trace))))
    ;;(message "%s" str)
    (with-current-buffer (get-buffer-create "*Watch call-process with backtrace*")
      (insert str "\n"))
    )
  (apply orig-func program infile destination display args))
(advice-add #'call-process :around #'my-watch-call-process-with-backtrace)
(progn
  (switch-to-buffer "magit: my-test-git-repository") ;;既に開いてstageしてあるMagitのバッファを表に出す。
  (magit-commit-create) ;;そのバッファ上でmagit-commit-createを実行する。
  )
;;(advice-remove #'call-process #'my-watch-call-process-with-backtrace)
call dir=c:/my-test-git-repository/ from=
  call-process("git-encwrapper" nil nil nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "diff" "--quiet" "--cached" "--")
  process-file("git-encwrapper" nil nil nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "diff" "--quiet" "--cached" "--")
  magit-process-file("git-encwrapper" nil nil nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "diff" "--quiet" "--cached" "--")
  magit-process-git(nil (("diff" "--quiet" "--cached" nil "--" nil)))
  magit-git-exit-code(("diff" "--quiet" "--cached" nil "--" nil))
  magit-git-failure("diff" "--quiet" "--cached" nil "--" nil)
  magit-anything-staged-p()
  magit-commit-assert(nil)
  #<subr magit-commit-create>()
  apply(#<subr magit-commit-create> nil)
  (let ((result (apply original-fun args))) (if result nil (my-magit-process-cache--commit-create-end)) result)
  my-magit-process-cache--commit-create(#<subr magit-commit-create>)
  apply(my-magit-process-cache--commit-create #<subr magit-commit-create> nil)
  magit-commit-create()
  ...略

call dir=c:/my-test-git-repository/ from=
  call-process("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--show-toplevel")
  process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--show-toplevel")
  magit-process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--show-toplevel")
  magit-process-git((t nil) ("rev-parse" "--show-toplevel"))
  magit-git-str("rev-parse" "--show-toplevel")
  magit-rev-parse-safe("--show-toplevel")
  magit-toplevel()
  #<subr magit-commit-create>()
  ...略

call dir=c:/my-test-git-repository/ from=
  call-process("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--git-dir")
  process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--git-dir")
  magit-process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--git-dir")
  magit-process-git((t nil) ("rev-parse" "--git-dir"))
  magit-git-str("rev-parse" "--git-dir")
  magit-rev-parse-safe("--git-dir")
  magit-git-dir()
  magit--record-separated-gitdir()
  magit-run-git-with-editor("commit" ("--"))
  #<subr magit-commit-create>()
  ...略

call dir=c:/my-test-git-repository/.git/ from=
  call-process("git-encwrapper" nil (t nil) nil "config" "core.commentchar")
  git-commit-setup-font-lock()
  git-commit-setup-font-lock-in-buffer()
  run-hooks(change-major-mode-after-body-hook after-change-major-mode-hook)
  normal-mode(t)
  after-find-file(nil t)
  find-file-noselect-1(#<buffer COMMIT_EDITMSG> "c:/my-test-git-repository/.git/COMMIT_EDITMSG" nil nil "c:/my-test-git-repository/.git/COMMIT_EDITMSG" (341992096703475215 1121764838))
  find-file-noselect("C:/my-test-git-repository/.git/COMMIT_EDITMSG")
  #<subr server-visit-files>((("C:/my-test-git-repository/.git/COMMIT_EDITMSG")) #<process server23432 <127.0.0.1:64200>> nil)
  apply(#<subr server-visit-files> ((("C:/my-test-git-repository/.git/COMMIT_EDITMSG")) #<process server23432 <127.0.0.1:64200>> nil))
  server-visit-files((("C:/my-test-git-repository/.git/COMMIT_EDITMSG")) #<process server23432 <127.0.0.1:64200>> nil)
  server-execute(#<process server23432 <127.0.0.1:64200>> (("C:/my-test-git-repository/.git/COMMIT_EDITMSG")) nil nil t nil nil)
  #f(compiled-function () #<bytecode -0x1bd4f2f840dbc4c>)()
  server-execute-continuation(#<process server23432 <127.0.0.1:64200>>)
  server-process-filter(#<process server23432 <127.0.0.1:64200>> "-auth [m:TL:<;51aiw67(FyI/O,\\{$|yUxQ0>:kv|IC?b~Kg&...")

call dir=c:/my-test-git-repository/.git/ from=
  call-process("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "for-each-ref" "--format=%(refname:short)" "refs/heads")
  process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "for-each-ref" "--format=%(refname:short)" "refs/heads")
  magit-process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "for-each-ref" "--format=%(refname:short)" "refs/heads")
  magit-process-git((t nil) ("--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "for-each-ref" "--format=%(refname:short)" "refs/heads"))
  magit-git-insert("for-each-ref" "--format=%(refname:short)" nil "refs/heads")
  magit-git-lines("for-each-ref" "--format=%(refname:short)" nil "refs/heads")
  magit-list-refs("refs/heads" "%(refname:short)")
  magit-list-refnames("refs/heads")
  magit-list-local-branch-names()
  git-commit-setup-font-lock()
  git-commit-setup-font-lock-in-buffer()
  run-hooks(change-major-mode-after-body-hook after-change-major-mode-hook)
  normal-mode(t)
  after-find-file(nil t)
  ...略

call dir=c:/my-test-git-repository/.git/ from=
  call-process("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--show-toplevel")
  process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--show-toplevel")
  magit-process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--show-toplevel")
  magit-process-git((t nil) ("rev-parse" "--show-toplevel"))
  magit-git-str("rev-parse" "--show-toplevel")
  magit-rev-parse-safe("--show-toplevel")
  magit-toplevel()
  magit-turn-on-auto-revert-mode-if-desired()
  magit-auto-revert-mode-enable-in-buffers()
  run-hooks(change-major-mode-after-body-hook after-change-major-mode-hook)
  normal-mode(t)
  after-find-file(nil t)
  ...略

call dir=c:/my-test-git-repository/.git/ from=
  call-process("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--git-dir")
  process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--git-dir")
  magit-process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--git-dir")
  magit-process-git((t nil) ("rev-parse" "--git-dir"))
  magit-git-str("rev-parse" "--git-dir")
  magit-rev-parse-safe("--git-dir")
  magit-toplevel()
  magit-turn-on-auto-revert-mode-if-desired()
  magit-auto-revert-mode-enable-in-buffers()
  run-hooks(change-major-mode-after-body-hook after-change-major-mode-hook)
  normal-mode(t)
  after-find-file(nil t)
  ...略

call dir=c:/my-test-git-repository/.git/ from=
  call-process("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--is-bare-repository")
  process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--is-bare-repository")
  magit-process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--is-bare-repository")
  magit-process-git((t nil) ("rev-parse" "--is-bare-repository"))
  magit-git-output(("rev-parse" ("--is-bare-repository")))
  magit-git-true("rev-parse" ("--is-bare-repository"))
  magit-rev-parse-true("--is-bare-repository")
  magit-bare-repo-p()
  magit-toplevel()
  magit-turn-on-auto-revert-mode-if-desired()
  magit-auto-revert-mode-enable-in-buffers()
  run-hooks(change-major-mode-after-body-hook after-change-major-mode-hook)
  normal-mode(t)
  after-find-file(nil t)
  ...略

call dir=c:/my-test-git-repository/.git/ from=
  call-process("git-encwrapper" nil nil nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "ls-files" "--error-unmatch" "c:/my-test-git-repository/.git/COMMIT_EDITMSG")
  process-file("git-encwrapper" nil nil nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "ls-files" "--error-unmatch" "c:/my-test-git-repository/.git/COMMIT_EDITMSG")
  magit-process-file("git-encwrapper" nil nil nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "ls-files" "--error-unmatch" "c:/my-test-git-repository/.git/COMMIT_EDITMSG")
  magit-process-git(nil (("ls-files" "--error-unmatch" "c:/my-test-git-repository/.git/COMMIT_EDITMSG")))
  magit-git-exit-code(("ls-files" "--error-unmatch" "c:/my-test-git-repository/.git/COMMIT_EDITMSG"))
  magit-git-success("ls-files" "--error-unmatch" "c:/my-test-git-repository/.git/COMMIT_EDITMSG")
  magit-file-tracked-p("c:/my-test-git-repository/.git/COMMIT_EDITMSG")
  magit-turn-on-auto-revert-mode-if-desired()
  magit-auto-revert-mode-enable-in-buffers()
  run-hooks(change-major-mode-after-body-hook after-change-major-mode-hook)
  normal-mode(t)
  after-find-file(nil t)
  ...略

call dir=c:/my-test-git-repository/.git/ from=
  call-process("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "HEAD")
  process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "HEAD")
  magit-process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "HEAD")
  magit-process-git((t nil) ("--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "HEAD"))
  magit-git-insert("rev-parse" "HEAD")
  magit-git-string("rev-parse" "HEAD")
  magit-rev-parse("HEAD")
  git-commit-setup()
  git-commit-setup-check-buffer()
  run-hooks(find-file-hook)
  after-find-file(nil t)
  ...略

call dir=c:/my-test-git-repository/ from=
  call-process("git-encwrapper" nil (t nil) nil "--no-pager" "ls-files" "-c" "-z" "--" ".git/COMMIT_EDITMSG")
  process-file("git-encwrapper" nil (t nil) nil "--no-pager" "ls-files" "-c" "-z" "--" ".git/COMMIT_EDITMSG")
  vc-git--call((t nil) "ls-files" "-c" "-z" "--" ".git/COMMIT_EDITMSG")
  vc-git--out-ok("ls-files" "-c" "-z" "--" ".git/COMMIT_EDITMSG")
  vc-git-registered("c:/my-test-git-repository/.git/COMMIT_EDITMSG")
  vc-call-backend(Git registered "c:/my-test-git-repository/.git/COMMIT_EDITMSG")
  #f(compiled-function (b) #<bytecode 0x14704c4aaf6471f6>)(Git)
  mapc(#f(compiled-function (b) #<bytecode 0x14704c4aaf6471f6>) (RCS CVS SVN SCCS SRC Bzr Git Hg))
  vc-registered("c:/my-test-git-repository/.git/COMMIT_EDITMSG")
  vc-backend("c:/my-test-git-repository/.git/COMMIT_EDITMSG")
  vc-responsible-backend("c:/my-test-git-repository/.git/COMMIT_EDITMSG" t)
  bug-reference-try-setup-from-vc()
  run-hook-with-args-until-success(bug-reference-try-setup-from-vc)
  bug-reference--run-auto-setup()
  bug-reference-mode()
  run-hooks(git-commit-setup-hook)
  git-commit-setup()
  git-commit-setup-check-buffer()
  run-hooks(find-file-hook)
  after-find-file(nil t)
  ...略

call dir=c:/my-test-git-repository/ from=
  call-process("git-encwrapper" nil (t nil) nil "--no-pager" "ls-tree" "--name-only" "-z" "HEAD" "--" ".git/COMMIT_EDITMSG")
  process-file("git-encwrapper" nil (t nil) nil "--no-pager" "ls-tree" "--name-only" "-z" "HEAD" "--" ".git/COMMIT_EDITMSG")
  vc-git--call((t nil) "ls-tree" "--name-only" "-z" "HEAD" "--" ".git/COMMIT_EDITMSG")
  vc-git--out-ok("ls-tree" "--name-only" "-z" "HEAD" "--" ".git/COMMIT_EDITMSG")
  vc-git-registered("c:/my-test-git-repository/.git/COMMIT_EDITMSG")
  vc-call-backend(Git registered "c:/my-test-git-repository/.git/COMMIT_EDITMSG")
  #f(compiled-function (b) #<bytecode 0x14704c4aaf6471f6>)(Git)
  mapc(#f(compiled-function (b) #<bytecode 0x14704c4aaf6471f6>) (RCS CVS SVN SCCS SRC Bzr Git Hg))
  vc-registered("c:/my-test-git-repository/.git/COMMIT_EDITMSG")
  vc-backend("c:/my-test-git-repository/.git/COMMIT_EDITMSG")
  vc-responsible-backend("c:/my-test-git-repository/.git/COMMIT_EDITMSG" t)
  bug-reference-try-setup-from-vc()
  run-hook-with-args-until-success(bug-reference-try-setup-from-vc)
  bug-reference--run-auto-setup()
  bug-reference-mode()
  run-hooks(git-commit-setup-hook)
  git-commit-setup()
  git-commit-setup-check-buffer()
  run-hooks(find-file-hook)
  after-find-file(nil t)
  ...略

call dir=c:/my-test-git-repository/ from=
  call-process("git-encwrapper" nil t nil "--no-pager" "remote" "get-url" "upstream")
  process-file("git-encwrapper" nil t nil "--no-pager" "remote" "get-url" "upstream")
  vc-do-command(#<buffer  *temp*-514073> 0 "git-encwrapper" nil "--no-pager" "remote" "get-url" "upstream")
  vc-git-command(#<buffer  *temp*-514073> 0 nil "remote" "get-url" "upstream")
  vc-git-repository-url("c:/my-test-git-repository/.git/COMMIT_EDITMSG" "upstream")
  vc-call-backend(Git repository-url "c:/my-test-git-repository/.git/COMMIT_EDITMSG" "upstream")
  #f(compiled-function (remote) #<bytecode 0xc87372323b60bec>)("upstream")
  #f(compiled-function (elt) #<bytecode 0xd0e31d85bc76844>)("upstream")
  mapc(#f(compiled-function (elt) #<bytecode 0xd0e31d85bc76844>) ("upstream" nil))
  seq-do(#f(compiled-function (elt) #<bytecode 0xd0e31d85bc76844>) ("upstream" nil))
  seq-some(#f(compiled-function (remote) #<bytecode 0xc87372323b60bec>) ("upstream" nil))
  bug-reference-try-setup-from-vc()
  run-hook-with-args-until-success(bug-reference-try-setup-from-vc)
  bug-reference--run-auto-setup()
  bug-reference-mode()
  run-hooks(git-commit-setup-hook)
  git-commit-setup()
  git-commit-setup-check-buffer()
  run-hooks(find-file-hook)
  after-find-file(nil t)
  ...略

call dir=c:/my-test-git-repository/ from=
  call-process("git-encwrapper" nil t nil "--no-pager" "remote" "get-url" "origin")
  process-file("git-encwrapper" nil t nil "--no-pager" "remote" "get-url" "origin")
  vc-do-command(#<buffer  *temp*-332582> 0 "git-encwrapper" nil "--no-pager" "remote" "get-url" "origin")
  vc-git-command(#<buffer  *temp*-332582> 0 nil "remote" "get-url" "origin")
  vc-git-repository-url("c:/my-test-git-repository/.git/COMMIT_EDITMSG" nil)
  vc-call-backend(Git repository-url "c:/my-test-git-repository/.git/COMMIT_EDITMSG" nil)
  #f(compiled-function (remote) #<bytecode 0xc87372323b60bec>)(nil)
  #f(compiled-function (elt) #<bytecode 0xd0e31d85bc76844>)(nil)
  mapc(#f(compiled-function (elt) #<bytecode 0xd0e31d85bc76844>) ("upstream" nil))
  seq-do(#f(compiled-function (elt) #<bytecode 0xd0e31d85bc76844>) ("upstream" nil))
  seq-some(#f(compiled-function (remote) #<bytecode 0xc87372323b60bec>) ("upstream" nil))
  bug-reference-try-setup-from-vc()
  run-hook-with-args-until-success(bug-reference-try-setup-from-vc)
  bug-reference--run-auto-setup()
  bug-reference-mode()
  run-hooks(git-commit-setup-hook)
  git-commit-setup()
  git-commit-setup-check-buffer()
  run-hooks(find-file-hook)
  after-find-file(nil t)
  ...略

call dir=c:/my-test-git-repository/.git/ from=
  call-process("git-encwrapper" nil nil nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "diff" "--quiet" "--cached" "--")
  process-file("git-encwrapper" nil nil nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "diff" "--quiet" "--cached" "--")
  magit-process-file("git-encwrapper" nil nil nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "diff" "--quiet" "--cached" "--")
  magit-process-git(nil (("diff" "--quiet" "--cached" nil "--" nil)))
  magit-git-exit-code(("diff" "--quiet" "--cached" nil "--" nil))
  magit-git-failure("diff" "--quiet" "--cached" nil "--" nil)
  magit-anything-staged-p()
  magit-commit-diff-1()
  #<subr magit-commit-diff>()
  apply(#<subr magit-commit-diff> nil)
  magit-commit-diff()
  run-hooks(server-switch-hook)
  server-execute(#<process server23432 <127.0.0.1:64200>> (("C:/my-test-git-repository/.git/COMMIT_EDITMSG")) nil nil t nil nil)
  ...略

call dir=c:/my-test-git-repository/ from=
  call-process("git-encwrapper" nil nil nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "diff" "--quiet" "--")
  process-file("git-encwrapper" nil nil nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "diff" "--quiet" "--")
  magit-process-file("git-encwrapper" nil nil nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "diff" "--quiet" "--")
  magit-process-git(nil (("diff" "--quiet" nil "--" nil)))
  magit-git-exit-code(("diff" "--quiet" nil "--" nil))
  magit-git-failure("diff" "--quiet" nil "--" nil)
  magit-anything-unstaged-p()
  magit-commit-diff-1()
  #<subr magit-commit-diff>()
  apply(#<subr magit-commit-diff> nil)
  magit-commit-diff()
  run-hooks(server-switch-hook)
  server-execute(#<process server23432 <127.0.0.1:64200>> (("C:/my-test-git-repository/.git/COMMIT_EDITMSG")) nil nil t nil nil)
  ...略

call dir=c:/my-test-git-repository/ from=
  call-process("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "config" "-z" "--get-all" "magit.extension")
  process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "config" "-z" "--get-all" "magit.extension")
  magit-process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "config" "-z" "--get-all" "magit.extension")
  magit-process-git((t nil) ("--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "config" "-z" "--get-all" "magit.extension"))
  magit-git-insert("config" nil "-z" "--get-all" "magit.extension")
  magit-git-items("config" nil "-z" "--get-all" "magit.extension")
  magit-get-all("magit.extension")
  magit-load-config-extensions()
  run-hooks(change-major-mode-after-body-hook special-mode-hook magit-section-mode-hook magit-mode-hook magit-diff-mode-hook)
  apply(run-hooks (change-major-mode-after-body-hook special-mode-hook magit-section-mode-hook magit-mode-hook magit-diff-mode-hook))
  run-mode-hooks(magit-diff-mode-hook)
  magit-diff-mode()
  magit-setup-buffer-internal(magit-diff-mode nil ((magit-buffer-range nil) (magit-buffer-typearg "--cached") (magit-buffer-diff-args ("--stat" "--no-ext-diff")) (magit-buffer-diff-files nil) (magit-buffer-diff-files-suspended nil)))
  magit-diff-setup-buffer(nil "--cached" ("--stat" "--no-ext-diff") nil)
  magit-commit-diff-1()
  #<subr magit-commit-diff>()
  apply(#<subr magit-commit-diff> nil)
  magit-commit-diff()
  run-hooks(server-switch-hook)
  server-execute(#<process server23432 <127.0.0.1:64200>> (("C:/my-test-git-repository/.git/COMMIT_EDITMSG")) nil nil t nil nil)
  ...略

call dir=c:/my-test-git-repository/ from=
  call-process("git-encwrapper" nil (t nil) nil "--no-pager" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "--no-pager" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "diff" "--ita-visible-in-index" "-p" "--no-prefix" "--numstat" "--cached" "--stat" "--no-ext-diff" "--")
  process-file("git-encwrapper" nil (t nil) nil "--no-pager" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "--no-pager" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "diff" "--ita-visible-in-index" "-p" "--no-prefix" "--numstat" "--cached" "--stat" "--no-ext-diff" "--")
  magit-process-file("git-encwrapper" nil (t nil) nil "--no-pager" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "--no-pager" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "diff" "--ita-visible-in-index" "-p" "--no-prefix" "--numstat" "--cached" "--stat" "--no-ext-diff" "--")
  magit-process-git((t nil) ("--no-pager" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "diff" "--ita-visible-in-index" "-p" "--no-prefix" "--numstat" "--cached" "--stat" "--no-ext-diff" "--"))
  magit-git-insert(("diff" "--ita-visible-in-index" "-p" "--no-prefix" "--numstat" "--cached" "--stat" "--no-ext-diff" "--"))
  magit-git-wash(magit-diff-wash-diffs "diff" ("--ita-visible-in-index" "-p" "--no-prefix" "--numstat" "--cached" "--stat" "--no-ext-diff" "--"))
  magit--insert-diff("diff" nil "-p" "--no-prefix" "--numstat" "--cached" ("--stat" "--no-ext-diff") "--" nil)
  magit-insert-diff()
  magit-run-section-hook(magit-diff-sections-hook)
  magit-diff-refresh-buffer()
  magit-refresh-buffer()
  magit-setup-buffer-internal(magit-diff-mode nil ((magit-buffer-range nil) (magit-buffer-typearg "--cached") (magit-buffer-diff-args ("--stat" "--no-ext-diff")) (magit-buffer-diff-files nil) (magit-buffer-diff-files-suspended nil)))
  magit-diff-setup-buffer(nil "--cached" ("--stat" "--no-ext-diff") nil)
  magit-commit-diff-1()
  #<subr magit-commit-diff>()
  apply(#<subr magit-commit-diff> nil)
  magit-commit-diff()
  run-hooks(server-switch-hook)
  ...略

まとめると次のようになります。

gitコマンドの引数 呼び出し元 より大きな呼び出し元 対策
diff --quiet --cached -- magit-anything-staged-p magit-commit-create  
rev-parse --show-toplevel magit-toplevel magit-commit-create 常時キャッシュ
rev-parse --git-dir magit-git-dir magit-commit-create 常時キャッシュ
config core.commentchar 直接呼び出し git-commit-setup-font-lock 常時キャッシュ
for-each-ref --format=%(refname: ...略 magit-list-local-branch-names git-commit-setup-font-lock 色分け無効化
rev-parse --show-toplevel magit-toplevel magit-turn-on-auto-revert-mode-if-desired 常時キャッシュ
rev-parse --git-dir magit-toplevel magit-turn-on-auto-revert-mode-if-desired 常時キャッシュ
rev-parse --is-bare-repository magit-toplevel magit-turn-on-auto-revert-mode-if-desired 常時キャッシュ
ls-files --error-unmatch c:/my- ...略 magit-file-tracked-p magit-turn-on-auto-revert-mode-if-desired コミットファイル無視
rev-parse HEAD magit-rev-parse git-commit-setup  
ls-files -c -z -- .git/COMMIT_EDITMSG vc-git-registered bug-reference-mode mode無効化
ls-tree --name-only -z HEAD -- ....略 vc-git-registered bug-reference-mode mode無効化,コミットファイル無視
remote get-url upstream vc-git-repository-url bug-reference-mode mode無効化
remote get-url origin vc-git-repository-url bug-reference-mode mode無効化
diff --quiet --cached -- magit-anything-staged-p magit-commit-diff  
diff --quiet -- magit-anything-unstaged-p magit-commit-diff  
config -z --get-all magit.extension magit-load-config-extensions magit-commit-diff 常時キャッシュ
diff --ita-visible-in-index -p ...略 magit-insert-diff magit-commit-diff  

それぞれのgitコマンドが何のために呼ばれているのかを調べ、一段階高い視点から削減を試みます。

VCとbug-reference-mode

bug-reference-mode から4回もgitが起動されています。

bug-reference-mode はバグトラッカーの番号をリンクに置き換えるマイナーモードのようです。

そしてその bug-reference-mode は git-commit-setup-hook に設定されていることから呼び出されています。

私はこの機能を使っていないのでサクッと登録解除してしまいましょう。

;; ■bug-reference-mode抑制
;; 次のコードはコミットメッセージを書くバッファでbug-reference-modeが起動するのを抑制します。
(with-eval-after-load "git-commit"
  (remove-hook 'git-commit-setup-hook 'bug-reference-mode))

もし使いたい場合でも改善する方法はあります。

vc-git-registeredで.git/COMMIT_EDITMSGファイルがgitリポジトリに登録されているか確認していますが、されているわけがありません(特殊な機能でされることがあったらすみません)。なので次のような最適化が可能です。

;; ■vc-git-registeredで.git/COMMIT_EDITMSGを無視
;; 次のコードは.git/COMMIT_EDITMSG等を即座にgit登録外と判定します。これによりプロセスの起動回数を削減できます。
;; 注意:もし意図的にgitの中で.git/COMMIT_EDITMSGという名前のディレクトリ名やファイル名を使いたいならこのコードは問題になります。(gitがそのようなディレクトリ名を許容するのか知りませんが)
(defun my-vc-git-registered-for-ignoring-commit-filenames (original-fun file)
  (if (string-match-p (concat ".git" git-commit-filename-regexp) file)
      nil
    (funcall original-fun file)))
(advice-add #'vc-git-registered :around #'my-vc-git-registered-for-ignoring-commit-filenames)

bug-reference-modeを使わない場合でもfind-file-hook経由でvc-refresh-stateが呼ばれてvc-git-registeredが呼ばれるようなので、上のコードは起動回数削減に寄与するでしょう。

vc-git-registeredに対処して結果がキャッシュされなくなると、 after-change-major-mode-hook → magit-turn-on-auto-revert-mode-if-desired → magit-file-tracked-p という流れで同じように.git/COMMIT_EDITMSGの登録確認が実行されます。これも同様に対処できます。

;; ■magit-file-tracked-pで.git/COMMIT_EDITMSGを無視
(defun my-magit-file-tracked-p-for-ignoring-commit-filenames (original-fun file)
  (if (string-match-p (concat ".git" git-commit-filename-regexp) file)
      nil
    (funcall original-fun file)))
(advice-add #'magit-file-tracked-p :around #'my-magit-file-tracked-p-for-ignoring-commit-filenames)

バッファの色づけ(git-commit-setup-font-lock)

git-commit-setup-font-lockからgitが呼ばれるのは2回。

一つはmagit-list-local-branch-namesでブランチ名を列挙しているところ。ブランチ名をローカルとリモートで色分けしたいですか? 私は諦められます。というか現在のコードはdeffaceで(featurep 'magit)を使って分岐していますが、magitから(require 'git-commit)するので常にnilです。このままだと常に両方ともfont-lock-variable-name-faceが使われるので、どのみち色分けされません。

ただ、コードの構造的に簡単に直すのが難しいです。関数全体を書き替えてしまうのも手ですが、とりあえず次のコードで無理矢理直しました。

;; ■ブランチ名の色分けを抑制
;; 次のコードはコミットメッセージ用バッファでブランチ名を取得できないようにします。
;; プロセスの起動回数を削減できますが、ローカルブランチとリモートブランチの色分けが行われなくなります。
(defun my-git-commit-setup-font-lock-for-blocking-branch-names-retrieval (original-fun &rest args)
  (cl-letf (((symbol-function 'magit-list-local-branch-names) (lambda () nil))) ;;一時的に関数シンボルの指す先を空にする。
    (apply original-fun args)))
(advice-add #'git-commit-setup-font-lock :around #'my-git-commit-setup-font-lock-for-blocking-branch-names-retrieval)

もう一つは git config core.commentchar を直接的に実行しているところ。コメントの色分けに使うのでしょう。これについては次で。

configのキャッシュを保持

使われているgit configコマンドは次の通りです。

  • config core.commentchar
  • config -z --get-all magit.extension

いずれの機能も使っていないので無視しても構いません。

しかし一応対応するのであれば、configコマンドは一律キャッシュをクリアしないというのはどうでしょう。そのための仕組みは既にmy-magit-process-cache.elに作ってあります。

(setq my-magit-process-cache--keep-args-regexp "\\bconfig\\b")

正規表現にマッチするコマンドライン引数を持つキャッシュはデフォルトではクリアされなくなります。

この正規表現だと値の設定や消去(unset)にもマッチしてしまいますが、とりあえずここでは発生しないので置いておきましょう。

もちろんどこかでconfigを変更したときには正しく動作しなくなります。しかし私は上の二つの設定を使っていませんし、使うとしても変更する頻度は高くないでしょう。そのような設定値を頻繁にプロセス起動で取得するのは割に合いません。

念のためgit-status実行時にクリアするのはどうでしょう。おかしくなったら立ち上げ直しますよね?

(defun my-magit-status-for-clearing-cache (&rest args)
  (my-magit-process-cache--clear-cache-all-forced))
(advice-add #'magit-status :before #'my-magit-status-for-clearing-cache)

一部のrev-parseを保持

使われているgit rev-parseコマンドは次の通りです。

  • rev-parse HEAD
  • rev-parse --git-dir
  • rev-parse --show-toplevel
  • rev-parse --is-bare-repository

rev-parse HEAD は頻繁に変わりますが、それ以外はディレクトリ構造を変えない限り変化しません。これもconfigと同じようにキャッシュを維持して良いのではないでしょうか。

(setq my-magit-process-cache--keep-args-regexp "\\(\\bconfig\\b\\|\\brev-parse \\(--show-toplevel\\|--git-dir\\|--is-bare-repository\\)\\'\\)")

stageされているか否か

magit-anything-staged-p と magit-anything-unstaged-p という関数があります。その名の通り現在のstage状況を確認するための関数です。staged-pはstageされている変更があるかどうか、unstaged-pはstageしていない変更があるかどうかです。

magit-commit-create から magit-anything-staged-p が呼ばれるのは仕方がありません。stageしている変更が無ければそこで終了すべきですから。

しかし magit-commit-diff-1 から magit-anything-staged-p や magit-anything-unstaged-p が呼ばれているのはなぜでしょうか。 magit-commit- なのですからここに来る段階ではstagedなのが当たり前ではないでしょうか。unstagedだと何が変わるのでしょうか。

magit-commit-diff-1 のソースコードを読んでみると、案外色々なシチュエーションがあるようです。ただ、 magit-commit-create によってここに来た場合は staged も unstaged もあえて取得する意味は無いように見えます。であれば次のように必ずstaged=t、unstaged=nilになるようにしてプロセス起動を回避できます。

;; ■staged, unstagedチェックの回避
(defun my-magit-commit-diff-1-for-avoid-call-process (original-fun &rest args)
  (let ((command (magit-repository-local-get 'this-commit-command)))
    (if (memq command
              ;; magit-commit-diff-1内に書かれている特別な対応が必要なコマンド一覧
              '(magit-commit--rebase magit-commit-amend magit-commit-reword magit-commit--all handle-switch-frame))
        (apply original-fun args)
      ;; magit-commit-create等特別な対応が必要ないコマンドなら
      ;; 必ずstage=t, unstaged=nilで良い、と思う。
      ;; (nil nil ,_) が気になるけど、そんなシチュエーションあるの?
      (cl-letf (((symbol-function 'magit-anything-staged-p) (lambda () t))
                ((symbol-function 'magit-anything-unstaged-p) (lambda () nil)))
        (apply original-fun args)))))
(advice-add #'magit-commit-diff-1 :around #'my-magit-commit-diff-1-for-avoid-call-process)

残り

diff --quiet --cached -- magit-anything-staged-p magit-commit-create
rev-parse HEAD magit-rev-parse git-commit-setup
diff --ita-visible-in-index -p ...略 magit-insert-diff magit-commit-diff

rev-parse HEADはコミットのたびに変化してしまいます。取得したコミットのハッシュ値は、git-commit-run-post-finish-hookでコミットが完了するのを待つときに使われます。0.01秒ごとにrev-parse HEADを実行して変化したらコミット完了と判定するみたいです。そんなの別に今じゃなくてもいいじゃん、書いている途中に非同期で取得してよ、と思いますが、まぁ、このくらいは勘弁してやります。面倒くさいし。非同期はともかくfinish時でいいとは思いますけどね。

最後のdiffはdiffを表示するなら避けられないでしょう。

その他細かい設定

git-commit-major-modeをnilにしておくとメジャーモードの切り替え処理が一つ減ります。デフォルトはtext-modeになっています。 fundamental-modeでいいやと思うならnilにしましょう。数十msくらい節約になります。

;; ■コミットメッセージを書くためのバッファでメジャーモードを切り替えない
(setq git-commit-major-mode nil)

最初にメジャーモードが設定される時にやってしまえば良さそうなものですが出来ないのでしょうか?

最終計測

というわけで最終計測です。最初の方で実行したcall-processを含んだ方法で計測します。call-processが削減されたことも確認したいので。

;; 調査用コード
(require 'my-profiler)
(my-profiler-instrument-all
 '((magit-commit-create . start)
   magit-commit-diff
   (server-execute . stop)
   git-commit-setup
   git-commit-setup-font-lock-in-buffer
   magit-auto-revert-mode-enable-in-buffers
   normal-mode
   (call-process . short)
))
(progn
  (switch-to-buffer "magit: my-test-git-repository") ;;既に開いてstageしてあるMagitのバッファを表に出す。
  (magit-commit-create) ;;そのバッファ上でmagit-commit-createを実行する。
)

一回目はconfigやrev-parseのキャッシュが済んでいないのでやや遅くなります。

TM	     0.023	+     0.023	          	Enter #[128 \300\301\302^C#\207 [apply my-magit-process-cache--commit-create #<subr magit-commit-create> nil] 5 nil (byte-code ^C\203
\0\301\302 BC\207\302 C\207 [current-prefix-arg --amend magit-commit-arguments] 2)]
TM	    90.752	+    90.729	    90.361	Eval   #[128 \300\301\302^C#\207 [apply my-call-process-for-bypassing-git-encwrapper #[128 \300\301\302^C#\207 [apply my-procargfix-advice--call-process #<subr call-process> ((depth . 99))] 5 nil] nil] 5 nil]
TM	   170.682	+    79.930	    79.417	Eval   #[128 \300\301\302^C#\207 [apply my-call-process-for-bypassing-git-encwrapper #[128 \300\301\302^C#\207 [apply my-procargfix-advice--call-process #<subr call-process> ((depth . 99))] 5 nil] nil] 5 nil]
TM	   250.379	+    79.697	    78.845	Eval   #[128 \300\301\302^C#\207 [apply my-call-process-for-bypassing-git-encwrapper #[128 \300\301\302^C#\207 [apply my-procargfix-advice--call-process #<subr call-process> ((depth . 99))] 5 nil] nil] 5 nil]
TM	   347.523	+    97.144	    75.891	Eval   #[128 \300\301\302^C#\207 [apply my-call-process-for-bypassing-git-encwrapper #[128 \300\301\302^C#\207 [apply my-procargfix-advice--call-process #<subr call-process> ((depth . 99))] 5 nil] nil] 5 nil]
TM	   347.642	+     0.119	          	Enter  #<subr git-commit-setup-font-lock-in-buffer>
TM	   347.666	+     0.024	     0.017	Leave  #<subr git-commit-setup-font-lock-in-buffer>
TM	   347.678	+     0.012	          	Enter  #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   347.698	+     0.020	     0.014	Leave  #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   360.608	+    12.910	   360.541	Leave #[128 \300\301\302^C#\207 [apply my-magit-process-cache--commit-create #<subr magit-commit-create> nil] 5 nil (byte-code ^C\203
\0\301\302 BC\207\302 C\207 [current-prefix-arg --amend magit-commit-arguments] 2)]
TM	   360.700	+     0.092	          	Enter #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   360.726	+     0.026	     0.014	Leave #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   534.973	+   174.247	          	Enter #<subr server-execute>
TM	   542.818	+     7.845	          	Enter  #<subr normal-mode>
TM	   542.860	+     0.042	          	Enter   #<subr git-commit-setup-font-lock-in-buffer>
TM	   617.753	+    74.893	    74.777	Eval     #[128 \300\301\302^C#\207 [apply my-call-process-for-bypassing-git-encwrapper #[128 \300\301\302^C#\207 [apply my-procargfix-advice--call-process #<subr call-process> ((depth . 99))] 5 nil] nil] 5 nil]
TM	   618.189	+     0.436	    75.309	Leave   #<subr git-commit-setup-font-lock-in-buffer>
TM	   618.229	+     0.040	          	Enter   #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   712.136	+    93.907	    84.548	Eval     #[128 \300\301\302^C#\207 [apply my-call-process-for-bypassing-git-encwrapper #[128 \300\301\302^C#\207 [apply my-procargfix-advice--call-process #<subr call-process> ((depth . 99))] 5 nil] nil] 5 nil]
TM	   789.723	+    77.587	    77.278	Eval     #[128 \300\301\302^C#\207 [apply my-call-process-for-bypassing-git-encwrapper #[128 \300\301\302^C#\207 [apply my-procargfix-advice--call-process #<subr call-process> ((depth . 99))] 5 nil] nil] 5 nil]
TM	   866.628	+    76.905	    76.519	Eval     #[128 \300\301\302^C#\207 [apply my-call-process-for-bypassing-git-encwrapper #[128 \300\301\302^C#\207 [apply my-procargfix-advice--call-process #<subr call-process> ((depth . 99))] 5 nil] nil] 5 nil]
TM	   866.940	+     0.312	   248.700	Leave   #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   871.546	+     4.606	          	Enter   #<subr git-commit-setup-font-lock-in-buffer>
TM	   872.208	+     0.662	     0.643	Leave   #<subr git-commit-setup-font-lock-in-buffer>
TM	   872.240	+     0.032	          	Enter   #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   881.868	+     9.628	     9.617	Leave   #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   882.129	+     0.261	   339.300	Leave  #<subr normal-mode>
TM	   882.152	+     0.023	          	Enter  #<subr git-commit-setup>
TM	   967.860	+    85.708	    84.202	Eval    #[128 \300\301\302^C#\207 [apply my-call-process-for-bypassing-git-encwrapper #[128 \300\301\302^C#\207 [apply my-procargfix-advice--call-process #<subr call-process> ((depth . 99))] 5 nil] nil] 5 nil]
TM	   973.618	+     5.758	    91.407	Leave  #<subr git-commit-setup>
TM	   973.642	+     0.024	          	Enter  #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   973.660	+     0.018	     0.011	Leave  #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   977.661	+     4.001	          	Enter  #<subr magit-commit-diff>
TM	   984.019	+     6.358	          	Enter   #<subr git-commit-setup-font-lock-in-buffer>
TM	   984.049	+     0.030	     0.022	Leave   #<subr git-commit-setup-font-lock-in-buffer>
TM	   984.078	+     0.029	          	Enter   #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   984.107	+     0.029	     0.023	Leave   #<subr magit-auto-revert-mode-enable-in-buffers>
TM	  1110.370	+   126.263	   125.311	Eval    #[128 \300\301\302^C#\207 [apply my-call-process-for-bypassing-git-encwrapper #[128 \300\301\302^C#\207 [apply my-procargfix-advice--call-process #<subr call-process> ((depth . 99))] 5 nil] nil] 5 nil]
TM	  1111.088	+     0.718	   133.404	Leave  #<subr magit-commit-diff>
TM	  1113.181	+     2.093	   578.189	Leave #<subr server-execute>

問題は二回目以降です。

TM	     0.023	+     0.023	          	Enter #[128 \300\301\302^C#\207 [apply my-magit-process-cache--commit-create #<subr magit-commit-create> nil] 5 nil (byte-code ^C\203
\0\301\302 BC\207\302 C\207 [current-prefix-arg --amend magit-commit-arguments] 2)]
TM	    87.735	+    87.712	    87.139	Eval   #[128 \300\301\302^C#\207 [apply my-call-process-for-bypassing-git-encwrapper #[128 \300\301\302^C#\207 [apply my-procargfix-advice--call-process #<subr call-process> ((depth . 99))] 5 nil] nil] 5 nil]
TM	   103.653	+    15.918	   103.562	Leave #[128 \300\301\302^C#\207 [apply my-magit-process-cache--commit-create #<subr magit-commit-create> nil] 5 nil (byte-code ^C\203
\0\301\302 BC\207\302 C\207 [current-prefix-arg --amend magit-commit-arguments] 2)]
TM	   296.154	+   192.501	          	Enter #<subr server-execute>
TM	   303.936	+     7.782	          	Enter  #<subr normal-mode>
TM	   303.981	+     0.045	          	Enter   #<subr git-commit-setup-font-lock-in-buffer>
TM	   304.298	+     0.317	     0.307	Leave   #<subr git-commit-setup-font-lock-in-buffer>
TM	   304.312	+     0.014	          	Enter   #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   314.016	+     9.704	     9.693	Leave   #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   316.569	+     2.553	          	Enter   #<subr git-commit-setup-font-lock-in-buffer>
TM	   316.849	+     0.280	     0.270	Leave   #<subr git-commit-setup-font-lock-in-buffer>
TM	   316.863	+     0.014	          	Enter   #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   326.005	+     9.142	     9.132	Leave   #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   326.220	+     0.215	    22.274	Leave  #<subr normal-mode>
TM	   326.240	+     0.020	          	Enter  #<subr git-commit-setup>
TM	   405.085	+    78.845	    77.140	Eval    #[128 \300\301\302^C#\207 [apply my-call-process-for-bypassing-git-encwrapper #[128 \300\301\302^C#\207 [apply my-procargfix-advice--call-process #<subr call-process> ((depth . 99))] 5 nil] nil] 5 nil]
TM	   409.544	+     4.459	    83.276	Leave  #<subr git-commit-setup>
TM	   409.580	+     0.036	          	Enter  #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   409.598	+     0.018	     0.010	Leave  #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   413.333	+     3.735	          	Enter  #<subr magit-commit-diff>
TM	   418.831	+     5.498	          	Enter   #<subr git-commit-setup-font-lock-in-buffer>
TM	   418.852	+     0.021	     0.014	Leave   #<subr git-commit-setup-font-lock-in-buffer>
TM	   418.864	+     0.012	          	Enter   #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   418.882	+     0.018	     0.012	Leave   #<subr magit-auto-revert-mode-enable-in-buffers>
TM	   543.655	+   124.773	   123.842	Eval    #[128 \300\301\302^C#\207 [apply my-call-process-for-bypassing-git-encwrapper #[128 \300\301\302^C#\207 [apply my-procargfix-advice--call-process #<subr call-process> ((depth . 99))] 5 nil] nil] 5 nil]
TM	   544.376	+     0.721	   131.027	Leave  #<subr magit-commit-diff>
TM	   546.288	+     1.912	   250.112	Leave #<subr server-execute>

546ms! 全く引っかかりが無いとは言えませんが、実用上ほとんど問題ない程度になったと思います。元が7822msでしたから元の6.98%にまで減ったことになります。

もちろん三回目以降も同じような時間になりますし、Magitのバッファを削除して再度magit-statusを実行してから計測すると、一回目の時間になります。キャッシュのクリアも機能しています。

コミットメッセージ以外の高速化

ここまではコミットメッセージを書けるようになるまでの時間を改善してきましたが、それ以外の部分でも改善の余地がありました。

コミットメッセージ以外でも常にキャッシュを有効化する

configやrev-parseは常時キャッシュしても問題ないものがありそうです。

これまでにキャッシュしたのは次のgitコマンドです。

  • config core.commentchar
  • config -z --get-all magit.extension
  • rev-parse --show-toplevel
  • rev-parse --git-dir
  • rev-parse --is-bare-repository

これらのうちいくつかはリフレッシュ時などコミット以外でも実行されます。

そこで my-magit-process-cache-always-mode というグローバルモードを作成しました。これは常時キャッシュを有効にしつつ、比較的安全そうなものだけをキャッシュするモードです。

my-magit-process-cache-commit-msg-modeと同じようにコミットメッセージ編集バッファを立ち上げる間は全てをキャッシュします。

その上でそれ以外の時でも上に挙げたconfigやrev-parseはキャッシュします。

このモードはこれまでに挙げた次の改善を内包します。

gitとは関係ないディレクトリでのmagit-auto-revert-mode

調査用のコードを有効にしていると気がつくのですが、git管理下に無いファイルを単に開いただけでgitを四回呼び出します。

call dir=c:/tmp/ from=
  magit-process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--show-toplevel")
  magit-process-git((t nil) ("rev-parse" "--show-toplevel"))
  magit-git-str("rev-parse" "--show-toplevel")
  magit-rev-parse-safe("--show-toplevel")
  magit-toplevel()
  magit-turn-on-auto-revert-mode-if-desired()
  magit-auto-revert-mode-enable-in-buffers()
  run-hooks(change-major-mode-after-body-hook after-change-major-mode-hook)
  normal-mode(t)
  after-find-file(nil t)
  find-file-noselect-1(#<buffer test.txt> "~/tmp/test.txt" nil nil "~/tmp/test.txt" (552535379283176539 1121764838))
  find-file-noselect("c:/tmp/test.txt" nil nil nil)
  find-file("c:/tmp/test.txt")

call dir=c:/tmp/ from=
  magit-process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--git-dir")
  magit-process-git((t nil) ("rev-parse" "--git-dir"))
  magit-git-str("rev-parse" "--git-dir")
  magit-rev-parse-safe("--git-dir")
  magit-toplevel()
  magit-turn-on-auto-revert-mode-if-desired()
  magit-auto-revert-mode-enable-in-buffers()
  run-hooks(change-major-mode-after-body-hook after-change-major-mode-hook)
  normal-mode(t)
  after-find-file(nil t)
  ...略

call dir=c:/tmp/ from=
  magit-process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--show-toplevel")
  magit-process-git((t nil) ("rev-parse" "--show-toplevel"))
  magit-git-str("rev-parse" "--show-toplevel")
  magit-rev-parse-safe("--show-toplevel")
  magit-toplevel()
  magit-turn-on-auto-revert-mode-if-desired()
  magit-auto-revert-mode-enable-in-buffers()
  run-hooks(after-change-major-mode-hook)
  run-mode-hooks(text-mode-hook)
  text-mode()
  ...略
  set-auto-mode()
  normal-mode(t)
  after-find-file(nil t)
  ...略

call dir=c:/tmp/ from=
  magit-process-file("git-encwrapper" nil (t nil) nil "--no-pager" "--literal-pathspecs" "-c" "core.preloadindex=true" "-c" "log.showSignature=false" "-c" "color.ui=false" "-c" "color.diff=false" "-c" "i18n.logOutputEncoding=UTF-8" "rev-parse" "--git-dir")
  magit-process-git((t nil) ("rev-parse" "--git-dir"))
  magit-git-str("rev-parse" "--git-dir")
  magit-rev-parse-safe("--git-dir")
  magit-toplevel()
  magit-turn-on-auto-revert-mode-if-desired()
  magit-auto-revert-mode-enable-in-buffers()
  run-hooks(after-change-major-mode-hook)
  run-mode-hooks(text-mode-hook)
  text-mode()
  ...略
  set-auto-mode()
  normal-mode(t)
  after-find-file(nil t)
  ...略

change-major-mode-after-body-hook から magit-auto-revert-mode-enable-in-buffers の流れです。また magit-auto-revert-mode か。

これだけで数百msくらいかかるわけです。もう本当に勘弁して欲しい。

ルートまで辿って.gitが無ければ何もしないようにしましょう。vc-git-rootというおあつらえ向きな関数があるのでそれを流用することにします。上のディレクトリに向かって.gitディレクトリを探す関数です。

;; ■magit-auto-revert-modeでvc-git-rootを使う
;; ファイルを開くときに(正確にはメジャーモードが変わるときに) .gitディ
;; レクトリが存在しないときはauto-revert-modeを立ち上げるかどうかのチェッ
;; クを即座に打ち切ります。
;; これによりプロセスの起動回数を削減できます。
;; 警告: もし.gitディレクトリ無しにgit管理下のファイルがある場合は正しく動作しなくなります。
(defun my-magit-turn-on-auto-revert-mode-if-desired-for-use-vc-git-root (original-fun &optional file)
  (if file
      (funcall original-fun file)
    (when (and buffer-file-name
               (vc-git-root buffer-file-name))
      (funcall original-fun file))))

(advice-add #'magit-turn-on-auto-revert-mode-if-desired :around #'my-magit-turn-on-auto-revert-mode-if-desired-for-use-vc-git-root)

gitの管理下なのに.gitディレクトリが存在しないケースはあるのでしょうか。GIT_DIRが指定されている場合? もしあったとしても私はそういったことはしないので問題ありません。

特殊なケースを利用しないのであれば、magit-toplevel自体を差し替えるという方法もあります。

;; ■magit-toplevelを不完全だが高速なものに差し替え
;; magit-toplevelは頻繁に呼び出されるので高速化の効果は大きいです。
;; 欠点: 特殊な形式のリポジトリを一切認識しなくなります。
(defun my-magit-toplevel-fast-but-imperfect (original-fun &optional directory)
  (magit--with-refresh-cache
      (cons (or directory default-directory) 'magit-toplevel)
    (magit--with-safe-default-directory directory
      (save-match-data
        (cond
         ;; Remote
         ((file-remote-p default-directory)
          (funcall original-fun directory))
         ;; Submodule (2022-11-23追記)
         ((string-match "\\`\\(.*/\\)\\.git/modules/\\(.*\\)\\'" default-directory)
          (concat (match-string 1 default-directory)
                  (match-string 2 default-directory)))
         ;; Does not support:
         ;; - environments for git directory (GIT_DIR, GIT_WORK_TREE, etc)
         ;; - bare repository
         ;; - find-file-visit-truename
         (t
          (when-let ((root-dir (vc-git-root default-directory)))
            (magit-expand-git-file-name root-dir))))))))
(advice-add #'magit-toplevel :around #'my-magit-toplevel-fast-but-imperfect)

(2022-11-23追記: サブモジュール下のコミットで正しくdiffが表示されなかったので修正しました。これも割と適当な修正の仕方です)

Magitはベアリポジトリでも使えるんですね。 git rev-parse --is-bare-repository はどうやってベアリポジトリを判別するのでしょうか。とりあえず未対応で。

まとめ

プロセスの起動回数を削減することでコミットログを編集するまでに約8秒かかっていたものが約0.5秒まで短縮できました。

その代わりに細かい制限が増えていますが私の使用状況ではほとんど支障は無い程度です。

MagitがWindowsで遅い原因には次のようなものがあります。

  • Magitの設計がごく短時間でプロセスを起動できるOSを前提にしたものになっていてWindowsがそうではない
  • EmacsやGitにもWindows版には多少のオーバーヘッドがある

開発者は問題を認識しており、様々な対策を講じてきたようです。特にlibgitを使ったアプローチは魅力的です。しかしlibgitを使うことで生じる問題や、何よりこの改善がWindowsユーザーしか喜ばない点でなかなか進まないようです。

いつかはより根本的な対策がなされると思いますが、それまではこのような小手先の改善で回避していく方が現実的かもしれません。

コード

最終的なコードは次の場所に配置してあります。

misohena/my-magit-speedup-for-windows: My setup files for Magit on MS-Windows.

環境

Emacs 28.2 (Windows版公式ビルド)
Windows 10 22H2
Core i7-6700 3.4GHz/H170M-PLUS/MEM16GB/SSD1TB
Magit 20221101.2214 [>= 3.3.0-git]
Git for Windows 2.38.1.windows.1
2022-11-06

win-ssh-agentをMSYS2で使う

長年win-ssh-agentを使っているのですが、ふとMSYS2で動作するのか、また、ビルドできるのか気になったので試してみました。

MSYS2でwin-ssh-agentをビルドする

ビルドするには、おそらく

pacman -S base-devel
pacman -S msys2-devel
pacman -S msys2-runtime-devel

あたりが入っていれば良いのだと思います。色々やった後の環境なので、いつの間にか入っているパッケージで必要なものがまだあるかもしれません。

それらを入れてMSYS環境からmakeしてみたところ、無事ビルドが成功して動作もしました。出来上がったexeはCygwinと同じように専用のDLL(msys-2.0.dll)に依存します。win-ssh-agentはpopenやらwait3やらcygwin_internalやら素のWindowsには無い関数を使用しているので仕方ないところです。全部Win32で書き直せば依存関係を減らせますが、CygwinかMSYS2環境下で動かすのが目的なのでやる必要は無いでしょう。

CygwinとMSYS2の両方で使う

通常Cygwin側でwin-ssh-agentを実行してもMSYS2側のsshでは認識されません(毎回パスフレーズが求められます)。反対にMSYS2側でwin-ssh-agentを実行してもCygwin側のsshでは認識されません。

なぜかというと環境変数に保存されるパスがそれぞれの環境独自のパスになっているからです。例えば次のように。

SSH_ASKPASS=/usr/loca/bin/win-ssh-askpass.exe
SSH_AUTH_SOCK=/tmp/ssh-????????????\agent.????

/usr/tmp がどこにマップされているかは環境(CygwinかMSYS2か)で異なります。

これをc:から始まる通常のフルパスに直すとCygwinからでもMSYS2からでも認識されます。

SSH_ASKPASS=c:\cygwin\usr\local\bin\win-ssh-agent/win-ssh-askpass.exe
SSH_AUTH_SOCK=c:\cygwin\tmp\ssh-????????????\agent.????

MSYS2も元はCygwinということできっと方式は同じなのでしょう。

win-ssh-agentではわざわざWindows標準のパスをCygwin用のパスに変換している場所があります(SSH_ASKPASS設定時)。また、ssh-agentから返ってくるCygwin用のパスを変換せずにSSH_AUTH_SOCKに設定しています。これらの場所で確実にWindows用のフルパスに変換してしまえば、CygwinからでもMSYS2からちゃんと認識してくれるようになります。

具体的には、 misc.h, misc.cpp に conv_path_posix_to_win という関数があるので、それをコピーしてstd::stringを返すバージョン(conv_path_posix_to_win_aとか)を作り、setenvするところ(こことかこことか)で変換してしまえばOKです。ちゃんとやるなら全部ワイド文字列にすべきですが、面倒なのでいいや。

最近の事情

最近はWindows版のOpenSSHだとかWSLだとかもあるので状況はより複雑なようです(see: 混沌を極めるWindowsのssh-agent事情 - Qiita)。幸い私はそれらを使っていないのでまだまだこのままで大丈夫なようです。

最近の悩みと言えばCygwinとMSYS2で同じような物を二つ入れておくのが何だか無駄に思えてきたことです。どちらも数GBくらい容量を食いますからね。昔から(それこそMeadowの頃から)常用しているのはCygwinでMSYS2はたまにしか使っていませんが、GitにせよEmacsにせよUnix由来のソフトウェアのWindows版はMSYS2でビルドすることが多いので、それならMSYS2で統一してしまおうかなと考えています。今回のはそのための布石です。ただ、Emacsの設定からCygwin依存部分を除去するのが案外面倒なので二の足を踏んでいます。不具合を無理矢理直している所もあるので。

2022-11-04 ,

org-modernでタグを正確に右寄せする

org-modernはタグを右寄せせず見出しのすぐ右に並べる(org-tags-column=0)ことを想定していますが、私は右寄せ(org-tags-column=-74)のまま使っています。

そうすると何が困るかというと、タグの位置が不揃いになることです。

修正前:タグの位置が不揃い
図1: 修正前:タグの位置が不揃い

org-modernはタグを少し小さめのフォント(:height 0.9)で表示しますし、コロン(:)の前後に空白を入れるのでどうしても幅が変わってしまいます。

文字を小さくしているので文字数単位での調整では修正できません。ピクセル単位での調整が必要です。

というわけで次のように直しました。(org-modern/org-modern.el at 59b2e3c94756b4e37b2cf7b9f81028c6d4758672 · minad/org-modern より修正)

;; org-modern.el (2022-11-04版より修正)

;;;~略~

(defun org-modern--tag ()
  "Prettify headline tags."
;;;~略~
          (setq colon-beg cbeg colon-end cend)))

      ;; 以下を追加。タグの位置を揃える。
      (my-org-modern-align-tags-right beg end)
)))

(require 'shr)

(defvar my-org-modern-tags-right (* (default-font-width) (- 80 3))) ;;揃えるピクセル位置

(defun my-org-modern-align-tags-right (beg end)
  (let* (;;(beg-px (car (window-text-pixel-size nil (line-beginning-position) beg)))
         (end-px (car (window-text-pixel-size nil (line-beginning-position) end)))
         ;;(width-px (if (<= beg-px end-px) (- end-px beg-px) (+ (- (window-text-width nil t) beg-px) end-px)))
         ;; shr-string-pixel-widthを使う。
         ;; つまり別バッファに移してからwindow-text-pixel-sizeで幅の計測を行う。
         ;; 同じバッファでやるとタグが非表示部分の中にあると幅が0になってしまう。
         (width-px (shr-string-pixel-width (buffer-substring beg end)))
         (tags-right my-org-modern-tags-right))
    (when (and (< end-px tags-right) (> width-px 0))
      ;;(put-text-property (1- beg) beg 'display (list 'space :width (list (if (< end-px tags-right) (- tags-right end-px) 0))))
      ;; align-toを使う。widthだと後からorg-indentでずれてしまう。
      (put-text-property (1- beg) beg 'display (list 'space :align-to (list (- tags-right width-px))))
      )))

つまり、org-modernがタグのfontifyを行った直後にタグのピクセル幅を計算し、タグの直前にある空白文字をdisplayプロパティによる空白に置き換えます。そのdisplayプロパティには (space :align-to 揃える位置 - タグ幅) を指定します。

結果は次の通りピッタリ右端が揃いました。

修正後:タグの位置がピッタリ揃っている
図2: 修正後:タグの位置がピッタリ揃っている

リージョンで囲っている部分はdisplayプロパティが適用された空白です。

キモは shr-string-pixel-width 関数です。テキストのピクセルサイズを求めるには window-text-pixel-size 関数を使わなければなりませんが、この関数はバッファとウィンドウを要求します。 shr-string-pixel-width は一時的なバッファを一時的に現在のウィンドウに関連付けて window-text-pixel-size を呼び出してくれます。そんなことをして即時に正しく計算できるのか(レイアウト処理を遅延していないのか)、パフォーマンスは大丈夫なのか心配になりましたが、今のところ問題は見つかっていません。window-text-pixel-sizeのソースコードを読んでおいた方が良いのかもしれません。

検索するとEmacs 25.1で問題があったのを修正した記録があります。

bug#24950: 25.1; shr-string-pixel-width cannot be called from a dedicate

今回の修正は強制的にタグを右端に揃えるのでorg-tags-columnがなんであろうとお構いなしです。環境によって最適なウィンドウ幅は変わります。タグを何桁目で揃えるのか悩み所でしたが、org-tags-column=0にして右寄せは完全にビューの役割にするのも良いかもしれません。

2022-11-03 ,

Org言語のソースコードブロックをエクスポートしたときにorg-modernが影響してしまう問題

久しぶりにOrgの書き方を説明する記事を書いた時に気がついたのですが、エクスポート結果がorg-modernが適用された状態になっていました。

例えば次のOrg文書をエクスポートしたときに……

org-modeでは色々なものを次のように書きます。

#+begin_src org
,* table

| 項目 | 金額 |
|------+------|
| あれ | 1000 |
| それ | 2000 |

,* list

- [ ] item1
- [ ] item2
- [ ] item3

,* link

こんにちは。 [[https://www.google.com/][Google]] 

↑これは以前直した所。
素のorg-modeでも単に下線でGoogleとだけ表示されてしまい
リンクの書き方が分からない。

#+end_src

次のようになっていました。

org-modernの影響を受けたHTMLエクスポート結果
図1: org-modernの影響を受けたHTMLエクスポート結果

これじゃOrgの書き方の説明になりません。もちろん正しくは次のようになっていなければなりません。

通常のHTMLエクスポート結果
図2: 通常のHTMLエクスポート結果

これは全てのバッファでorg-modernを有効にするために、次のように設定したからです。

(add-hook 'org-mode-hook 'org-modern-mode)

org-modeがHTMLでエクスポートするとき、ソースコードブロックの中身に色づけを行います。その処理はorg-html-fontify-code関数にあるのですが、その仕組みは、一時バッファを作成して言語用のモードを立ち上げ、コードを挿入し、font-lock-ensureでバッファの色づけを行い、htmlizeを使ってテキストプロパティを元にHTMLに変換します。

なので、Emacs上で編集しているときの見た目をHTML上で再現してしまうわけです。なんてこった!

同種の現象は以前リンクの書き方でもありました。

org言語のソースブロックをエクスポートしたときにリンクをそのまま出力する

なので今回も同じようなアプローチを取ります。

次の部分はリンクの問題と共用です。

(defvar-local my-org-in-html-fontify-code nil)

(defun my-org-html-fontify-code-advice (old-func &rest rest)
  (cl-letf (((default-value 'org-link-descriptive) nil) ;;リンクを展開表示する
            ((default-value 'my-org-in-html-fontify-code) t)) ;;org-html-fontify-codeの中にいることを示す
    (apply old-func rest)))

(advice-add 'org-html-fontify-code :around 'my-org-html-fontify-code-advice)

その上で org-modern-mode を起動する部分を次のようにします。

(defun my-org-modern-enable ()
  ;; エクスポート中(ソースコードブロックのfontify中)はorg-modern-modeを起動しない。
  (unless my-org-in-html-fontify-code
    (org-modern-mode)))

(add-hook 'org-mode-hook #'my-org-modern-enable)

つまり、色づけ処理に入るときにフラグを立てて、モードを立ち上げるときにそれを確認するわけです。

はい、いつも通り無理矢理ですね。

そもそも org-modern を常用している人って世界中にどれくらいいるんでしょうね。重くなるし編集しづらくなるし色々問題も起きるのでハッキリ言っておすすめはしません(笑)。

2022-11-03 ,

org-modeの表(テーブル)で集計する方法(orgtbl-aggregateの使い方)

org-modeのスプレッドシート(表計算)機能は便利ですが、データをグループ化して集計する機能が欠けています。

Excelであればピボットテーブルや小計機能を使えば超簡単ですが、org-modeでやろうとするとどうしたものか困ってしまいます。ソースコードブロック(babel)で何とかする方法もありますが、ここでは orgtbl-aggregate という外部パッケージを使う方法を説明します。

orgtbl-aggregateの入手先

orgtbl-aggregateは次の場所で開発されているようです。

tbanel/orgaggregate: Aggregates tables in Org mode

MELPA等でも配布されているようです。

一点だけ注意。日本語(全角文字)を使用すると表が乱れる不具合がありました(2022-11-03現在)。例によって文字列に対してstring-width関数を使用していないことが原因です。 (length cellnp)(length cell) と書かれている部分を (string-width cellnp)(string-width cell) に変更したら解消しました。

基本的な使い方

適当な表

適当な表を用意しました。

#+NAME: 20221103-payments
| 大分類 | 小分類 | 支払先       | 目的           |  金額 |
|--------+--------+--------------+----------------+-------|
| 交通費 | 鉄道   | JR東日本     | 立川-甲府      |  1690 |
| 交通費 | バス   | 山梨交通     | 甲府駅-広河原  |  1990 |
| 交通費 | バス   | 山梨交通     | 利用者協力金   |   300 |
| 宿泊費 | 幕営   | 白根御池小屋 | テント1人1泊   |  1000 |
| 食費   | 飲料   | 白根御池小屋 | 麦茶           |   500 |
| 宿泊費 | 幕営   | 北岳肩の小屋 | テント1人1泊   |  1000 |
| 食費   | 飲料   | 北岳肩の小屋 | なっちゃん     |   600 |
| 食費   | 飲料   | 北岳肩の小屋 | 水1L           |   200 |
| 食費   | 菓子   | 白根御池小屋 | 信玄アイス     |   800 |
| 交通費 | バス   | 山梨交通     | 広河原-甲府駅  |  1990 |
| 交通費 | バス   | 山梨交通     | 利用者協力金   |   300 |
| 交通費 | 鉄道   | JR東日本     | 甲府-立川      |  1690 |
|--------+--------+--------------+----------------+-------|
|        |        |              |                | 12060 |
#+TBLFM: @>$5=vsum(@I..@II)

20221103-paymentsという名前が付いたorg-modeの表です。これは6月末に北岳へ行った時に支払ったお金の一覧です。

右下に合計金額を書き加えてあります。これが少々面倒を引き起こします。

基本

大まかにどんなものにどのくらいの費用がかかったのでしょうか。

何も考えずに最低限の指定をしてみます。 #+BEGIN:#+END:C-c C-x x で挿入できます。aggregate、テーブル名、集計する列などを入力します。その後で C-c C-c を押すと集計を実行します。

#+BEGIN: aggregate :table "20221103-payments" :cols "大分類 vsum(金額)"
| 大分類 | vsum(金額) |
|--------+------------|
| 交通費 |       7960 |
| 宿泊費 |       2000 |
| 食費   |       2100 |
|        |      12060 |
#+END:

概ね良いのですが、合計の部分(12060)が一緒くたになっているのが気になります。元の表から合計の行を消しても良いのですが、それは残したいものとしましょう。計算を水平線(hline)で囲まれた範囲に限定できないものでしょうか。

隠れた列「hline」

実は hline という列が指定できます。元の表には無い列ですが、何個目の水平線の後かを表します(一つ目の水平線は見出しとの区切りのため数えません)。

#+BEGIN: aggregate :table "20221103-payments" :cols "hline 大分類 vsum(金額)"
| hline | 大分類 | vsum(金額) |
|-------+--------+------------|
|     0 | 交通費 |       7960 |
|     0 | 宿泊費 |       2000 |
|     0 | 食費   |       2100 |
|     1 |        |      12060 |
#+END:

条件抽出

hlineが0の行だけを抽出すれば合計部分を排除できます。それには :cond (equal hline "0") を指定します。 "0" は文字列です。

#+BEGIN: aggregate :table "20221103-payments" :cols "大分類 vsum(金額)" :cond (equal hline "0")
| 大分類 | vsum(金額) |
|--------+------------|
| 交通費 |       7960 |
| 宿泊費 |       2000 |
| 食費   |       2100 |
#+END:

列名変更

列名の vsum(金額) というのはちょっと式っぽいので、単純に にしてみます。 ;'計' を指定します。列名が変わります。

#+BEGIN: aggregate :table "20221103-payments" :cols "大分類 vsum(金額);'計'" :cond (equal hline "0")
| 大分類 |   計 |
|--------+------|
| 交通費 | 7960 |
| 宿泊費 | 2000 |
| 食費   | 2100 |
#+END:

ソート

金額が大きい順にソートしてみます。 ;^N を指定すると数値降順にソートされます(小文字で昇順。a/Aアルファベット順、n/N数値順、t/T時間順)。

#+BEGIN: aggregate :table "20221103-payments" :cols "大分類 vsum(金額);'計';^N" :cond (equal hline "0")
| 大分類 |   計 |
|--------+------|
| 交通費 | 7960 |
| 食費   | 2100 |
| 宿泊費 | 2000 |
#+END:

本記事の趣旨とは関係ない余談ですが、やはり交通費が一番かかります。食費には自宅からの持ち込み分は含まれていません。宿泊費が安いのはひとえにテント泊だからですが、装備を用意するのに多額の費用がかかります(山小屋に泊まるのと比べれば十分元は取れます)。

追加処理

最後に合計を付け加えてみます。ちょっと面倒です。

#+BEGIN: aggregate :table "20221103-payments" :cols "大分類 vsum(金額);'計';^N" :cond (equal hline "0") :post (lambda (table) `(,@table hline ("合計" ,(cl-loop for line in table sum (if (eq line 'hline) 0 (string-to-number (nth 1 line)))))))
| 大分類 |    計 |
|--------+-------|
| 交通費 |  7960 |
| 食費   |  2100 |
| 宿泊費 |  2000 |
|--------+-------|
| 合計   | 12060 |
#+END:

:post の後の部分は整形すると次のようになっています。

(lambda (table)
  `(,@table
    hline
    ("合計" ,(cl-loop for line in table
                      sum (if (eq line 'hline)
                              0
                            (string-to-number (nth 1 line)))))))

tableは行のリストで、その要素は列のリストかシンボルhlineです。

このコードは末尾にhlineと合計の行を付け加えます。

単純に上2行(見出しとhline)を無視するだけであればcl-loop部分は次のようにしても良かったかもしれません。

(cl-loop for line in (cddr table)
         sum (string-to-number (nth 1 line)))

結果の埋め込み

元の表もそうですが、合計が入るとデータとしては少々扱いづらい表になってしまいます。合計は表の中ではなく別の場所に記載するというのも手でしょう。

インラインソースコードブロックを使えば文書中に結果を埋め込むことも出来ます。

合計: src_elisp[:var tbl=20221103-payments[0:-2,-1] :colnames yes :hlines no :eval no-export ]{(apply #'+ tbl)} {{{results(=12060=)}}}

わざわざ計算しなくても表の右下から持ってきたいだけなら次のようにしても大丈夫です。(集計するブロックに名前を付けてそれを参照しても大丈夫です)

合計: src_elisp[:var tbl=20221103-payments[-1,-1] :eval no-export]{tbl} {{{results(=12060=)}}}

ちなみに[-1,-1]の部分は参照先の一部を取り出すための表記です。詳しくは次の辺りをご覧下さい。

別の観点

もちろん集計するキーはどの列でも構いません。

支払先毎の金額を出してみます。

#+BEGIN: aggregate :table "20221103-payments" :cols "支払先 vsum(金額);^N" :cond (equal hline "0")
| 支払先       | vsum(金額) |
|--------------+------------|
| 山梨交通     |       4580 |
| JR東日本     |       3380 |
| 白根御池小屋 |       2300 |
| 北岳肩の小屋 |       1800 |
#+END:

hlineの出力

合計の前に水平線を出すには、 :hline を指定するという手もあります。

#+BEGIN: aggregate :table "20221103-payments" :cols "hline;^n 大分類 vsum(金額);^N" :hline 1
| hline | 大分類 | vsum(金額) |
|-------+--------+------------|
|     0 | 交通費 |       7960 |
|     0 | 食費   |       2100 |
|     0 | 宿泊費 |       2000 |
|-------+--------+------------|
|     1 |        |      12060 |
#+END:

単純に金額だけで(降順)ソートすると合計の12060が先頭に来てしまいます。「hline」列を金額より前にソートすることで合計が下に居続けます。

その上で :hline 1 を指定すると、1列目(hline)の変わり目に水平線が入ります。

hlineの列は邪魔なので ;<> を指定することで非表示にできます。

#+BEGIN: aggregate :table "20221103-payments" :cols "hline;<>;^n 大分類 vsum(金額);^N" :hline 1
| 大分類 | vsum(金額) |
|--------+------------|
| 交通費 |       7960 |
| 食費   |       2100 |
| 宿泊費 |       2000 |
|--------+------------|
|        |      12060 |
#+END:

:hlineの後の数字は列数です。左から指定された列数の列が同じ行をグループ化し、その間に水平線を挿入します。値がソートされていないと正しく挿入できない、と思います。

#+BEGIN: aggregate :table "20221103-payments" :cols "大分類;^a 支払先;^a 小分類;^a vsum(金額);^N" :cond (equal hline "0") :hline 1
| 大分類 | 支払先       | 小分類 | vsum(金額) |
|--------+--------------+--------+------------|
| 交通費 | JR東日本     | 鉄道   |       3380 |
| 交通費 | 山梨交通     | バス   |       4580 |
|--------+--------------+--------+------------|
| 宿泊費 | 北岳肩の小屋 | 幕営   |       1000 |
| 宿泊費 | 白根御池小屋 | 幕営   |       1000 |
|--------+--------------+--------+------------|
| 食費   | 北岳肩の小屋 | 飲料   |        800 |
| 食費   | 白根御池小屋 | 菓子   |        800 |
| 食費   | 白根御池小屋 | 飲料   |        500 |
#+END:
#+BEGIN: aggregate :table "20221103-payments" :cols "大分類;^a 支払先;^a 小分類;^a vsum(金額);^N" :cond (equal hline "0") :hline 2
| 大分類 | 支払先       | 小分類 | vsum(金額) |
|--------+--------------+--------+------------|
| 交通費 | JR東日本     | 鉄道   |       3380 |
|--------+--------------+--------+------------|
| 交通費 | 山梨交通     | バス   |       4580 |
|--------+--------------+--------+------------|
| 宿泊費 | 北岳肩の小屋 | 幕営   |       1000 |
|--------+--------------+--------+------------|
| 宿泊費 | 白根御池小屋 | 幕営   |       1000 |
|--------+--------------+--------+------------|
| 食費   | 北岳肩の小屋 | 飲料   |        800 |
|--------+--------------+--------+------------|
| 食費   | 白根御池小屋 | 菓子   |        800 |
| 食費   | 白根御池小屋 | 飲料   |        500 |
#+END:

orgtbl-aggregateを使わない方法(ソースコードブロックで集計する)

orgtbl-aggregate を使わないのであればソースコードブロックを使うのが普通だと思います。環境に依存せずに使えるのはEmacs Lispだけです。

#+begin_src elisp :var tbl=20221103-payments :colnames no :hlines yes
(let ((key-col 0)
      (value-col 4)
      (start-row 2)
      body)
  ;; 集計
  (cl-loop for line in (nthcdr start-row tbl)
           until (eq line 'hline)
           for key = (nth key-col line)
           for value = (nth value-col line)
           do (cl-incf (alist-get key body 0 nil #'equal) value))
  ;; ドット対をリストに変換
  (setq body (mapcar (lambda (x) (list (car x) (cdr x))) body))
  ;; ソート
  (setq body (sort body (lambda (a b) (> (cadr a) (cadr b) ))))

  `(;; 見出し
    (,(nth key-col (car tbl)) ,(nth value-col (car tbl)))
    ;; 水平線
    hline
    ;; データ本体
    ,@body
    ;; 水平線
    hline
    ;; 合計
    ("合計" ,(cl-loop for (key value) in body sum value))
  ))
#+end_src

#+RESULTS:
| 大分類 |  金額 |
|--------+-------|
| 交通費 |  7960 |
| 食費   |  2100 |
| 宿泊費 |  2000 |
|--------+-------|
| 合計   | 12060 |

あらかじめ関数にでもしておかない限り面倒くさくて仕方がありません。Rなど他の言語を使えば多少はマシかもしれませんが。

自分用の集計用関数を定義しておけば良いのでしょうが汎用性を持たせるのには手間がかかります。それなら orgtbl-aggregate のダイナミックブロックで必要なことが十分手軽に出来ます。

2022-10-30 ,

Org Agendaの長い見出しにインデントを適用する

org-modeでAgenda Viewを見ていたときに、長い見出しが折り返されているのが見づらいことに気がついた。(私は普段org-startup-truncatedをnilにして使っているのでそうなるのだと思う。表の部分にはphscrollを使用している)

Org Agendaで長い見出しが折り返されている様子
図1: Org Agendaで長い見出しが折り返されている様子

折り返し後のテキストを字下げする機能はEmacsに既にあって、wrap-prefixテキストプロパティを使えば良い。

org-agenda.elのorg-agenda-format-item関数を次のように修正する。

        ;; Evaluate the compiled format
-       (setq rtn (concat (eval formatter t) txt))
+       (let ((prefix (eval formatter t)))
+         (setq rtn (concat prefix txt))
  
        ;; And finally add the text properties
-       (remove-text-properties 0 (length rtn) '(line-prefix t wrap-prefix t) rtn)
+         (remove-text-properties 0 (length rtn) '(line-prefix t wrap-prefix t) rtn)
+         (put-text-property 0 (length rtn) 'wrap-prefix (make-string (length prefix) ? ) rtn))
        (org-add-props rtn nil
          'org-category category
            'tags tags
            'org-priority-highest org-priority-highest

すると次のようにスッキリした見た目になった。

Org Agendaの長い見出しにインデントを適用した様子
図2: Org Agendaの長い見出しにインデントを適用した様子

関数を直接修正するとorg-modeのバージョンアップによって壊れる可能性が高いので、せめてadvice-addを使うなどして動作を変えたいところ。なので次のようにしてみた。

(defvar my-org-agenda-format-item-prefix "") ;;formatterが返した値を取っておくための変数。

(defun my-org-agenda-format-item (orig-fun &rest args)
  ;; 元のorg-agenda-format-itemを呼び出す前に
  ;; org-prefix-format-compiledを一時的に書き替える。
  (let* ((org-prefix-format-compiled
          (list
           (car org-prefix-format-compiled)
           ;; formatterを書き替えてしまう。
           ;; 結果を my-org-agenda-format-item-prefix に書き込むように。
           (list 'setq 'my-org-agenda-format-item-prefix (cadr org-prefix-format-compiled))))
         ;; 元のorg-agenda-format-itemを呼び出す。
         (rv (apply orig-fun args)))
    ;; 戻り値にwrap-prefixテキストプロパティを追加する。
    ;; インデントの深さはformatterが返した文字列(prefix)の長さとする。
    (put-text-property 0 (length rv) 'wrap-prefix (make-string (length my-org-agenda-format-item-prefix) ? ) rv)
    rv))

(advice-add #'org-agenda-format-item :around #'my-org-agenda-format-item)

もちろんOrg Agendaバッファのtruncate-linesをtにするという手もある。はみ出した見出しはスクロールしなければ見えなくなるが。

2022-09-08

Emacsが子プロセスを起動するときのコマンドライン引数を直す(Windows版)

Windows版のEmacsで子プロセスを起動するときに正しいコマンドライン引数が子プロセスに伝わらない(場合がある)不具合について調査、改善してみました。

この不具合は様々な現象を引き起こします。例えばgrepに指定した文字列が検索されないといった形で問題が現れます。

原因

調べたところ三つの原因が見つかりました。

  • CreateProcessA(ANSI版、非UNICODE版)を使っている
  • コマンドライン引数の文字エンコーディングが間違っている場合がある
  • Emacsの引数のエスケープ処理に問題がある

一つ目は、Emacsが子プロセスを起動するのにWin32APIのCreateProcessAを使っていることです。CreateProcessAはANSI文字列版(MBCS版)であり、CreateProcessWというWide文字列版(UNICODE版)ではありません。なのでどう逆立ちしても(CP65001でも使わない限り)UNICODEは使用できません。現在のコードページに沿った文字エンコーディング(日本の場合はCP932、ほぼShift_JIS)で表現できる範囲の文字しか引数として使用できません。

二つ目は、Emacsの設定によってはCreateProcessAにUTF-8等の間違った文字エンコーディングの文字列が渡されてしまうことです。ただ、私は普段CP932をデフォルトにしているのでこの原因で問題が起きたことはありません。

三つ目は、Emacsのコマンドライン引数処理に複数の問題があることです。マルチバイト文字を考慮していないため、2バイト目が5Cである文字(いわゆるダメ文字)に反応して余計な\(バックスラッシュ)を挿入してしまいます。また、Cygwin向けのエスケープ処理にも不十分なところがあります。

この辺りの処理はEmacsのソースコードの emacs/src/w32proc.c にあります。

emacs/w32proc.c at 5a223c7f2ef4c31abbd46367b6ea83cd19d30aa7 · emacs-mirror/emacs

修正方法

一つ目の問題を直そうと思ったらEmacsのソースコードを修正してCreateProcessWを使うようにすべきでしょう。自分でビルドせず配布されているバイナリを使いたいのであれば諦めるよりありません。無理矢理何とかする方法も思いつかなくはないですが(他のプログラム、DLLを経由するとか、@でファイルの中身を引数に挿入する仕組みを使うとか)、止めておきます。

二つ目の問題は、事前に文字列をCP932に変換することで回避できます。

三つ目の問題は、 w32-quote-process-args をnilにしてEmacsの問題のある引数処理を抑制しつつ自分で引数を処理することで回避できます。

一つ目はともかく、二つ目と三つ目はEmacs Lispのレベルで何とかできそうです。

Webを探したところ、次のようなページが見つかりました。

UTF-8 をベースとして利用するための設定 - NTEmacs @ ウィキ - atwiki(アットウィキ)

「UTF-8をベースとして」ということですが、CP932のままで使用しようとした場合も結局は同じ問題が発生します(特にダメ文字問題)。

というわけで、そのページの下の方で紹介されているコードを試したところ、概ね問題が解消しました。

「概ね」と書いたのは完全には解消していなかったからです。

そのコードを詳しく見てみると、肝心のコマンドライン引数処理の部分が非常にシンプルな正規表現置換でした。「はて、本当にそれで良いのかな?」と思って色々調べたところ少しだけ改善の余地がありました。

その辺りとともに全体的に自分なりに整理して沢山コメントを入れたのが次のコードです。

;;;; 子プロセスに渡すコマンドライン引数を修正する(NTEmacs用 28.1で確認)

;; Windows版のEmacsで子プロセスを起動するときのコマンドライン引数に関する
;; 二つの問題を修正する。
;;
;; - 文字エンコーディングの問題
;; - エスケープ処理(quoting)の問題

;; Emacsが何をしているのかは emacs/src/w32proc.c の sys_spawnve 関数を
;; 見ること。

;;;;; Cygwinプログラム判定

;; 引数の変換処理方式はCygwinのプログラムかどうかで変える必要がある。
;; Cygwinのプログラムかどうかはexeがcygwin1.dllを必要としているかで判別する。

(defun my-procargfix-cygwin-program-p-no-cache (filename)
  "FILENAMEがCygwinのプログラムならtを返します。(キャッシュ不使用)"
  ;; cygwin1.dllを使っているかで判定する。
  ;; emacs/src/w32proc.c の w32_executable_type も似たような事をしている。
  (with-temp-buffer
    (let ((w32-quote-process-args nil)) ;;lddのCygwin判定(再帰)を抑制する。
      (when (eq (call-process "ldd" nil t nil (concat "\"" filename "\""))
                0)
        (goto-char (point-min))
        (number-or-marker-p
         (re-search-forward "cygwin[0-9]+\.dll" nil t))))))

(defvar my-procargfix-fullpath-cache nil) ;;2022-11-18追加
(defvar my-procargfix-ldd-cache nil)

(defun my-procargfix-cygwin-program-p (filename)
  "FILENAMEがCygwinのプログラムならtを返します。(キャッシュ使用)"
  (let ((abs-fname (and (stringp filename)
                        ;;(executable-find filename) ;;9ms! Very Slow!! ;;2022-11-18削除
                        (or (cdr (assoc filename my-procargfix-fullpath-cache))
                            (cdar (push (cons filename (executable-find filename)) my-procargfix-fullpath-cache))) ;;2022-11-18追加
                        )))
    (when abs-fname
      (or
       (cdr (assoc abs-fname my-procargfix-ldd-cache))
       (let ((cyg-p (my-procargfix-cygwin-program-p-no-cache abs-fname)))
         (push (cons abs-fname cyg-p) my-procargfix-ldd-cache)
         cyg-p)))))

;;2022-11-18追記: executable-findは滅茶苦茶遅いのでキャッシュするようにした。しかしファイルを移動したときはキャッシュのクリアが必要になってしまった。
(defun my-procargfix-clear-cache ()
  (interactive)
  (setq my-procargfix-fullpath-cache nil)
  (setq my-procargfix-ldd-cache nil)) ;;2022-11-18追加


;;;;; 引数の変換処理

;; CreateProcessにコマンドライン引数を引き渡すとき、全ての引数を一つの
;; 文字列に結合しなければならない。
;; そのために各引数を二重引用符で囲み範囲を明確にする必要がある。
;; 特殊な意味に用いられる文字はエスケープしなければならない。
;; また、CreateProcessAを使用しているので確実にCP932(日本であれば)
;; でエンコードする必要がある。

(defun my-procargfix-quote-for-cygwin (arg)
  "Cygwinプログラムへの引数ARGを二重引用符で囲みます。"

  ;; Cygwinが渡された引数をどのように展開するかは次のソースを参照すること。
  ;; https://github.com/mirror/newlib-cygwin/blob/master/winsup/cygwin/dcrt0.cc

  ;; 基本的には \ と " をエスケープする。
  ;;  \ => \\
  ;;  " => \"
  (cond
   ;; ただし変換後(囲った後)が "\\server\..." の形式になると
   ;; Cygwin側でエスケープシーケンスの処理が抑制されてしまう。
   ;; 例えばgrepで \sXXX\s と書くと変換後の "\\sXXX\\s" は
   ;; この形式にマッチしてしまう。
   ;; こうなるとCygwin側に渡したときに元の文字列に戻らない。
   ;; なので、変換後の先頭が\二文字になるのを避ける。
   ;; 変換前の先頭に\が一文字ならば、それはエスケープしないようにする。
   ;; 変換後が "\sXXX\\s" ならば \sXXX\s に戻る。
   ((and (>= (length arg) 2)
         (= (elt arg 0) ?\\)
         (/= (elt arg 1) ?\\)
         (/= (elt arg 1) ?\")) ;;is_dos_pathの後半部分に相当
    (concat "\""
            (substring arg 0 2)
            ;; 最初の2文字より後は通常通りエスケープする。
            (replace-regexp-in-string "[\\\\\"]" "\\\\\\&" arg t nil nil 2)
            "\""))
   ;; また、同様に "C:..." の形式でも
   ;; Cygwin側でエスケープシーケンスの処理が抑制されてしまう。
   ;; 例えばgrepで A:\sXXX\s と書くと変換後の "A:\\sXXX\\s" は
   ;; この形式にマッチしてしまう。
   ;; 先頭のアルファベットを二重引用符の外に出すことで回避する。
   ;; 変換後が A":\\sXXX\\s" ならば A:\sXXX\s に戻る。
   ((and (>= (length arg) 2)
         (or (<= ?A (elt arg 0) ?Z)
             (<= ?a (elt arg 0) ?z))
         (= (elt arg 1) ?:)) ;;isdriveに相当
    (concat (substring arg 0 1)
            "\""
            ;; 最初の1文字より後は通常通りエスケープする。
            (replace-regexp-in-string "[\\\\\"]" "\\\\\\&" arg t nil nil 1)
            "\""))
   ;; 通常のケース。
   ;;  \ => \\
   ;;  " => \"
   (t
    (concat "\""
            (replace-regexp-in-string "[\\\\\"]" "\\\\\\&" arg t)
            "\"")))
  ;; 注意: CYGWIN=noglobの場合はサポートしない。
  ;; noglobが指定されると、単に二重引用符の間がそのまま出力されるようになる。
  ;; その時二重引用符は強制的に消される(quoted関数、winshell=0時の動作)。
  ;; 二重引用符の中に""や\"を書いても特別扱いされない。
  ;; "ABC""DEF" => ABCDEF
  ;; "ABC\"DEF" => ABC\DEF
  ;; こうなると二重引用符を再現するのはどうやっても不可能となる。
  )

(defun my-procargfix-quote-for-windows (arg)
  "通常のWindowsプログラムへの引数ARGを二重引用符で囲みます。"
  ;; 通常のWindowsプログラムがコマンドライン引数をどのように展開するかは
  ;; 次のページを参照すること。
  ;; https://docs.microsoft.com/ja-jp/cpp/c-language/parsing-c-command-line-arguments?view=msvc-170

  ;; 二重引用符で囲った上で、
  ;; 0個以上の\の後に"が来るケースだけ処理すれば十分なはず。
  ;; \{0..n個}" => \{n*2個}\"
  (concat "\""
          (replace-regexp-in-string "\\(\\\\*\\)\"" "\\1\\1\\\\\"" arg)
          "\""))

(defun my-procargfix-convert-prog-args (prog-name prog-args)
  "コマンドPROG-NAMEに引き渡す引数リストPROG-ARGSを変換します。"
  ;; 独自のエスケープ処理をする。
  (setq prog-args
        ;;この中からcall-processが呼ばれる場合があることに注意
        (mapcar (if (my-procargfix-cygwin-program-p prog-name)
                    #'my-procargfix-quote-for-cygwin
                  #'my-procargfix-quote-for-windows)
                prog-args))

  ;; 確実にCP932にする。
  ;; CreateProcessA(ASCII版)に引き渡すコマンドライン引数のエンコーディングは
  ;; 現在のコードページのものでなければならない。
  ;; 最終的にUTF-16に変換されてサブプロセスに渡されるので、
  ;; どのみち自由なバイト列は指定できない。
  (setq prog-args
        (mapcar (lambda (arg)
                  (if (multibyte-string-p arg)
                      (encode-coding-string arg 'cp932)
                    arg))
                prog-args))
  prog-args)

;;;;; 子プロセス起動関数の書き替え

;; call-process、call-process-region、start-processにadviceを仕掛ける。
;; コマンドライン引数部分を事前に変換する。

(defun my-procargfix-apply (orig-fun fun-args prog-pos args-pos)
  "子プロセスを呼び出す関数をコマンド引数部分を修正して呼び出します。

呼び出す関数はORIG-FUN、その関数に引き渡す引数はFUN-ARGS、プログ
ラム名はFUN-ARGSのPROG-POS番目、コマンド引数部分はFUN-ARGSの
ARGS-POS番目以降です。"
  ;; 関数引数リスト(fun-args)のコマンド引数部分(args-pos以降)を加工する。
  ;; すでにw32-quote-process-argsがnilのときは余計なことはしない。
  (when w32-quote-process-args
    (setf (nthcdr args-pos fun-args)
          (my-procargfix-convert-prog-args
           (nth prog-pos fun-args)
           (nthcdr args-pos fun-args))))

  ;; (2023-05-08追記: 空白を含む実行ファイル(Program Files)を起動したときに引数列がおかしくなる問題に対処した)
  ;; 実行ファイルパスを加工する。
  ;; w32-quote-process-argsをnilにすると実行ファイルパスが二重引用符で
  ;; 囲まれなくなる。そうすると空白を含む実行ファイルパスが正しく呼び
  ;; 出し先のargv[0]に設定されなくなる。
  ;; w32-quote-process-argsをnilにする以上どうしようも無いので、
  ;; 空白文字を含む場合はショートファイル名にして回避する。
  ;; ただし、exeやbatが省略された場合はうまく行かないかもしれない。
  (when w32-quote-process-args
    (let ((prog-name (nth prog-pos fun-args)))
      (when (seq-contains-p prog-name ?  #'eq)
        (setf (nth prog-pos fun-args)
              (or (w32-short-file-name prog-name) prog-name)))))

  ;; Emacsのエスケープ処理を抑制して元の関数を呼び出す。
  ;;(message "args=%s" fun-args)
  (let ((w32-quote-process-args nil))
    (apply orig-fun fun-args)))

(defmacro my-procargfix-add-advice (target-func prog-pos args-pos)
  (let ((ad-func
         (intern (format "my-procargfix-advice--%s" target-func))))
    `(progn
       (defun ,ad-func (orig-fun &rest fun-args)
         (my-procargfix-apply orig-fun fun-args ,prog-pos ,args-pos))
       (advice-add (quote ,target-func)
                   :around
                   (quote ,ad-func)
                   '((depth . 99))))))

(my-procargfix-add-advice call-process        0 4)
(my-procargfix-add-advice call-process-region 2 6)
(my-procargfix-add-advice start-process       2 3)
;;@todo make-processには対応していない。

テスト:

// コマンドライン引数をそのまま表示するだけのプログラム。
// echoargs-cyg.exe : Cygwinのg++でビルドした物。
// echoargs-vc.exe : VC++でビルドした物。
#include <iostream>

int main(int argc, char *argv[])
{
    for(int i = 0; i < argc; ++i){
        std::cout << i << ":" << argv[i] << std::endl;
    }
}
(defun my-procargfix-test-exec (program arg)
  "PROGRAMをコマンドライン引数としてARGを与えて起動する。表示された引数文字列を回収してリストで返す。"
  (let (;;(coding-system-for-read 'utf-8-dos)
        (coding-system-for-read 'cp932-dos)
        (buffer (get-buffer-create "*Output*")))
    (with-current-buffer buffer
      (delete-region (point-min) (point-max))
      (call-process (expand-file-name program) nil buffer t arg)
      (goto-char (point-min))
      (cl-loop while (re-search-forward "^[0-9]+:\\(.*\\)$" nil t)
               collect (match-string 1)))))

(defun my-procargfix-test-exec-exam (program arg)
  (equal (cdr (my-procargfix-test-exec program arg))
         (list arg)))

;; 実行して元に戻るかを確認する。
(let ((test-cases
       '("abc"
         "Program Files"
         "abc\"\" \\\\\\\""
         "abc\"def\"\"ghi\"\"\"jkl\"\"\"\"mno"
         "abc\\def\\\\ghi\\\\\\jkl\\\\\\\\mno"
         "abc'def''ghi'''jkl''''mno"
         ;; 先頭がネットワークパスになりかねないケース
         "\\sABC\\s"
         "\\sABC"
         "\\\"sABC"
         "\\\\sABC"
         ;; ドライブレターで始まるケース
         "c:\\sABC\\s\"DEF\""
         ;; 
         ""
         ;; ダメ文字
         "表示"
         "\\表\\示"
         ;; GLOBっぽい文字列
         "*.el"
         "~/"
         ))
      (ok 0)
      (ng 0))
  (dolist (program '("echoargs-vc.exe" "echoargs-cyg.exe"))
    (dolist (arg test-cases)
      (if (my-exec-test program arg)
          (cl-incf ok)
        (cl-incf ng)
        (message "Fail %s" arg))))
  (message "OK:%s, NG:%s" ok ng))

最後に

Emacsからgrepを使ったときに問題が起きることがあるのは昔から気がついていました。ただ、色々と工夫するとたいていの場合問題を回避できてしまうのであまり深く追求することはありませんでした。

そもそも素のgrepはCP932に対応していないので普段あまり使っていません。日本で使われている複数の文字エンコーディングに対応したgrepとして昔はlv(をlgrepにリネームした物。Emacsのlgrepコマンドと紛らわしいので以下単にlv)を使用していました。しかしlvはGNU grepよりも機能が劣るため、grepの設定(grep-command等)を流用するパッケージでたまに問題が起きました(grepにあるオプションが存在しない等)。そこで最近はlvをエンコーディング変換にのみ使用してgrepとパイプで繋げるスクリプト(lvgrep)を作成して使っていました。そうこうするうちにCounselでripgrepを使うようになりました。なので外部のgrepコマンドはripgrepで統一してしまおうとgrep-commandにrgを指定したのですが様々な問題が発生しました。そのうちの一つが今回のダメ文字によって引数が壊れるというものでした。

正直ここまで面倒くさいことになるとは思いませんでした。たかがgrepを完全に動作させたいだけなのに。Emacsは(Windowsでは)grepもまともに使えないエディタなんです。

だいたいM-x grepのインタフェースは原始的すぎますよね。他にもlgrepとかrgrepとかzgrepとかzrgrep(rzgrep)とかgrep-find(find-grep)とかfind-grep-diredとかgrepと名の付くものはいったいEmacsに幾つ入っているのか調べてしまいましたよ。Emacsの機能だけを使ったgrepも悪くないと思うんですけどね。moccur-grepとか。外部のコマンドに依存しないのでWindowsでも安定して動きます。まぁ、速度は多少遅いかもしれませんが。diredからA(dired-do-find-regexp)とかQ(dired-do-find-regexp-and-replace)とかも結構便利だったりします。最近はconsult-ripgrepを使ってみています。Embarkで検索結果を普通のgrepのように別バッファに移したりも出来ます。grep一つとってもEmacsはとても難しくてなかなか人にお勧めできないエディタだなとつくづく思う次第です。

そういえば今回の問題に関連すると思われるメーリングリストの投稿を見ました。

https://lists.gnu.org/archive/html/bug-gnu-emacs/2013-01/msg01211.html

2013年だからもうずいぶん前ですよね。私は英語がとても苦手で中学時代にずっと2を取り続けたくらいなので正確な意味は分かりませんが、コマンドライン引数のエンコーディングに制限を課すべきでは無いと言っているのでしょうか。どうなんでしょうね。まずエスケープ処理をしている段階で既に特定のエンコーディングに制限されてしまっています。文字が\か"か判別する方法はエンコーディングによって変わりますからね。Cygwinですら今やマルチバイト文字を考慮してargvを組み立ててますよ。第一CreateProcessに渡すコマンドライン引数はA版なら現在のコードページ、W版ならUTF-16と決まっています。A版には何でも好きなバイト列を放り込めるわけでは無く、それはUTF-16に変換されて子プロセスに引き渡されます。spellerというのが何か知りませんが、そんな使い方をする人が実際にいるのでしょうか。少なくともWindowsではいないでしょう(出来ないので)。制限を課したくないと言いながら文字列をぶっ壊して特定の文字列を使えなくしてOSにはないEmacs独自の制限を新たに付け加えているのですから何を言っているんだろうという感じです。

誰かこの部分CreateProcessWでUNICODE化してくれませんかね。

既にWSL2上に移行した人も居るようですし今更感もある話題ですが、私はまだまだWindowsのネイティブ版を使い続けるつもりなので今後もおかしな挙動に悩まされ続けることでしょう。

2022-08-29 ,

折りたたみ状態によって見出しのマークを切り替える(org-mode)

org-modernを入れたのでこれまで使っていたorg-bulletsをお払い箱にして見出しの表示設定を調整しました。

これまで私が使っていた全角■●▲(←全角で表示されていますか?)等はどうにも野暮ったかったので、半角で表示される右三角にしてみたところ結構いい感じになりました。しかし右三角を使うと、開いたときに下向き三角になって欲しい気がしてしまいます。というわけでやってみました。

結果:

TABキーによって見出しのマークが切り替わる様子
図1: TABキーによって見出しのマークが切り替わる様子

コード:

;; org-modern.el (2022-12-22) に対する変更

;; まずは深さ毎の見出しマーク文字列(展開時、折りたたみ時の両方)をあらかじめ組み立てます。
;; org-modernではorg-modern-modeを起動したときにできるだけpropertizeした文字列を
;; 変数にキャッシュしておくようになっているので、それに倣いました。

(defvar-local org-modern--open-star-cache nil)
(defvar-local org-modern--folded-star-cache nil)

(defun my-org-modern--cache-star ()
  ;; 状態によって次の記号を使う。
  ;;  open(unfolded): BLACK RIGHT POINTING TRIANGLE (U+25B6)
  ;;  folded: BLACK DOWN POINTING SMALL TRIANGLE (U+25BE)
  ;; (SMALLを使ったのは手元の環境できっちり半角で表示される下向き黒三角がこれだけだったので)
  ;; (2022-12-22削除:深さに応じて先頭に空白を入れる。)
  ;; (2022-12-22追加:深さに応じて先頭に空白を入れるには org-modern-hide-stars に空白文字を指定すること。org-modern 0.6以降の機能)
  ;; この辺は好みで。
  (setq
   org-modern--open-star-cache
   (vconcat (cl-loop for level from 1 to 10
                     ;; (2022-12-22修正:本家でpropertizeを使うコードがorg-modern--symbolに変わったので追従。また、levelに応じて空白を入れるのを止めた)
                     collect (org-modern--symbol "▾")))
   org-modern--folded-star-cache
   (vconcat (cl-loop for level from 1 to 10
                     ;; (2022-12-22修正:本家でpropertizeを使うコードがorg-modern--symbolに変わったので追従。また、levelに応じて空白を入れるのを止めた)
                     collect (org-modern--symbol "▶")))))
(advice-add #'org-modern-mode :before #'my-org-modern--cache-star)

;; 次に折りたたみ状態に(開閉状態)によってfontify時に使うキャッシュを切り替えます。
;; 折りたたみ状態は見出し行の直後が不可視状態になっているかで判断しています。

(defun my-org-modern--star-around (original-fun &rest args)
  "Prettify headline stars."
  ;; 開閉状況によって org-modern--star-cache を切り替える。
  (let* ((folded (invisible-p (line-end-position)))
         (org-modern--star-cache (if folded
                                     org-modern--folded-star-cache
                                   org-modern--open-star-cache)))
    (apply original-fun args)))
(advice-add #'org-modern--star :around #'my-org-modern--star-around)

;; 最後に折りたたみ状態が切り替わったときに見出し行をfontifyし直します。
;; org-modeがセクションを表示したり非表示にしたりするとき、必ず
;; org-flag-regionやoutline-flag-regionが呼ばれます。
;; 表示/非表示する範囲の一行前くらいから見出し行を抽出してfont-lock-flushで
;; 再fontifyを促します。

(defun my-org-modern-flush-headings (from to flag)
  (save-match-data
    (save-excursion
      (goto-char from)

      ;; 1行前から更新する。更新すべき見出しが先行しているかもしれないので。
      (forward-line -1)

      ;; 閉じるときは一行前からFROMまでを処理すれば十分。
      ;; FROM以降は隠されて見えないし、開くときはflag=nilでここが呼ばれる。
      (when flag ;;hide region FROM..TO
        (setq to from))

      (while (re-search-forward (concat "^" org-outline-regexp) to t)
        (font-lock-flush (line-beginning-position)
                         (min (1+ (line-end-position)) (point-max)))))))

(defun my-org-modern-flag-region-advice (original-fun from to flag &rest args)
  (apply original-fun from to flag args)
  ;; org-modeやoutline-modeでFROMからTOまでを表示したり隠したりしたときに、
  ;; その中にある見出し行をfont-lockし直す。
  ;; font-lock側では現在の開閉状況によって見出し行を変化させる。
  (my-org-modern-flush-headings from to flag))

(advice-add #'outline-flag-region :around #'my-org-modern-flag-region-advice)

;; (2022-12-22修正:Org 9.6からorg-flag-regionはobsoleteになってorg-fold-core-regionが使われるようになったので修正。)
(if (version<= "9.6" (org-version))
    (when (fboundp 'org-fold-core-region)
      (advice-add #'org-fold-core-region :around #'my-org-modern-flag-region-advice))
  (when (fboundp 'org-flag-region)
    (advice-add #'org-flag-region :around #'my-org-modern-flag-region-advice)))

今回のことでorg-mode(やoutline-mode)が領域を表示/非表示にする流れについて理解が深まりました。

以前、折りたたみ状態によって見出し行の大きさや行間スペースを変えたいと思ったこともあるので、今回の応用でそういったことも可能になるかもしれません。

2022-08-27 ,

org-modernとorg-indentを併用したときの表の乱れを直す

org-modern

先日org-modernを試してみました。org-modeの各部の見た目を綺麗に(モダンに)してくれます。

そんな中で私が最も気に入ったのは、表(テーブル)の線を綺麗にしてくれるという点です。

org-modernで見た目を改善したorg-modeの表
図1: org-modernで見た目を改善したorg-modeの表

もはやorg-modeと言われなければ分からないと思います。

いくつか問題もあって、 org-table-toggle-coordinate-overlays による座標表示は機能しなくなります。まぁ、仕方ないですね。(2022-08-27追記: org-table-toggle-column-width あたりも問題がありますね。これはちょっと気になるかなぁ)

その辺りは許容するとして、私が使っていて最も気になったのはorg-indentと併用した際の問題です。org-indentは階層に応じて左にインデントをつけてくれるモードです。org-modernはこのorg-indentと相性が悪いです。例えばブロック(#+begin_???から#+end_???までの間)の左に装飾を入れる機能があるのですが、これはorg-indentが有効になっているときは機能しません。

org-indentの併用で表に発生する問題

表の線についてはorg-indent使用時でも一見正しく機能するように見えましたが、よく見ると二つほど問題がありました。

  • 横線の下に大きく空白が空く
  • ウィンドウの先頭にある行がインデントされない
修正前
図2: 修正前

原因

横線の下に大きく空白が空く原因は、org-indentが挿入する空白文字が高さを持ってしまっているところにあります。高さを持っている以上、その行がそれ以上縮まることはありません。

ウィンドウの先頭がインデントされない原因は、先日書いたEmacsのバグにあります。

原因
図3: 原因

修正

org-indentで挿入する空白の高さを1ピクセルにする

org-indentが挿入する文字列が高さを持ってしまっていることが原因なので、それを無くせば良いのです。文字列では無くdisplayプロパティのspace指定を使うことで高さ1ピクセルの空白を作ります。

;; org-indentを使っていると表の水平線の高さが狭まらない問題を修正する。
;; インデントの空白文字列の高さよりも小さくならないのが原因。
;; インデントの空白文字列をdisplayプロパティで高さ1pxのspaceに置き換える。
;; @todo wrap-indentも修正すべき?
(defun my-org-indent--compute-prefixes-after ()
  ;; org-indent--text-line-prefixesはレベル毎のline-prefix。
  ;; org-indent--compute-prefixesがそれを計算した後ここが呼ばれる。
  (let ((prefixes org-indent--text-line-prefixes))
    ;; 各レベルのprefixを修正する。
    (dotimes (i (length prefixes))
      (let* ((space-str (aref prefixes i))
             (space-length (length space-str)))
        (when (> space-length 0)
          (aset prefixes i
                ;; テキストプロパティ
                ;; display (space :width i :height (1))
                ;; を追加する。
                ;; つまり、line-prefixとして空白文字ではなく高さ1pxのspace
                ;; が表示されるようになる。
                ;; これによって、(prefix以外の)行の高さが正しく反映される
                ;; ようになる。これまでは行が小さくなってもprefixの空白文
                ;; 字の高さより小さくならなかった。
                (org-add-props
                    space-str
                    nil
                  'display (cons 'space
                                 (list :width space-length
                                              ;; (list (* space-length
                                              ;;          (frame-char-width)))
                                       :height '(1))))))))))
(advice-add #'org-indent--compute-prefixes :after
            #'my-org-indent--compute-prefixes-after)

元々このorg-indentの空白文字を入れるという挙動は、org-modernに限らず他でも同様の問題を引き起こす可能性があるはずです。例えばfaceをカスタマイズして特定の行の文字サイズを小さくしたとき、文字は小さくなったのに行が一緒に小さくならなず無駄に空白が空くという問題が生じる可能性があります。

表の縦線部分をdisplay (space …)ではなくdisplay " "にする

先日書いた通りこの問題はdisplayプロパティにspaceではなく文字列を指定すれば発生しません。文字列にすると幅と高さを自由に指定できなくなってしまいますが、face属性に:height 0.1を設定することで極小文字にして回避します。

;; org-modern--tableを差し替える。
(defun org-modern--table ()
  "Prettify vertical table lines."
  (save-excursion
    (let* ((beg (match-beginning 0))
           (end (match-end 0))
           (tbeg (match-beginning 1))
           (tend (match-end 1))
           ;; Unique objects
           (sp1 (list 'space :width 1))
           (sp2 (list 'space :width 1))
           (color (face-attribute 'org-table :foreground nil t))
           (inner (progn
                    (goto-char beg)
                    (forward-line)
                    (re-search-forward "^[ \t]*|" (line-end-position) t)))
           (separator (progn
                        (goto-char beg)
                        (re-search-forward "^[ \t]*|-" end 'noerror))))

      ;; 横線を引く
      (goto-char beg)
      (when separator
        ;; overlineを引いて高さを縮める
        (when (numberp org-modern-table-horizontal)
          (add-face-text-property tbeg tend `(:overline ,color) 'append)
          (add-face-text-property beg (1+ end) `(:height ,org-modern-table-horizontal) 'append))
        ;; 横幅を1文字分確保する(縦線部分以外)
        (while (re-search-forward "[^|+]+" tend 'noerror)
          (let ((a (match-beginning 0))
                (b (match-end 0)))
            ;; TODO Text scaling breaks the table formatting since the space is not scaled accordingly
            (cl-loop for i from a below b do
                     (put-text-property i (1+ i) 'display
                                        (if (= 0 (mod i 2)) sp1 sp2))))))

      ;; 縦線を引く
      (goto-char beg)
      (while (re-search-forward
              "-+\\(?1:+\\)-\\|\\(?:^\\|[- ]\\)\\(?1:|\\)\\(?:$\\|[- ]\\)"
              end 'noerror)
        (let ((a (match-beginning 1))
              (b (match-end 1)))
          (cond
           ((and org-modern-table-vertical (or (not separator) inner))
            (add-text-properties
             a b
             `(;; vertical lineにspaceを使うとウィンドウ先頭でline-prefixが効かなくなる。
               ;;display (space :width (,org-modern-table-vertical))
               display
               " "
               face
               (:inherit org-table :inverse-video t)
               ))
            (add-face-text-property a b`(:height 0.1) 'append) ;;0.1の部分は,org-modern-table-verticalとしたいところだけどピクセル数で指定されるので無理。
            )
           ((and org-modern-table-horizontal separator)
            (put-text-property
             a b
             ;; vertical lineにspaceを使うとウィンドウ先頭でline-prefixが効かなくなる。
             ;;'display `(space :width (,org-modern-table-vertical))
             'display " "))
           (t (put-text-property a b 'face 'org-hide)))))
      )))

結果

修正後
図4: 修正後