From 11dea3c363eb019b4c3694c3321dbf676e6aa039 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 1 Nov 2022 21:57:46 +0100
Subject: disassembler: Show intrinsic name for 'call-' instructions.

* module/system/vm/disassembler.scm (code-annotation)[intrinsic-name]:
New procedure.
Add clauses for intrinsics.
* NEWS: Update.
---
 NEWS                              |  5 +++++
 module/system/vm/disassembler.scm | 47 ++++++++++++++++++++++++++++++++++++++-
 2 files changed, 51 insertions(+), 1 deletion(-)

diff --git a/NEWS b/NEWS
index 644e8bbab..07011c3c6 100644
--- a/NEWS
+++ b/NEWS
@@ -48,6 +48,11 @@ IPv6 support; they can be used with `bind'.
 Likewise, the `IPPROTO_IPV6' and `IPV6_V6ONLY' constants are defined,
 for use with `setsockopt'.
 
+** Disassembler now shows intrinsic names
+
+Disassembler output now includes the name of intrinsics next to each
+`call-' instruction (info "(guile) Intrinsic Call Instructions").
+
 * Bug fixes
 
 ** Type sizes are correctly determined when cross-compiling
diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index cc055491d..2c9755ab9 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -1,6 +1,6 @@
 ;;; Guile bytecode disassembler
 
-;;; Copyright (C) 2001, 2009-2010, 2012-2015, 2017-2020 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009-2010, 2012-2015, 2017-2020, 2022 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -229,6 +229,10 @@ address of that offset."
       (pointer->scm
        (dereference-pointer (make-pointer addr)))))
 
+  (define (intrinsic-name index)
+    (and=> (intrinsic-index->name index)
+           (compose list symbol->string)))
+
   (match code
     (((or 'j 'je 'jl 'jge 'jne 'jnl 'jnge) target)
      (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
@@ -284,6 +288,47 @@ address of that offset."
                       "anonymous procedure")))
        (push-addr! addr name)
        (list "~A at #x~X" name addr)))
+
+    ;; intrinsics
+    (('call-thread index)
+     (intrinsic-name index))
+    (('call-thread-scm _ index)
+     (intrinsic-name index))
+    (('call-thread-scm-scm _ _ index)
+     (intrinsic-name index))
+    (('call-scm-sz-u32 _ _ index)
+     (intrinsic-name index))
+    (('call-scm<-thread _ index)
+     (intrinsic-name index))
+    (('call-scm<-u64 _ _ index)
+     (intrinsic-name index))
+    (('call-scm<-s64 _ _ index)
+     (intrinsic-name index))
+    (('call-scm<-scm _ _ index)
+     (intrinsic-name index))
+    (('call-u64<-scm _ _ index)
+     (intrinsic-name index))
+    (('call-s64<-scm _ _ index)
+     (intrinsic-name index))
+    (('call-f64<-scm _ _ index)
+     (intrinsic-name index))
+    (('call-scm<-scm-scm _ _ _ index)
+     (intrinsic-name index))
+    (('call-scm<-scm-uim _ _ _ index)
+     (intrinsic-name index))
+    (('call-scm<-scm-u64 _ _ _ index)
+     (intrinsic-name index))
+    (('call-scm-scm _ _ index)
+     (intrinsic-name index))
+    (('call-scm-scm-scm _ _ _ index)
+     (intrinsic-name index))
+    (('call-scm-uimm-scm _ _ _ index)
+     (intrinsic-name index))
+    (('call-scm<-scm-uimm _ _ _ index)
+     (intrinsic-name index))
+    (('call-scm<-scmn-scmn _ _ _ index)
+     (intrinsic-name index))
+
     (('make-non-immediate dst target)
      (let ((val (reference-scm target)))
        (when (program? val)
-- 
cgit v1.2.1