ICFP Ada virtual machine

Samuel Tardieu, 2006-08-01

The ICFP contest of this year starts with the implementation of a virtual machine. While I didn’t participate to the contest itself, I wrote one in Python and rewrote another one in Ada for performance reasons. Here is its code, released in the public domain.

The Unchecked_Conversion may look ugly, but they are the best way to get good performances out of the virtual machine. The code (155 lines including the header) shows how easy it is to write such a virtual machine in Ada.

This program has been written for a 32 bits machine, and should be endianness-agnostic.

--  ICFP Programming Contest 2006 -- Virtual Machine
--  Written by Samuel Tardieu <sam@rfc1149.net>, public domain
--  To compile: gnatmake -O3 -gnatp -fomit-frame-pointer vm
--  To run: ./vm codex.umz

with Ada.Command_Line;           use Ada.Command_Line;
with Ada.Streams.Stream_IO;      use Ada.Streams.Stream_IO;
with Ada.Text_IO;                use Ada.Text_IO;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Interfaces;                 use Interfaces;

procedure VM is

   type Arr is array (Unsigned_32 range <>) of Unsigned_32;
   type Arr_Access is access Arr;
   for Arr_Access'Size use 32;

   procedure Free is
      new Ada.Unchecked_Deallocation (Arr, Arr_Access);

   function To_Unsigned_32 is
      new Ada.Unchecked_Conversion (Arr_Access, Unsigned_32);

   function To_Access is
      new Ada.Unchecked_Conversion (Unsigned_32, Arr_Access);

   Mem0 : Arr_Access;

   Regs : array (Unsigned_32'(0) .. 7) of Unsigned_32 := (others => 0);

   PC : Unsigned_32 := 0;

   End_Of_Program : exception;
   Unknown_Opcode : exception;

   procedure Interpret_Opcode is
      Opcode     : constant Unsigned_32 := Mem0 (PC);
      Operator   : constant Unsigned_32 := Opcode / (2**28);
      A          : constant Unsigned_32 := (Opcode / 64) and 7;
      B          : constant Unsigned_32 := (Opcode / 8) and 7;
      C          : constant Unsigned_32 := Opcode and 7;
      Current_PC : constant Unsigned_32 := PC;
   begin
      if PC <= Mem0'Last then
         PC := PC + 1;
      end if;
      case Operator is
         when 0 =>
            if Regs (C) /= 0 then
               Regs (A) := Regs (B);
            end if;
         when 1 =>
            declare
               Base : constant Arr_Access := To_Access (Regs (B));
            begin
               if Base = null then
                  Regs (A) := Mem0 (Regs (C));
               else
                  Regs (A) := Base (Regs (C));
               end if;
            end;
         when 2 =>
            declare
               Base : constant Arr_Access := To_Access (Regs (A));
            begin
               if Base = null then
                  Mem0 (Regs (B)) := Regs (C);
               else
                  Base (Regs (B)) := Regs (C);
               end if;
            end;
         when 3 =>
            Regs (A) := Regs (B) + Regs (C);
         when 4 =>
            Regs (A) := Regs (B) * Regs (C);
         when 5 =>
            Regs (A) := Regs (B) / Regs (C);
         when 6 =>
            Regs (A) := not (Regs (B) and Regs (C));
         when 7 =>
            raise End_Of_Program;
         when 8 =>
            declare
               Last : Unsigned_32;
            begin
               if Regs (C) = 0 then
                  Last := 0;
               else
                  Last := Regs (C) - 1;
               end if;
               Regs (B) := To_Unsigned_32 (new Arr'(0 .. Last => 0));
            end;
         when 9 =>
            declare
               Base : Arr_Access := To_Access (Regs (C));
            begin
               Free (Base);
            end;
         when 10 =>
            Put (Character'Val (Regs (C)));
            Flush;
         when 11 =>
            declare
               X : Character;
            begin
               Get_Immediate (X);
               Put (X);
               Flush;
               Regs (C) := Character'Pos (X);
            end;
         when 12 =>
            declare
               Base : constant Arr_Access := To_Access (Regs (B));
            begin
               if Regs (B) /= 0 then
                  Free (Mem0);
                  Mem0 := new Arr'(Base.all);
               end if;
               PC := Regs (C);
            end;
         when 13 =>
            Regs ((Opcode / 2**25) and 7) := Opcode and (2**25 - 1);
         when others =>
            raise Unknown_Opcode;
      end case;
   end Interpret_Opcode;

   procedure Load is
      use Ada.Streams, Ada.Streams.Stream_IO;
      F : Ada.Streams.Stream_IO.File_Type;
      S : Stream_Element_Array (1 .. 4);
      L : Stream_Element_Offset;
   begin
      Open (F, In_File, Argument (1));
      Mem0 := new Arr (0 .. Unsigned_32 (Size (F)) / 4 - 1);
      for I in Mem0'Range loop
         Read (F, S, L);
         Mem0 (I) := Unsigned_32 (S (1)) * 2**24 +
           Unsigned_32 (S (2)) * 2**16 +
           Unsigned_32 (S (3)) * 2**8 +
           Unsigned_32 (S (4));
      end loop;
      Close (F);
   end Load;

begin
   Load;
   loop
      Interpret_Opcode;
   end loop;
exception
   when End_Of_Program =>
      null;
end VM;