[PATCH] pkl: split iolist instruction into two instructions

[Mohammad-Reza Nabipoor]

2022-10-26  Mohammad-Reza Nabipoor  <mnabipoor@gnu.org>

        * libpoke/pkl-insn.def (iolist): Remove instruction.
        (ionum): New instruction.
        (ioref): Likewise.
        * libpoke/pvm.jitter (iolist): Remove instruction.
        (ionum): New instruction.
        (ioref): Likewise.
        (late-c): Add callback functions to traverse IO space.
        * libpoke/pkl-rt.pk (iolist): Re-write in terms of new
        instructions.
---
 ChangeLog            | 12 +++++++
 libpoke/pkl-insn.def |  3 +-
 libpoke/pkl-rt.pk    |  7 +++-
 libpoke/pvm.jitter   | 78 +++++++++++++++++++++++++++++++++-----------
 4 files changed, 79 insertions(+), 21 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 63f63999..ced77d93 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,15 @@
+2022-10-26  Mohammad-Reza Nabipoor  <mnabipoor@gnu.org>
+
+       * libpoke/pkl-insn.def (iolist): Remove instruction.
+       (ionum): New instruction.
+       (ioref): Likewise.
+       * libpoke/pvm.jitter (iolist): Remove instruction.
+       (ionum): New instruction.
+       (ioref): Likewise.
+       (late-c): Add callback functions to traverse IO space.
+       * libpoke/pkl-rt.pk (iolist): Re-write in terms of new
+       instructions.
+
 2022-10-26  Jose E. Marchesi  <jemarch@gnu.org>
 
        * etc/poke.rec (Introduce SELF in methods): Removed as DONE.
diff --git a/libpoke/pkl-insn.def b/libpoke/pkl-insn.def
index a0bd73a0..4deb8d68 100644
--- a/libpoke/pkl-insn.def
+++ b/libpoke/pkl-insn.def
@@ -460,7 +460,8 @@ PKL_DEF_INSN(PKL_INSN_IOHANDLER,"","iohandler")
 PKL_DEF_INSN(PKL_INSN_IOFLAGS,"","ioflags")
 PKL_DEF_INSN(PKL_INSN_IOGETB,"","iogetb")
 PKL_DEF_INSN(PKL_INSN_IOSETB,"","iosetb")
-PKL_DEF_INSN(PKL_INSN_IOLIST,"","iolist")
+PKL_DEF_INSN(PKL_INSN_IONUM,"","ionum")
+PKL_DEF_INSN(PKL_INSN_IOREF,"","ioref")
 
 /* VM instructions.  */
 
diff --git a/libpoke/pkl-rt.pk b/libpoke/pkl-rt.pk
index 963bd193..39a62df0 100644
--- a/libpoke/pkl-rt.pk
+++ b/libpoke/pkl-rt.pk
@@ -71,7 +71,12 @@ immutable fun iobias = (int<32> ios = get_ios) 
offset<uint<64>,1>:
 
 immutable fun iolist = int<32>[]:
 {
-  return asm int<32>[]: ("iolist");
+  var a = int<32>[] (),
+      n = asm uint<64>: ("ionum");
+
+  for (var i = 0UL; i < n; ++i)
+    apush (a, asm int<32>: ("ioref; nip" : i));
+  return a;
 }
 
 immutable fun iosetbias = (offset<uint<64>,1> bias = 0#1, int<32> ios = 
get_ios) void:
diff --git a/libpoke/pvm.jitter b/libpoke/pvm.jitter
index 8fe50780..9fa8854d 100644
--- a/libpoke/pvm.jitter
+++ b/libpoke/pvm.jitter
@@ -917,19 +917,38 @@ late-c
     };
 #undef E
 
-    struct iolist_ctx
+    struct ionum_ctx
     {
-      pvm_val arr_ios;
+      uint64_t count;
     };
 
     static void
-    iolist_callback (ios io, void *data)
+    ionum_callback (ios io, void *data)
     {
-      struct iolist_ctx *ctx = data;
-      pvm_val arr = ctx->arr_ios;
+      struct ionum_ctx *ctx = data;
 
-      (void) pvm_array_insert (arr, PVM_VAL_ARR_NELEM (arr),
-                               PVM_MAKE_INT (ios_get_id (io), 32));
+      ++ctx->count;
+    }
+
+    struct ioref_ctx
+    {
+      uint64_t index;
+      int ios_id;
+    };
+
+    static void
+    ioref_callback (ios io, void *data)
+    {
+      struct ioref_ctx *ctx = data;
+
+      if (ctx->ios_id != -1)
+        return;
+      if (ctx->index == 0)
+        {
+          ctx->ios_id = ios_get_id (io);
+          return;
+        }
+      --ctx->index;
     }
 
     static int
@@ -1812,23 +1831,44 @@ instruction iosize ()
   end
 end
 
-# Instruction: iolist
+# Instruction: ionum
 #
-# Push an array of open IO spaces (array of signed integers) on the stack.
-# This array may be empty if no IO space is open.
+# Pushe the number of IO spaces on the stack.
 #
-# Stack: ( -- ARR )
+# Stack: ( -- ULONG )
 
-instruction iolist ()
+instruction ionum ()
   code
-    struct iolist_ctx iolist_ctx;
-    pvm_val arr = pvm_make_array (pvm_make_integral_type (PVM_MAKE_ULONG (32, 
64),
-                                                          PVM_MAKE_INT (1, 
32)),
-                                  PVM_MAKE_ULONG (0, 64));
+    struct ionum_ctx ctx;
 
-    iolist_ctx.arr_ios = arr;
-    ios_map (iolist_callback, &iolist_ctx);
-    JITTER_PUSH_STACK (arr);
+    ctx.count = 0;
+    ios_map (ionum_callback, &ctx);
+    JITTER_PUSH_STACK (PVM_MAKE_ULONG (ctx.count, 64));
+  end
+end
+
+# Instruction: ioref
+#
+# Given an index ULONG, push the descriptor of the IO space on
+# the stack as a signed integer.
+#
+# If the provided index is out of bounds, then raise
+# PVM_E_OUT_OF_BOUNDS.
+#
+# Stack: ( ULONG -- ULONG IOS )
+# Exceptions: PVM_E_OUT_OF_BOUNDS
+
+instruction ioref ()
+  branching # because of PVM_RAISE_DIRECT
+  code
+    struct ioref_ctx ctx;
+
+    ctx.index = PVM_VAL_ULONG (JITTER_TOP_STACK ());
+    ctx.ios_id = -1;
+    ios_map (ioref_callback, &ctx);
+    if (ctx.ios_id == -1)
+      PVM_RAISE_DIRECT (PVM_E_OUT_OF_BOUNDS);
+    JITTER_PUSH_STACK (PVM_MAKE_INT (ctx.ios_id, 32));
   end
 end
 
-- 
2.38.1