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.
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 <email@example.com>, 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; array (Unsigned_32'(0) .. 7) of Unsigned_32 := (others => 0); Regs : 32 := 0; PC : Unsigned_ exception; End_Of_Program : exception; Unknown_Opcode : procedure Interpret_Opcode is constant Unsigned_32 := Mem0 (PC); Opcode : constant Unsigned_32 := Opcode / (2**28); Operator : constant Unsigned_32 := (Opcode / 64) and 7; A : constant Unsigned_32 := (Opcode / 8) and 7; B : constant Unsigned_32 := Opcode and 7; C : constant Unsigned_32 := PC; Current_PC : begin if PC <= Mem0'Last then 1; PC := PC + end if; case Operator is when 0 => if Regs (C) /= 0 then Regs (A) := Regs (B);end if; when 1 => declare constant Arr_Access := To_Access (Regs (B)); Base : begin if Base = null then Regs (A) := Mem0 (Regs (C));else Regs (A) := Base (Regs (C));end if; end; when 2 => declare constant Arr_Access := To_Access (Regs (A)); Base : 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 => not (Regs (B) and Regs (C)); Regs (A) := when 7 => raise End_Of_Program; when 8 => declare 32; Last : Unsigned_begin if Regs (C) = 0 then 0; Last := else 1; Last := Regs (C) - end if; 32 (new Arr'(0 .. Last => 0)); Regs (B) := To_Unsigned_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 Character; X : begin Get_Immediate (X); Put (X); Flush; Regs (C) := Character'Pos (X);end; when 12 => declare constant Arr_Access := To_Access (Regs (B)); Base : begin if Regs (B) /= 0 then Free (Mem0);new Arr'(Base.all); Mem0 := end if; PC := Regs (C);end; when 13 => 2**25) and 7) := Opcode and (2**25 - 1); Regs ((Opcode / 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;1 .. 4); S : Stream_Element_Array ( L : Stream_Element_Offset;begin 1)); Open (F, In_File, Argument (new Arr (0 .. Unsigned_32 (Size (F)) / 4 - 1); Mem0 := for I in Mem0'Range loop Read (F, S, L);32 (S (1)) * 2**24 + Mem0 (I) := Unsigned_32 (S (2)) * 2**16 + Unsigned_32 (S (3)) * 2**8 + Unsigned_32 (S (4)); Unsigned_end loop; Close (F);end Load; begin Load;loop Interpret_Opcode;end loop; exception when End_Of_Program => null; end VM;