/* pkl-rt.pk - Run-time library for the poke compiler.  */

/* Copyright (C) 2019, 2020, 2021, 2022, 2023, 2024 Jose E. Marchesi.  */

/* This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <http://www.gnu.org/licenses/>.
 */

/* Exceptions.  */

/* IMPORTANT: if you make changes to the Exception struct, please
   update the pvm_make_exception function in pvm-val.c
   accordingly.  */

immutable type Exception =
  struct
  {
    int<32> code;
    string name;
    int<32> exit_status;
    string location;
    string msg;
  };

/* Standard exception codes.
   These codes should be in sync with PVM_E_* macros in pvm.h and
   PK_EC_* macros libpoke.h.
   Note that user-defined exceptions must have codes starting with
   255 (and should be registered using exception_code function defined
   below).
   Note also that EC_generic _must_ be zero.  */

immutable var EC_generic       = 0;
immutable var EC_div_by_zero   = 1;
immutable var EC_no_ios        = 2;
immutable var EC_no_return     = 3;
immutable var EC_out_of_bounds = 4;
immutable var EC_eof           = 6;
immutable var EC_map           = 7;
immutable var EC_conv          = 8;
immutable var EC_elem          = 9;
immutable var EC_constraint    = 10;
immutable var EC_io            = 11;
immutable var EC_signal        = 12;
immutable var EC_io_flags      = 13;
immutable var EC_inval         = 14;
immutable var EC_exit          = 15;
immutable var EC_assert        = 16;
immutable var EC_overflow      = 17;
immutable var EC_perm          = 18;
immutable var EC_stack         = 19;

/* Standard exceptions.  */

immutable var E_generic
  = Exception {code = EC_generic, name = "generic", exit_status = 1};
immutable var E_div_by_zero
  = Exception {code = EC_div_by_zero, name = "division by zero", exit_status = 1};
immutable var E_no_ios
  = Exception {code = EC_no_ios, name = "no IOS", exit_status = 1};
immutable var E_no_return
  = Exception {code = EC_no_return, name = "no return", exit_status = 1};
immutable var E_out_of_bounds
  = Exception {code = EC_out_of_bounds, name = "out of bounds", exit_status = 1};
immutable var E_eof
  = Exception {code = EC_eof, name = "EOF", exit_status = 0 };
immutable var E_map
  = Exception {code = EC_map, name = "no map", exit_status = 1};
immutable var E_conv
  = Exception {code = EC_conv, name = "conversion error", exit_status = 1};
immutable var E_elem
  = Exception {code = EC_elem, name = "invalid element", exit_status = 1};
immutable var E_constraint
  = Exception {code = EC_constraint, name = "constraint violation", exit_status = 1};
immutable var E_io
  = Exception {code = EC_io, name = "generic IO", exit_status = 1};
immutable var E_signal
  = Exception {code = EC_signal, exit_status = 1};
immutable var E_io_flags
  = Exception {code = EC_io_flags, name = "invalid IO flags", exit_status = 1};
immutable var E_inval
  = Exception {code = EC_inval, name = "invalid argument", exit_status = 1};
immutable var E_exit
  = Exception {code = EC_exit, name = "exit", exit_status = 0};
immutable var E_assert
  = Exception {code = EC_assert, name = "assertion failure", exit_status = 1};
immutable var E_overflow
  = Exception {code = EC_overflow, name = "overflow", exit_status = 1};
immutable var E_perm
  = Exception {code = EC_perm, name = "wrong permissions", exit_status = 1};
immutable var E_stack
  = Exception {code = EC_stack, name = "invalid stack", exit_status = 1};

/* Given the name of a struct field FNAME, and a snippet with Poke
   code CODE, return a suitable string to be put in the `msg' field of
   an E_constraint exception resulting from the evaluation of an
   expression whose source code is in CODE.

   Note that FNAME can be empty if the field is anonymous.
   Also, CODE may be empty.  */

immutable fun _pkl_e_constraint_msg = (string fname, string code) string:
{
  var msg = "";

  if (code != "")
    {
      msg += "failed expression\n  ";
      for (c in code)
        msg += (c == '\n') ? "\n  " : c as string;
    }

  if (fname != "")
    msg += "\nin field " + fname;

  return msg;
}

/* Registration of user-defined exceptions */

immutable type _ExceptionCodeGenerator = () int<32>;
immutable var exception_code = lambda _ExceptionCodeGenerator:
  {
    var n = 255; /* First available code for user-defined exceptions */

    return lambda int<32>: { return n++; };
  }();

/* Compiler built-ins that may raise exceptions.  */

immutable fun getenv = (string name) string:
{
  var env_var = asm any: ("getenv; nip" : name);

  if (!asm int<32>: ("nn; nip" : env_var))
    raise Exception { code = EC_inval,
                      name = "invalid argument",
                      msg = "no environment variable " + name };

  return env_var as string;
}

/* Compiler built-ins. */

immutable fun rand = (uint<32> seed = 0) int<32>:
{
  return asm int<32>: ("rand" : seed);
}

immutable fun get_endian = int<32>:
{
  return asm int<32>: ("pushend");
}

immutable fun set_endian = (int<32> endian) int<32>:
{
  asm ("popend" :: endian);

  /* Always return `true' to facilitate using this function in struct
  constraint expressions.  */
 return 1;
}

immutable fun flush = (int<32> ios, offset<uint<64>,1> offset) void:
{
  asm ("ogetm
        nip
        flush
        bn .done
        raise
      .done:
        drop" :: ios, offset);
}

immutable fun gettime = int<64>[2]:
{
  var t = int<64>[2] ();

  asm ("time" : t[0], t[1]);
  return t;
}

immutable fun strace = void:
{
  asm ("strace 0");
}

immutable fun rtrace = void:
{
  asm ("rtrace 0");
}

immutable fun term_get_color = int<32>[3]:
{
  var r = 0, g = 0, b = 0;
  asm ("pushoc" : r, g, b);
  return [r, g, b];
}

immutable fun term_set_color = (int<32>[3] color) void:
{
  asm ("popoc" :: color[0], color[1], color[2]);
}

immutable fun term_get_bgcolor = int<32>[3]:
{
  var r = 0, g = 0, b = 0;
  asm ("pushobc" : r, g, b);
  return [r, g, b];
}

immutable fun term_set_bgcolor = (int<32>[3] color) void:
{
  asm ("popobc" :: color[0], color[1], color[2]);
}

immutable fun term_begin_class = (string class) void:
{
  asm ("begsc" :: class);
}

immutable fun term_end_class = (string class) void:
{
  if (!asm int<32>: ("endsc" : class))
    raise Exception { code = EC_inval,
                      name = "invalid class" };
}

immutable fun term_begin_hyperlink = (string url, string id = "") void:
{
  asm ("beghl" :: url, id);
}

immutable fun term_end_hyperlink = void:
{
  if (!asm int<32>: ("endhl"))
     raise Exception { code = EC_inval,
                      name = "no current hyperlink" };
}

immutable fun vm_obase = int<32>:
{
  return asm int<32>: ("pushob");
}

immutable fun vm_set_obase = (int<32> obase) void:
{
  if (!(obase in [2, 8, 10, 16]))
    raise E_inval;
  asm ("popob" :: obase);
}

immutable fun vm_opprint = int<32>:
{
  return asm int<32>: ("pushopp");
}

immutable fun vm_set_opprint = (int<32> pprint_p) void:
{
  asm ("popopp" :: pprint_p);
}

immutable fun vm_oacutoff = int<32>:
{
  return asm int<32>: ("pushoac");
}

immutable fun vm_set_oacutoff = (int<32> oacutoff) void:
{
  asm ("popoac" :: oacutoff);
}

immutable fun vm_odepth = int<32>:
{
  return asm int<32>: ("pushod");
}

immutable fun vm_set_odepth = (int<32> odepth) void:
{
  asm ("popod" :: odepth);
}

immutable fun vm_oindent = int<32>:
{
  return asm int<32>: ("pushoi");
}

immutable fun vm_set_oindent = (int<32> oindent) void:
{
  asm ("popoi" :: oindent);
}

immutable fun vm_omaps = int<32>:
{
  return asm int<32>: ("pushoo");
}

immutable fun vm_set_omaps = (int<32> omaps) void:
{
  asm ("popoo" :: omaps);
}

immutable fun vm_omode = int<32>:
{
  return asm int<32>: ("pushom");
}

/* Please keep the following two variables in sync with enum pvm_omode
   in pvm.h.  */
immutable var VM_OMODE_PLAIN = 0;
immutable var VM_OMODE_TREE = 1;

immutable fun vm_set_omode = (int<32> omode) void:
{
  if (!(omode in [VM_OMODE_PLAIN, VM_OMODE_TREE]))
    raise E_inval;
  asm ("popom" :: omode);
}

immutable fun vm_dispatch = string:
{
  return asm string: ("vmdisp");
}

immutable fun __pkl_unsafe_string_set = (string dst, uint<64> index,
                                         string str) void:
{
  asm ("strset; drop" :: dst, index, str);
}

immutable fun vm_autoremap = int<32>:
{
  return asm int<32>: ("pusharem");
}

immutable fun vm_set_autoremap = (int<32> autoremap) void:
{
  asm ("poparem" :: autoremap);
}

immutable var ENDIAN_LITTLE = 0;
immutable var ENDIAN_BIG = 1;

/* IOS flags and modes.

   There is space for 64 flags in the uint<64> optional argument to
   `open'.  The flags in the least-significative 32 bits are valid for
   all IOD backends and are defined below.  The most-significative 32
   bits are reserved for backend-specific flags.

   Please keep these values in sync with the constants in ios.h.  */

immutable var IOS_F_READ   = 1;
immutable var IOS_F_WRITE  = 2;
immutable var IOS_F_CREATE = 16;

immutable var IOS_M_RDONLY = IOS_F_READ;
immutable var IOS_M_WRONLY = IOS_F_WRITE;
immutable var IOS_M_RDWR = IOS_F_READ | IOS_F_WRITE;

/* Find the greatest common divisor of two unsigned 64-bit integrals A
   and B using the Euclidean algorithm.  */

immutable fun _pkl_gcd = (uint<64> a, uint<64> b) uint<64>:
  {
   if (b == 0)
     return a;
   else
     return _pkl_gcd (b, a % b);
  }

/* Return the prefix to use when printing integral magnitudes of the
   given numerical base.  This may return an empty prefix.  */

immutable fun _pkl_base_prefix = (int<32> base) string:
 {
   if (base == 2)
      return "0b";
   if (base == 8)
      return "0o";
   if (base == 16)
      return "0x";

   return "";
 }

/* Concatenate three strings.  */

immutable fun _pkl_strcat3 = (string a, string b, string c) string:
  {
    var la = a'length,
        lab = la + b'length,
        labc = lab + c'length,
        s = "?" * labc;

    __pkl_unsafe_string_set (s, 0, a);
    __pkl_unsafe_string_set (s, la, b);
    __pkl_unsafe_string_set (s, lab, c);
    return s;
  }

/* Reduces an array of string to a single string by concatenting the
   NELEM elements of ARR starting from specified INDEX.  */

immutable fun _pkl_reduce_string_array = (string[] arr,
                                          uint<64> index, uint<64> nelem) string:
  {
    var slen = 0UL,
        first = index,
        last = index + nelem;

    while (first < last)
      {
        slen += arr[first]'length;
        ++first;
      }

    var s = " " * slen;  /* Allocate the final string once.  */

    first = index;
    for (var cursor = 0UL; first < last; ++first)
      {
        __pkl_unsafe_string_set (s, cursor, arr[first]);
        cursor += arr[first]'length;
      }
    return s;
  }

/* Return a new string in which all the non-printable characters are replaced
   with a escape sequence (\xXX).  */

immutable fun _pkl_escape_string = (string str) string:
  {
    var chars = "0123456789abcdef",
        len = str'length,
        len_esc = 0;

    /* Calculate the length of escaped string.  */
    for (var i = 0UL; i < len; ++i)
      len_esc +=
        str[i] == '\t' || str[i] == '\n' || str[i] == '"'  /* " */
                  || str[i] == '\\' ? 2
          : str[i] - 0x20UB < 0x5fUB /* is printable */ ? 1
          : 4 /* \xXX */;

    var esc = "?" * len_esc;

    for (var i = 0UL, j = 0UL; i < len; ++i)
      {
        if (str[i] == '\t')
          {
            __pkl_unsafe_string_set (esc, j, "\\t");
            j += 2;
          }
        else if (str[i] == '\n')
          {
            __pkl_unsafe_string_set (esc, j, "\\n");
            j += 2;
          }
        else if (str[i] == '"') /* " */
          {
            __pkl_unsafe_string_set (esc, j, "\\\"");
            j += 2;
          }
        else if (str[i] == '\\')
          {
            __pkl_unsafe_string_set (esc, j, "\\\\");
            j += 2;
          }
        else if (str[i] - 0x20UB < 0x5fUB)
          {
            __pkl_unsafe_string_set (esc, j, str[i] as string);
            ++j;
          }
        else
          {
            var nib_lo = chars[str[i] & 0xfUB] as string,
                nib_hi = chars[(str[i] .>> 4) & 0xfUB] as string;

            __pkl_unsafe_string_set (esc, j, "\\x" + nib_hi + nib_lo);
            j += 4;
          }
      }
    return esc;
  }

/* Return a string with the name corresponding to the given unit in
   bits.  This may be an empty string for an unknown unit.

   This should go away once we have a run-time mechanism to store and
   access unit types.  */

immutable var _pkl_unit_bit =    1UL;
immutable var _pkl_unit_nibble = 4UL;
immutable var _pkl_unit_byte =   8UL;

immutable var _pkl_unit_kilobit = _pkl_unit_bit * 1000;
immutable var _pkl_unit_kilobyte = _pkl_unit_byte * 1000;
immutable var _pkl_unit_megabit = _pkl_unit_kilobit * 1000;
immutable var _pkl_unit_megabyte = _pkl_unit_kilobyte * 1000;
immutable var _pkl_unit_gigabit = _pkl_unit_megabit * 1000;
immutable var _pkl_unit_gigabyte = _pkl_unit_megabyte * 1000;

immutable var _pkl_unit_kibibit = _pkl_unit_bit * 1024;
immutable var _pkl_unit_kibibyte = _pkl_unit_byte * 1024;
immutable var _pkl_unit_mebibit = _pkl_unit_kibibit * 1024;
immutable var _pkl_unit_mebibyte = _pkl_unit_kibibyte * 1024;
immutable var _pkl_unit_gibibit = _pkl_unit_mebibit * 1024;
immutable var _pkl_unit_gibibyte = _pkl_unit_mebibyte * 1024;

immutable fun _pkl_unit_name = (uint<64> bits) string:
 {
    if (bits == _pkl_unit_bit)
       return "b";
    if (bits == _pkl_unit_nibble)
       return "N";
    if (bits == _pkl_unit_byte)
       return "B";
    if (bits == _pkl_unit_kilobit)
       return "Kb";
    if (bits == _pkl_unit_kilobyte)
       return "KB";
    if (bits == _pkl_unit_megabit)
       return "Mb";
    if (bits == _pkl_unit_megabyte)
       return "MB";
    if (bits == _pkl_unit_gigabit)
       return "Gb";
    if (bits == _pkl_unit_gigabyte)
       return "GB";
    if (bits == _pkl_unit_kibibit)
       return "Kib";
    if (bits == _pkl_unit_kibibyte)
       return "KiB";
    if (bits == _pkl_unit_mebibit)
       return "Mib";
    if (bits == _pkl_unit_mebibyte)
       return "MiB";
    if (bits == _pkl_unit_gibibit)
       return "Gib";
    if (bits == _pkl_unit_gibibyte)
       return "GiB";

    return "";
  }

/* Assertion function.

   The compiler transforms assert statement to invocation of this
   function.  COND is first argument of assert statement, and MSG is
   the optional second argument.  FILENAME is the name of source
   file.  LINE and COL are, respectively, line and column number
   of the assert statement in the source file.  */

immutable fun _pkl_assert = (uint<64> cond, string msg, string filename,
                             uint<64> line, uint<64> col) void:
  {
    if (cond)
      return;

    raise Exception {
      code = EC_assert,
      name = "assertion failure",
      location = format ("%s:%u64d:%u64d:", filename, line, col),
      msg = msg,
      exit_status = 1,
    };
  }

/* Sleep instruction wrapper.  */

immutable fun sleep = (int<64> sec, int<64> nsec = 0) void:
{
  var err = 0;
  asm ("sleep; nip2" : err : sec, nsec);
  if (err == -1)
    raise E_inval;
  if (err == -2)
    raise E_generic;
  assert (err == 0,
          "Unhandled error in sleep()!  Please email <poke-devel@gnu.org>.");
}

/* The following function implements the fast path of the aoref macro
   in pkl-gen.pks.  Given an array whose elements have all the same
   size, which is known at compile-time, and an offset, return the
   element stored in the array at that exact offset.  If no such
   element exists in the array then raise E_out_of_bounds.  */

immutable fun _pkl_aoref_complete = (any[] array, offset<uint<64>,1> idx,
                                     uint<64> elem_bsize) any:
{
  var len = array'length;

  /* Corner case to avoid division by zero below.  */
  if (elem_bsize == 0 && idx == 0#1 && len > 0)
    return array'elem (0);

  if (idx'magnitude % elem_bsize == 0)
    return array'elem (idx'magnitude / elem_bsize);
  raise E_out_of_bounds;
}

/* The following function implements the slow path of the aoref macro
   in pkl-gen.pks.  Given an array and an offset, return the element
   stored in the array at that exact offset.  If no such element exists
   in the array then raise E_out_of_bounds.  */

immutable fun _pkl_aoref = (any[] array, offset<uint<64>,1> idx) any:
{
  var len = array'length;

  if (array'mapped)
    idx += array'offset;

  for (var i = 0UL; i < len; ++i)
    {
      if (array'eoffset (i) > idx)
        break;

      if (array'eoffset (i) == idx)
        return array'elem (i);
    }

  raise E_out_of_bounds;
}

/* The following function implements the stroref macro in pkl-gen.pks.
   Given a string and an offset, return the character occupying the
   position at the given offset in the string.  If the given offset is
   past the end of the string or the offset is not byte-aligned then
   raise E_out_of_bounds.  */

immutable fun _pkl_stroref = (string str, offset<uint<64>,1> idx) uint<8>:
{
  if (idx'magnitude % 8 != 0 || idx >= str'size)
    raise E_out_of_bounds;

  return str[idx'magnitude / 8];
}

/* The Pk_Type struct below describes the values returned by the
   `typeof' language construction.  This type is used in the compiler
   phases, so pretty please do not use `typeof' until the compiler has
   been bootstrapped.

   Fun facts:
   1) If you do changes to the struct Pk_Type defined below it is most
      likely you will have to adapt the typifier RAS functions/macros
      accordingly.
   2) The PK_TYPE_* values _must_ resolve to a constant integral value
      at compile-time.  Constant folding is ok.  Changing their values
      is ok.
*/

immutable var PK_TYPE_UNKNOWN  = 0U;
immutable var PK_TYPE_INTEGRAL = 1U;
immutable var PK_TYPE_OFFSET   = 2U;
immutable var PK_TYPE_STRING   = 3U;
immutable var PK_TYPE_ARRAY    = 4U;
immutable var PK_TYPE_STRUCT   = 5U;
immutable var PK_TYPE_FUNCTION = 6U;
immutable var PK_TYPE_ANY      = 7U;

immutable type Pk_Type =
  struct
  {
    uint<32> code;
    string name;
    uint<32> complete_p;
    int<32> integral_p  if code == PK_TYPE_STRUCT;
    int<32> signed_p    if code in [PK_TYPE_INTEGRAL, PK_TYPE_OFFSET] || code == PK_TYPE_STRUCT && integral_p;
    uint<64> size       if code in [PK_TYPE_INTEGRAL, PK_TYPE_OFFSET] || code == PK_TYPE_STRUCT && integral_p;
    uint<64> _unit      if code == PK_TYPE_OFFSET;
    int<32> bounded_p   if code == PK_TYPE_ARRAY;
    int<32> union_p     if code == PK_TYPE_STRUCT;
    int<32> pinned_p    if code == PK_TYPE_STRUCT;
    int<32> nfields     if code == PK_TYPE_STRUCT;
    int<32> nmethods    if code == PK_TYPE_STRUCT;
    string[] fnames     if code == PK_TYPE_STRUCT;
    int<32>[] fcomputed if code == PK_TYPE_STRUCT;
    string[] ftypes     if code == PK_TYPE_STRUCT;
    string[] mnames     if code == PK_TYPE_STRUCT;
    string[] mtypes     if code == PK_TYPE_STRUCT;

    (int<32>,int<32>,uint<64>)any mapper if code in [PK_TYPE_ARRAY, PK_TYPE_STRUCT];
    (any)void writer                     if code in [PK_TYPE_ARRAY, PK_TYPE_STRUCT];
    (any)any integrator                  if code in [PK_TYPE_ARRAY, PK_TYPE_STRUCT];
    (any)any deintegrator                if code == PK_TYPE_STRUCT;
    (any,any)int<32> comparator          if code == PK_TYPE_STRUCT;
  };

/* Tracing.

   If the boolean variable `pk_tracer_p' is set to true the compiler
   and run-time will collaborate to emit different kind of tracing
   events.  This is done by invoking a tracing dispatch function that
   is defined below.  */

immutable var pk_tracer_p = 0;

/* The tracing events themselves are identified by unique signed
   32-bit values that start with 0 and use consecutive numbers.

   Fun facts:
   - The PK_TV_* values are used as keys in arrays, so please
     keep them consecutive, ideally without any gap.
   - For the same reason, we need PK_TV_NUM_EVENTS always up to
     date.
   - The PK_TV_* values are replicated in pkl.h.  Please keep
     these in sync.

   These are the supported tracing events:

   A FIELD_MAPPED tracing event is generated every time a struct or
   union field has been successfully mapped from IO space, but before
   its constraints have been checked.  The event dispatch function is
   passed the following arguments:

     FIELD_VALUE (any)
       The value of the field that has been mapped.

     FIELD_Type (Pk_Type)
       A Pk_Type describing the type of the field value.

     FIELD_NAME (string)
       The name of the field that was mapped.  If the field is
       anonymous then an empty string is passed.

     FIELD_OFFSET (offset<uint<64>,b>)
       Offset of the field just mapped.

   A FIELD_CONSTRUCTED tracing event is generated every time a struct
   or union field has been successfully constructed, but before its
   constraints have been checked.  The event dispatch function is
   passed the following arguments:

     FIELD_VALUE (any)
       The value of the field that has been constructed.

     FIELD_Type (Pk_Type)
       A Pk_Type describing the type of the field value.

     FIELD_NAME (string)
       The name of the field that was constructed.  If the field is
       anonymous then an empty string is passed.

     FIELD_OFFSET (offset<uint<64>,b>)
       Offset of the field just constructed.

   A FIELD_ABSENT tracing event is generated every time an optional
   field is found to be absent when mapping or constructing a struct.
   The event dispatch function is passed the following arguments:

     FIELD_NAME (string)
       The name of the field that is found to be absent.  Note that
       optional fields cannot be anonymous.  */

immutable var PK_TV_FIELD_MAPPED = 0;
immutable var PK_TV_FIELD_ABSENT = 1;
immutable var PK_TV_FIELD_CONSTRUCTED = 2;
immutable var PK_TV_NUM_EVENTS = 3;

/* Tracing events can be handled by "actions".  Each action is
   implemented by an "event handler, which is a Poke function
   that gets two arguments:

   The first argument is the tracing event ID, one of the
   PK_TV_* values defined above.

   The second argument is an array of zero or more `any' valus.  The
   number and interpretation of these values depend on the particular
   tracing event being handled.  See the descriptions of the events
   below.  */

immutable type Pk_Tracer_Action = (int<32>,any[])void;

/* The "tracer dispatch table" is a table that associates event IDs
   with actions.  When the run-time triggers a tracing event, it looks
   in the table and invokes the corresponding event handler.  The user
   can install his own actions.  */

immutable type Pk_Tracer_Dispatch_Table =
  struct
  {
    /* The default action for tracer events is to do nothing.  */
    fun default_action = (int<32> e, any[] args) void: { }

    Pk_Tracer_Action[] table
      = Pk_Tracer_Action[PK_TV_NUM_EVENTS] (default_action);

    /* Register an action for a tracing event.  */
    method set_action = (int<32> e, Pk_Tracer_Action act) void:
    {
      table[e] = act;
    }

    /* Reset the action for a tracing event to the default,
       which is to do nothing.  */
    method reset_action = (int<32> e) void:
    {
      table[e] = default_action;
    }
  };

immutable var pk_tracer_dispatch = Pk_Tracer_Dispatch_Table {};

/* This is to be .called from RAS.  */

immutable fun _pkl_dispatch_tv = (int<32> e, any[] a) void:
{
  pk_tracer_dispatch.table[e] (e, a);
}

/* Closures which are useful for creating array bounders.  */

type _Pkl_ClsN = ()any;
type _Pkl_ClsI = ()uint<64>;
type _Pkl_ClsO = ()offset<uint<64>,1>;

/* Return a closure that returns `null'.  */

immutable fun _pkl_mkclsn = _Pkl_ClsN:
{
  /* HACK This is equivalent to `push null'.
     Until we get a more powerful assembler, we have to use this
     trick.  */
  return lambda any: { return asm any: ("push 7"); };
}

immutable fun _pkl_mkclsi = (uint<64> i) _Pkl_ClsI:
{
  return lambda uint<64>: { return i; };
}

immutable fun _pkl_mkclso = (offset<uint<64>,1> o) _Pkl_ClsO:
{
  return lambda offset<uint<64>,1>: { return o; };
}

/* Hooks for the IO subsystem.

   The functions in `ios_open_hook' are invoked once a new IO space
   has been opened.

   The functions in `ios_close_pre_hook' are invoked when an IO space
   is about to be closed. Note that a close_pre hook can prevent the
   closing operation to be performed by raising an exception.

   The functions in `ios_close_hook' are invoked when an IO space has
   been closed.

   The functions in `ios_set_hook' are invoked when an IO space
   becomes the current IO space.

   All the hooks above get the id of an IO space as arguments.  The
   different io* built-ins can be then used by the handlers in order
   to fetch additional properties of the IO space.  */

immutable type IOS_Hook_Fn = (int<32>)void;

immutable var ios_open_hook = IOS_Hook_Fn[]();
immutable var ios_close_pre_hook = IOS_Hook_Fn[]();
immutable var ios_close_hook = IOS_Hook_Fn[]();
immutable var ios_set_hook = IOS_Hook_Fn[]();

immutable fun _pkl_run_ios_open_hook = (int<32> ios) void:
{
  for (f in ios_open_hook)
    f (ios);
}

immutable fun _pkl_run_ios_close_pre_hook = (int<32> ios) void:
{
  for (f in ios_close_pre_hook)
    f (ios);
}

immutable fun _pkl_run_ios_close_hook = (int<32> ios) void:
{
  for (f in ios_close_hook)
    f (ios);
}

immutable fun _pkl_run_ios_set_hook = (int<32> ios) void:
{
  for (f in ios_set_hook)
    f (ios);
}

/* Poke programming interface to handle IO spaces.  */

immutable fun get_ios = int<32>:
{
  var ios = asm int<32>: ("pushios");

  if (ios < 0)
    raise E_no_ios;
  return ios;
}

immutable fun set_ios = (int<32> ios) int<32>:
{
  asm ("popios" :: ios);
  _pkl_run_ios_set_hook (ios);
  /* Always return `true' to facilitate using this function
     in struct constraint expressions.  */
  return 1;
}

immutable fun iosize = (int<32> ios = get_ios) offset<uint<64>,8>:
{
  return asm offset<uint<64>,8>: ("iosize; nip" : ios);
}

immutable fun iohandler = (int<32> ios = get_ios) string:
{
  return asm string: ("iohandler; nip" : ios);
}

immutable fun ioflags = (int<32> ios = get_ios) uint<64>:
{
  return asm uint<64>: ("ioflags; nip" : ios);
}

immutable fun iobias = (int<32> ios = get_ios) offset<uint<64>,1>:
{
  return asm offset<uint<64>,1>: ("iogetb; nip" : ios);
}

immutable fun iolist = int<32>[]:
{
  var n = asm uint<64>: ("ionum"),
      a = int<32>[n] ();

  for (var i = 0UL; i < n; ++i)
    a[i] = asm int<32>: ("ioref; nip" : i);
  return a;
}

immutable fun iosearch = (string handler) int<32>:
{
  for (ios in iolist)
    if (iohandler (ios) == handler)
      return ios;

  raise E_no_ios;
}

immutable fun iosetbias = (offset<uint<64>,1> bias = 0#1, int<32> ios = get_ios) void:
{
  asm ("iosetb; drop" :: bias, ios);
}

immutable fun open = (string handler, uint<64> flags = 0) int<32>:
{
  var set_ios_p = get_ios ?! E_no_ios;
  var ios = asm int<32>: ("open" : handler, flags);

  if (ios >= 0)
    ;
  else if (ios == -3)
    raise Exception { code = EC_io_flags,
                      msg = "insufficient permissions or device doesn't exist" };
  else if (ios == -5)
    raise E_eof;
  else if (ios == -6)
    raise Exception { code = EC_inval,
                      msg = "invalid arguments passed to `open'" };
  else if (ios == -7)
    raise Exception { code = EC_io,
                      msg = "IO space already opened" };
  else
    raise E_io;

  _pkl_run_ios_open_hook (ios);
  if (set_ios_p)
    _pkl_run_ios_set_hook (ios);

  return ios;
}

immutable fun close = (int<32> ios) void:
{
  _pkl_run_ios_close_pre_hook (ios);
  asm ("close
        bn .done
        raise
      .done:
        drop" :: ios);
  _pkl_run_ios_close_hook (ios);
}

/* Return whether the given value is integral, i.e. if it is
   either a PVM int, uint, long or ulong.  */

immutable fun _pkl_any_integral_p = (any v) int<32>:
{
  return (asm int<32>: ("typof; nip; tyisi; nip" : v)
          || asm int<32>: ("typof; nip; tyisiu; nip" : v)
          || asm int<32>: ("typof; nip; tyisl; nip" : v)
          || asm int<32>: ("typof; nip; tyislu; nip" : v));
}

/* Multiply two uint<64> and return an array of two elements containing
   the hi and lo part of the resulting uint<128> number.  This uses the
   Hacker's Delight 32x32->64 algorithm.  */

immutable fun _pkl_64x64_128 = (uint<64> a, uint<64> b) uint<64>[2]:
{
  var a1 = (a & 0xffff_ffff);
  var b1 = (b & 0xffff_ffff);
  var t = (a1 * b1);
  var w3 = (t & 0xffff_ffff);
  var k = (t .>> 32);

  a .>>= 32;
  t = (a * b1) + k;
  k = (t & 0xffff_ffff);

  var w1 = (t .>> 32);

  b .>>= 32;
  t = (a1 * b) + k;
  k = (t .>> 32);

  return [(a * b) + w1 + k, (t <<.32) + w3];
}

/* The following table is used by _pkl_eq_integral in order to
   dispatch equality operations without using slow branches.

   The array takes as indices the PVM type of the operands,
   encoded the following way:

   [op1type]       [op2type]
       |               |
       +- 0: int       +- 0: int
       +- 1: uint      +- 1: uint
       +- 2: long      +- 2: long
       +- 3: ulong     +- 3: ulong  */

immutable var _pkl_eq_integral_dispatch_table
  = [
      [
        /* int, int */
        lambda (any i1, any i2) int<32>:
          {
            return asm int<32>: ("eqi; nip2" : i1, i2);
          },
        /* int, uint */
        lambda (any i1, any i2) int<32>:
          {
            var i1u32 = asm uint<32>: ("itoiu 32; nip" : i1);
            return asm int<32>: ("eqiu; nip2" : i1u32, i2);
          },
        /* int, long */
        lambda (any i1, any i2) int<32>:
          {
            var i1i64 = asm int<64>: ("itol 64; nip" : i1);
            return asm int<32>: ("eql; nip2" : i1i64, i2);
          },
        /* int, ulong */
        lambda (any i1, any i2) int<32>:
          {
            var i1u64 = asm uint<64>: ("itolu 64; nip" : i1);
            return asm int<32>: ("eqlu; nip2" : i1u64, i2);
          },
      ],
      [
        /* uint, int */
        lambda (any i1, any i2) int<32>:
          {
            var i2u32 = asm uint<32>: ("itoiu 32; nip" : i2);
            return asm int<32>: ("eqiu; nip2" : i1, i2u32);
          },
        /* uint, uint */
        lambda (any i1, any i2) int<32>:
          {
            return asm int<32>: ("eqiu; nip2" : i1, i2);
          },
        /* uint, long */
        lambda (any i1, any i2) int<32>:
          {
            var i1i64 = asm int<64>: ("iutol 64; nip" : i1);
            return asm int<32>: ("eql; nip2" : i1i64, i2);
          },
        /* uint, ulong */
        lambda (any i1, any i2) int<32>:
          {
            var i1u64 = asm uint<64>: ("iutolu 64; nip" : i1);
            return asm int<32>: ("eqlu; nip2" : i1u64, i2);
          },
      ],
      [
        /* long, int */
        lambda (any i1, any i2) int<32>:
          {
            var i2l64 = asm int<64>: ("itol 64; nip" : i2);
            return asm int<32>: ("eql; nip2" : i1, i2l64);
          },
        /* long, uint */
        lambda (any i1, any i2) int<32>:
          {
            var i2l64 = asm int<64>: ("iutol 64; nip" : i2);
            return asm int<32>: ("eql; nip2" : i1, i2l64);
          },
        /* long, long */
        lambda (any i1, any i2) int<32>:
          {
            return asm int<32>: ("eql; nip2" : i1, i2);
          },
        /* long, ulong */
        lambda (any i1, any i2) int<32>:
          {
            var i1u64 = asm uint<64>: ("ltolu 64; nip" : i1);
            return asm int<32>: ("eqlu; nip2" : i1u64, i2);
          },
      ],
      [
        /* ulong, int */
        lambda (any i1, any i2) int<32>:
          {
            var i2lu64 = asm uint<64>: ("itolu 64; nip" : i2);
            return asm int<32>: ("eqlu; nip2" : i1, i2lu64);
          },
        /* ulong, uint */
        lambda (any i1, any i2) int<32>:
          {
            var i2lu64 = asm uint<64>: ("iutolu 64; nip" : i2);
            return asm int<32>: ("eqlu; nip2" : i1, i2lu64);
          },
        /* ulong, long */
        lambda (any i1, any i2) int<32>:
          {
            var i2lu64 = asm uint<64>: ("ltolu 64; nip" : i2);
            return asm int<32>: ("eqlu; nip2" : i1, i2lu64);
          },
        /* ulong, ulong */
        lambda (any i1, any i2) int<32>:
          {
            return asm int<32>: ("eqlu; nip2" : i1, i2);
          },
      ],
    ];

/* Determine whether two given integral values are equal.  */

immutable fun _pkl_eq_integral = (any i1, any i2) int<32>:
{
  var i1idx = (asm int<32>: ("typof; nip; tyisi; nip" : i1)
               + asm int<32>: ("typof; nip; tyisiu; nip" : i1) * 2
               + asm int<32>: ("typof; nip; tyisl; nip" : i1) * 3
               + asm int<32>: ("typof; nip; tyislu; nip" : i1) * 4) - 1;
  var i2idx = (asm int<32>: ("typof; nip; tyisi; nip" : i2)
               + asm int<32>: ("typof; nip; tyisiu; nip" : i2) * 2
               + asm int<32>: ("typof; nip; tyisl; nip" : i2) * 3
               + asm int<32>: ("typof; nip; tyislu; nip" : i2) * 4) - 1;

  return _pkl_eq_integral_dispatch_table[i1idx][i2idx](i1, i2);
}

/* Determine whether two offset values of arbitrary magnitude and
   unit are equal.  */

immutable fun _pkl_eq_offset = (any v1, any v2) int<32>:
{
  fun abs_to_u64 = (any v) uint<64>:
  {
    if (asm int<32>: ("typof; nip; tyisi; nip" : v))
      {
        var i64 = asm int<64>: ("itol 64; nip" : v);
        return i64 < 0 ? -i64 : i64;
      }
    else if (asm int<32>: ("typof; nip; tyisiu; nip" : v))
      return asm uint<64>: ("iutolu 64; nip" : v);
    else if (asm int<32>: ("typof; nip; tyisl; nip" : v))
      {
        var i64 = asm int<64>: ("ltol 64; nip" : v);
        return i64 < 0 ? -i64 : i64;
      }
    else if (asm int<32>: ("typof; nip; tyislu; nip" : v))
      return asm uint<64>: ("lutolu 64; nip" : v);

    /* Unreachable.  */
    assert (0, "internal run-time error in _pkl_eq_any.eq_offset.abs_to_u64");
  }

  var v1_magnitude = asm any: ("ogetm; nip" : v1);
  var v1_unit = asm uint<64>: ("ogetu; nip" : v1);
  var v2_magnitude = asm any: ("ogetm; nip" : v2);
  var v2_unit = asm uint<64>: ("ogetu; nip" : v2);

  /* If the units of both offsets are equal, then we got it easy: just
     compare the magnitudes.  */
  if (v1_unit == v2_unit) return
     _pkl_eq_integral (v1_magnitude, v2_magnitude);

  /* Convert the absolute value of the magnitudes to uint<64>  */
  var v1_magnitude_u64 = abs_to_u64 (v1_magnitude);
  var v2_magnitude_u64 = abs_to_u64 (v2_magnitude);

  /* Now normalize them to bits by multiplying them by their
     respective units.  But we gotta do this in 128-bit arithmetic to
     avoid a possible overflow.  */
  var v1_normalized = v1_unit == 1
                      ? [0UL, v1_magnitude_u64]
                      : _pkl_64x64_128 (v1_magnitude_u64, v1_unit);
  var v2_normalized = v2_unit == 1
                      ? [0UL, v2_magnitude_u64]
                      : _pkl_64x64_128 (v2_magnitude_u64, v2_unit);

  /* Compare and be done.  */
  return v1_normalized == v2_normalized;
}

/* Determine whether two given string values are equal.  */

immutable fun _pkl_eq_string = (any v1, any v2) int<32>:
{
  return asm int<32>: ("eqs; nip2" : v1, v2);
}

/* Determine whether two given `any' values are equal.  */

immutable fun _pkl_eq_any = (any v1, any v2) int<32>:
{
  fun handle_array = int<32>:
  {
    var v1_len = asm uint<64>: ("sel; nip" : v1);
    var v2_len = asm uint<64>: ("sel; nip" : v2);

    /* First check the length.  */
    if (v1_len != v2_len)
      return 0;

    /* Check the elements.  */
    for (var i = 0UL; i < v1_len; ++i)
      if (!_pkl_eq_any (v1'elem (i), v2'elem (i)))
        return 0;

    return 1;
  }

  fun handle_struct = int<32>:
  {
    fun struct_type_name = (any val) string:
    {
      return asm string: ("typof
                      tysctgetn
                      nip2
                      bn .namenull
                      nip
                      ba .done
                    .namenull:
                      drop
                    .done:" : "", val);
    }

    var v1_len = asm uint<64>: ("sel; nip" : v1);
    var v2_len = asm uint<64>: ("sel; nip" : v2);

    /* First make sure both struct types have the
       same name.  */
    if (struct_type_name (v1) != struct_type_name (v2))
      return 0;

    /* Now check the length.  This accommodates optional
       fields and the like.  */
    if (v1_len != v2_len)
      return 0;

    /* Check the elements.  */
    for (var i = 0UL; i < v1_len; ++i)
      if (v1'ename (i) != v2'ename (i)
          || !_pkl_eq_any (v1'elem (i), v2'elem (i)))
        return 0;

    return 1;
  }

  if (_pkl_any_integral_p (v1) && _pkl_any_integral_p (v2))
    /* Integrals.  */
    return _pkl_eq_integral (v1, v2);
  else if (asm int<32>: ("typof; nip; tyiso; nip" : v1)
           && asm int<32>: ("typof; nip; tyiso; nip" : v2))
    /* Offsets.  */
    return _pkl_eq_offset (v1, v2);
  else if (asm int<32>: ("typof; nip; tyiss; nip" : v1)
           && asm int<32>: ("typof; nip; tyiss; nip" : v2))
    /* Strings.  */
    return _pkl_eq_string (v1, v2);
  else if (asm int<32>: ("typof; nip; tyisa; nip" : v1)
           && asm int<32>: ("typof; nip; tyisa; nip" : v2))
    /* Arrays.  */
    return handle_array;
  else if (asm int<32>: ("typof; nip; tyissct; nip" : v1)
           && asm int<32>: ("typof; nip; tyissct; nip" : v2))
    /* Structs.  */
    return handle_struct;
  else
    return 0;
}

/* Printer and formatter for values of type `any'.  */

immutable type _Pkl_Print_Format_Ctx =
  struct
  {
    (string)void emit;
    (string)void begin_class;
    (string)void end_class;
    int<32> pretty_print_p;
  };

immutable fun _pkl_print_format_any = (any val,
                                       _Pkl_Print_Format_Ctx ctx,
                                       int<32> depth,
                                       int<32> obase = vm_obase,
                                       int<32> only_type_name = 0) void:
{
  fun lutos = (uint<64> i, int<32> base, int<32> padbits = 0) string:
  {
    var chars = "0123456789abcdef";
    var s = "";

    assert (base <= 16);
    if (i == 0)
      s = "0";

    while (i > 0)
      {
        s = chars[i % base] as string + s;
        i = i / base;
      }

    if (base != 10 && padbits > 0)
      {
        var bits_per_digit = (base == 16 ? 4
                              : base == 8 ? 3
                              : base == 2 ? 1
                              : 0);
        var num_digits = padbits /^ bits_per_digit;

        while (s'length < num_digits)
          s = "0" + s;
      }

    return s;
  }

  fun handle_type = void:
  {
    ctx.begin_class ("type");

    var is_int_p = asm int<32>: ("tyisi; nip" : val),
        is_uint_p = asm int<32>: ("tyisiu; nip" : val),
        is_long_p = asm int<32>: ("tyisl; nip" : val),
        is_ulong_p = asm int<32>: ("tyislu; nip" : val);

    if (is_int_p || is_uint_p || is_long_p || is_ulong_p)
      {
        var sign_p = asm int<32>: ("tyigetsg; nip" : val);
        var width = asm uint<64>: ("tyigetsz; nip" : val);

        ctx.emit ((sign_p ? "" : "u") + "int<" + lutos (width, 10) + ">");
      }
    else if (asm int<32>: ("tyiso; nip" : val))
      {
        var base_type = asm any: ("tyogetm; nip" : val),
            unit_in_bits = asm uint<64>: ("tyogetu; nip" : val);
        var ref_type = asm any: ("tyogetrt; nip" : val);

        ctx.emit ("offset<");
        _pkl_print_format_any (base_type, ctx, depth);
        ctx.emit ("," + lutos (unit_in_bits, 10));
        if (asm int<32>: ("nn; nip" : ref_type))
          {
            ctx.emit (",");
            _pkl_print_format_any (ref_type, ctx, depth, obase, 1);
          }
        ctx.emit (">");
      }
    else if (asm int<32>: ("tyiss; nip" : val))
      ctx.emit ("string");
    else if (asm int<32>: ("tyisv; nip" : val))
      ctx.emit ("void");
    else if (asm int<32>: ("tyisa; nip" : val))
      {
        var bound = asm any: ("tyagetb; nip; call" : val);

        _pkl_print_format_any (asm any: ("tyagett; nip" : val), ctx, depth);
        ctx.emit ("[");
        if (!asm int<32>: ("nnn; nip" : bound))
          _pkl_print_format_any (bound, ctx, depth);
        ctx.emit ("]");
      }
    else if (asm int<32>: ("tyissct; nip" : val))
      {
        var nfields = asm uint<64>: ("tysctgetnf; nip" : val);
        var type_name
          = asm string: ("typof
                          tysctgetn
                          nip2
                          bn .namenull
                          nip
                          ba .done
                        .namenull:
                          drop
                        .done:"
                         : "", val );

        if (type_name != "")
          {
            ctx.emit (type_name);
            if (only_type_name)
              {
                ctx.end_class ("type");
                return;
              }
          }
        else
          ctx.emit ("struct");

        ctx.emit (" {");
        for (var i = 0UL; i < nfields; ++i)
          {
            var maybe_fname = asm any: ("tysctgetfn; nip2" : val, i);
            var ftype = asm any: ("tysctgetft; nip2" : val, i);

            if (i != 0UL)
              ctx.emit (" ");
            _pkl_print_format_any (ftype, ctx, depth);
            if (!asm int<32>: ("nnn; nip" : maybe_fname))
              ctx.emit (" " + (maybe_fname as string));
            ctx.emit (";");
          }
        ctx.emit ("}");
      }
    else if (asm int<32>: ("tyisc; nip" : val))
      {
        assert (
          0,
          "Unreachable reached! (There's no PVM type for closures (for now)!)");
      }

    ctx.end_class ("type");
  }
  fun handle_integral = (int<32> long_p, int<32> signed_p) void:
  {
    var bits = asm uint<64>: ("siz; nip" : val);
    var int_suffix = (bits == 4 ? "N"
                      : bits == 8 ? "B"
                      : bits == 16 ? "H"
                      : bits == 64 ? "L"
                      : bits == 1 ? "T"
                      : "");
    var uval = 0UL;

    fun emit_int_prefix = void:
    {
      if (bits != 32 && int_suffix == "")
        {
          if (signed_p)
            ctx.emit ("(int<");
          else
            ctx.emit ("(uint<");
          ctx.emit (lutos (bits, 10));
          ctx.emit (">) ");
        }
    }

    ctx.begin_class ("integer");

    if (signed_p)
      {
        var ival = (long_p ? asm int<64>: ("ltol 64; nip" : val)
                           : asm int<64>: ("itol 64; nip" : val));

        emit_int_prefix;
        if (ival < 0 && obase == 10)
          {
            ctx.emit ("-");
            uval = -ival as uint<64>;
          }
        else
          {
            uval = ival as uint<64>;
            if (bits < 64)
              uval &= (1UL <<. bits) - 1;
          }
      }
    else
      {
        uval = (long_p ? asm uint<64>: ("lutolu 64; nip" : val)
                       : asm uint<64>: ("iutolu 64; nip" : val));

        emit_int_prefix;
        if (bits != 1 && (bits == 32 || int_suffix != ""))
          int_suffix = "U" + int_suffix;
      }

    ctx.emit (_pkl_base_prefix (obase));
    ctx.emit (lutos (uval, obase, bits));
    ctx.emit (int_suffix);
    ctx.end_class ("integer");
  }

  fun handle_offset = void:
  {
    var offset_magnitude = asm any: ("ogetm; nip" : val);
    var offset_unit = asm uint<64>: ("ogetu; nip" : val);
    var offset_unit_name = _pkl_unit_name (offset_unit);

    ctx.begin_class ("offset");
    _pkl_print_format_any (offset_magnitude, ctx, depth);
    ctx.emit ("#");
    if (offset_unit_name != "")
      ctx.emit (offset_unit_name);
    else
      ctx.emit (lutos (offset_unit, 10));
    ctx.end_class ("offset");
  }

  fun handle_string = void:
  {
    ctx.begin_class ("string");
    ctx.emit ("\""
              + _pkl_escape_string (val as string)
              + "\"");
    ctx.end_class ("string");
  }

  fun handle_array = void:
  {
    var oacutoff = vm_oacutoff;
    var sel = asm uint<64>: ("sel; nip" : val);

    ctx.begin_class ("array");
    ctx.emit ("[");
    for (var n = 0; n < sel; ++n)
      {
        if (n != 0)
          ctx.emit (",");

        /* Note an oacutoff of 0 means no limit.  */
        if (oacutoff != 0 && n >= oacutoff)
          {
            ctx.emit ("...");
            break;
          }
        _pkl_print_format_any (val'elem (n), ctx, depth);

        /* Print element offset if required.  */
        if (vm_omaps)
          {
            var elem_offset = val'eoffset (n);

            ctx.emit (" @ ");
            if (elem_offset % 1#8 == 0#1)
              _pkl_print_format_any (elem_offset as offset<uint<64>,8>, ctx, depth);
            else
              _pkl_print_format_any (elem_offset, ctx, depth);
          }
      }
    ctx.emit ("]");

    /* Print map info if required.  */
    if (vm_omaps)
      {
        var boff = asm uint<64>: ("mgeto; nip" : val);

        ctx.emit (" @ ");
        if (boff % 8 == 0)
          _pkl_print_format_any (boff#1 as offset<uint<64>,8>, ctx, depth);
        else
          _pkl_print_format_any (boff#1, ctx, depth);
      }

    ctx.end_class ("array");
  }

  fun handle_struct = void:
  {
    fun indent_if_tree = (int<32> depth) void:
    {
      if (vm_omode == VM_OMODE_TREE)
        {
          var istep = asm int<32>: ("pushoi");
          var s = " " * (1 + istep * depth);

          __pkl_unsafe_string_set (s, 0, "\n");
          ctx.emit (s);
        }
    }

    /* Use the struct pretty-printer, if it has one defined.  */
    if (ctx.pretty_print_p
        && vm_opprint
        && asm int<32>: ("srefmnt; nn; nip3" : val, "_print"))
    {
      asm ("srefmnt; nip; call; drop" :: val, "_print");
      return;
    }

    var struct_type_name
      = asm string: ("typof
                      tysctgetn
                      nip2
                      bn .namenull
                      nip
                      ba .done
                   .namenull:
                      drop
                   .done:"
                     : "struct", val );

    ctx.begin_class ("struct");
    ctx.begin_class ("struct-type-name");
    ctx.emit (struct_type_name);
    ctx.end_class ("struct-type-name");

    /* Stop here if we are past the maximum depth configured in
       the VM.  */
    var odepth = vm_odepth;
    if (odepth != 0 && depth >= odepth)
      {
        ctx.emit (" {...}");
        ctx.end_class ("struct");
        return;
      }

    ctx.emit (" {");

    /* Emit struct fields.  */
    var num_fields = asm uint<64>: ("sel; nip" : val);
    for (var n = 0UL; n < num_fields; ++n)
      {
        try
          {
            var field = val'elem (n);
            var field_name = val'ename (n);

            indent_if_tree (depth + 1);
            if (field_name != "")
              {
                ctx.begin_class ("struct-field-name");
                ctx.emit (field_name);
                ctx.end_class ("struct-field-name");
                ctx.emit ("=");
              }

            if (ctx.pretty_print_p
                && vm_opprint
                && field_name != ""
                && asm int<32>: ("srefmnt; nn; nip3" : val, "_print_" + field_name))
              {
                /* Call the field pretty-printer.  */
                asm ("srefmnt; nip; call; drop" :: val, "_print_" + field_name);
              }
            else
              _pkl_print_format_any (field, ctx, depth + 1);

            /* Print field offset if required.  */
            if (vm_omaps)
              {
                var field_offset = val'eoffset (n);

                ctx.emit (" @ ");
                if (field_offset % 1#8 == 0#1)
                  _pkl_print_format_any (field_offset as offset<uint<64>,8>, ctx, depth + 1);
                else
                  _pkl_print_format_any (field_offset, ctx, depth + 1);
              }

            if (n != num_fields - 1)
              ctx.emit (",");
          }
        catch if E_elem { ++num_fields; } /* Absent field.  */
      }

    indent_if_tree (depth);
    ctx.emit ("}");

    /* Print struct offset if required.  */
    if (vm_omaps)
      {
        var boff = asm uint<64>: ("mgeto; nip" : val);

        ctx.emit (" @ ");
        if (boff % 8 == 0)
          _pkl_print_format_any (boff#1 as offset<uint<64>,8>, ctx, depth);
        else
          _pkl_print_format_any (boff#1, ctx, depth);
      }

    ctx.end_class ("struct");
  }

  if (asm int<32>: ("nnn; nip" : val))
    ctx.emit ("null");
  else if (asm int<32>: ("isty; nip" : val))
    handle_type;
  else if (asm int<32>: ("typof; nip; nnn; nip" : val))
    {
      var closure_name = asm string: ("cgetn
                                       bn .noname
                                       nip2
                                       ba .done
                                     .noname:
                                       drop2
                                     .done:" : "", val);
      ctx.begin_class ("special");
      if (closure_name == "")
        ctx.emit ("#<closure>");
      else
        ctx.emit ("#<closure:" + closure_name + ">");
      ctx.end_class ("special");
    }
  else if (asm int<32>: ("typof; nip; tyisi; nip" : val))
    handle_integral :long_p 0 :signed_p 1;
  else if (asm int<32>: ("typof; nip; tyiso; nip" : val))
    handle_offset;
  else if (asm int<32>: ("typof; nip; tyisl; nip" : val))
    handle_integral :long_p 1 :signed_p 1;
  else if (asm int<32>: ("typof; nip; tyisiu; nip" : val))
    handle_integral :long_p 0 :signed_p 0;
  else if (asm int<32>: ("typof; nip; tyislu; nip" : val))
    handle_integral :long_p 1 :signed_p 0;
  else if (asm int<32>: ("typof; nip; tyiss; nip" : val))
    handle_string;
  else if (asm int<32>: ("typof; nip; tyisa; nip" : val))
    handle_array;
  else if (asm int<32>: ("typof; nip; tyissct; nip" : val))
    handle_struct;
  else
    {
      ctx.begin_class ("special");
      ctx.emit ("#<unknown>");
      ctx.end_class ("special");
    }
}

immutable fun _pkl_print_any = (any val, int<32> depth = 0) void:
{
  var ctx
    = _Pkl_Print_Format_Ctx {
        emit = lambda (string s) void: { print s; },
        begin_class = lambda (string c) void: { term_begin_class (c); },
        end_class = lambda (string c) void: { term_end_class (c); },
        pretty_print_p = 1,
      };

  _pkl_print_format_any (val, ctx, depth);
}

immutable fun _pkl_format_any = (any val, int<32> depth = 0) string:
{
  var result = "";
  var ctx
    = _Pkl_Print_Format_Ctx {
        emit = lambda (string s) void: { result += s; },
        /* XXX use string properties from classes.  */
     };

  _pkl_print_format_any (val, ctx, depth);
  return result;
}

/**** Set the default load path ****/

immutable var load_path = "";

/* First, add the system-wide locations.  */

try load_path = getenv ("POKEDATADIR");
catch if E_inval { load_path = "%DATADIR%"; }

/* Add the directories prescribed by the XDG Base Directory
   Specification as described in
   https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html */

try load_path = getenv ("XDG_DATA_HOME") + ":" + load_path;
catch if E_inval {
  try load_path = getenv ("HOME") + "/.local/share/poke:" + load_path;
  catch if E_inval {}
}

try load_path = getenv ("XDG_DATA_DIRS") + ":" + load_path;
catch if E_inval { }

/* Add the directories in POKE_LOAD_PATH, if defined.  */
try load_path = getenv ("POKE_LOAD_PATH") + ":" + load_path;
catch if E_inval { }
