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 <firstname.lastname@example.org>, 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); : Arr_Access; Mem0 : array (Unsigned_32'(0) .. 7) of Unsigned_32 := (others => 0); Regs : Unsigned_32 := 0; PC : 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 := PC + 1; PC end if; case Operator is when 0 => if Regs (C) /= 0 then (A) := Regs (B); Regs end if; when 1 => declare : constant Arr_Access := To_Access (Regs (B)); Base begin if Base = null then (A) := Mem0 (Regs (C)); Regs else (A) := Base (Regs (C)); Regs end if; end; when 2 => declare : constant Arr_Access := To_Access (Regs (A)); Base begin if Base = null then (Regs (B)) := Regs (C); Mem0 else (Regs (B)) := Regs (C); Base end if; end; when 3 => (A) := Regs (B) + Regs (C); Regs when 4 => (A) := Regs (B) * Regs (C); Regs when 5 => (A) := Regs (B) / Regs (C); Regs when 6 => (A) := not (Regs (B) and Regs (C)); Regs when 7 => raise End_Of_Program; when 8 => declare : Unsigned_32; Last begin if Regs (C) = 0 then := 0; Last else := Regs (C) - 1; Last end if; (B) := To_Unsigned_32 (new Arr'(0 .. Last => 0)); Regs end; when 9 => declare : Arr_Access := To_Access (Regs (C)); Base begin (Base); Free end; when 10 => (Character'Val (Regs (C))); Put Flush;when 11 => declare : Character; X begin (X); Get_Immediate (X); Put Flush;(C) := Character'Pos (X); Regs end; when 12 => declare : constant Arr_Access := To_Access (Regs (B)); Base begin if Regs (B) /= 0 then (Mem0); Free := new Arr'(Base.all); Mem0 end if; := Regs (C); PC end; when 13 => ((Opcode / 2**25) and 7) := Opcode and (2**25 - 1); Regs when others => raise Unknown_Opcode; end case; end Interpret_Opcode; procedure Load is use Ada.Streams, Ada.Streams.Stream_IO; : Ada.Streams.Stream_IO.File_Type; F : Stream_Element_Array (1 .. 4); S : Stream_Element_Offset; L begin (F, In_File, Argument (1)); Open := new Arr (0 .. Unsigned_32 (Size (F)) / 4 - 1); Mem0 for I in Mem0'Range loop (F, S, L); Read (I) := Unsigned_32 (S (1)) * 2**24 + Mem0 (S (2)) * 2**16 + Unsigned_32 (S (3)) * 2**8 + Unsigned_32 (S (4)); Unsigned_32 end loop; (F); Close end Load; begin Load;loop Interpret_Opcode;end loop; exception when End_Of_Program => null; end VM;