Rosetta Code

Compiler/virtual machine interpreter: Difference between revisions

Page Discussion

Compiler/virtual machine interpreter (view source)

Revision as of 18:58, 14 April 2022

31,949 bytes added ,  2 years ago
→‎{{header|Nim}}
Line 6,956:
}
</lang>
 
=={{header|Mercury}}==
{{works with|Mercury|20.06.1}}
 
 
In the hope of achieving good speed, this implementation takes advantage of Mercury's support for signed and unsigned fixed-width integer types.
 
 
<lang Mercury>%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% The Rosetta Code Virtual Machine, in Mercury.
%%%
%%% (This particular machine is arbitrarily chosen to be big-endian.)
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
:- module vm.
 
:- interface.
:- import_module io.
:- pred main(io::di, io::uo) is det.
 
:- implementation.
:- import_module array.
:- import_module bool.
:- import_module char.
:- import_module exception.
:- import_module int.
:- import_module int32.
:- import_module list.
:- import_module string.
:- import_module uint.
:- import_module uint8.
:- import_module uint32.
 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% uint32 operations.
%%%
 
:- func twos_cmp(uint32) = uint32.
:- mode twos_cmp(in) = out is det.
:- pragma inline(twos_cmp/1).
twos_cmp(U) = NegU :-
(NegU = (\U) + 1_u32).
 
:- func unsigned_add(uint32, uint32) = uint32.
:- mode unsigned_add(in, in) = out is det.
:- pragma inline(unsigned_add/2).
unsigned_add(U, V) = U_plus_V :-
(U_plus_V = U + V).
 
:- func unsigned_sub(uint32, uint32) = uint32.
:- mode unsigned_sub(in, in) = out is det.
:- pragma inline(unsigned_sub/2).
unsigned_sub(U, V) = U_minus_V :-
(U_minus_V = U - V).
 
:- func signed_mul(uint32, uint32) = uint32.
:- mode signed_mul(in, in) = out is det.
:- pragma inline(signed_mul/2).
signed_mul(U, V) = UV :-
UV = cast_from_int32(cast_from_uint32(U) * cast_from_uint32(V)).
 
:- func signed_quot(uint32, uint32) = uint32.
:- mode signed_quot(in, in) = out is det.
:- pragma inline(signed_quot/2).
signed_quot(U, V) = U_quot_V :- % Truncation towards zero.
U_quot_V = cast_from_int32(cast_from_uint32(U)
// cast_from_uint32(V)).
 
:- func signed_rem(uint32, uint32) = uint32.
:- mode signed_rem(in, in) = out is det.
:- pragma inline(signed_rem/2).
signed_rem(U, V) = U_rem_V :- % Truncation towards zero, sign of U.
U_rem_V = cast_from_int32(cast_from_uint32(U)
rem cast_from_uint32(V)).
 
:- func signed_lt(uint32, uint32) = uint32.
:- mode signed_lt(in, in) = out is det.
:- pragma inline(signed_lt/2).
signed_lt(U, V) = U_lt_V :-
if (int32.cast_from_uint32(U) < int32.cast_from_uint32(V))
then (U_lt_V = 1_u32)
else (U_lt_V = 0_u32).
 
:- func signed_le(uint32, uint32) = uint32.
:- mode signed_le(in, in) = out is det.
:- pragma inline(signed_le/2).
signed_le(U, V) = U_le_V :-
if (int32.cast_from_uint32(U) =< int32.cast_from_uint32(V))
then (U_le_V = 1_u32)
else (U_le_V = 0_u32).
 
:- func signed_gt(uint32, uint32) = uint32.
:- mode signed_gt(in, in) = out is det.
:- pragma inline(signed_gt/2).
signed_gt(U, V) = U_gt_V :-
U_gt_V = signed_lt(V, U).
 
:- func signed_ge(uint32, uint32) = uint32.
:- mode signed_ge(in, in) = out is det.
:- pragma inline(signed_ge/2).
signed_ge(U, V) = U_ge_V :-
U_ge_V = signed_le(V, U).
 
:- func unsigned_eq(uint32, uint32) = uint32.
:- mode unsigned_eq(in, in) = out is det.
:- pragma inline(unsigned_eq/2).
unsigned_eq(U, V) = U_eq_V :-
if (U = V)
then (U_eq_V = 1_u32)
else (U_eq_V = 0_u32).
 
:- func unsigned_ne(uint32, uint32) = uint32.
:- mode unsigned_ne(in, in) = out is det.
:- pragma inline(unsigned_ne/2).
unsigned_ne(U, V) = U_ne_V :-
if (U \= V)
then (U_ne_V = 1_u32)
else (U_ne_V = 0_u32).
 
:- func logical_cmp(uint32) = uint32.
:- mode logical_cmp(in) = out is det.
:- pragma inline(logical_cmp/1).
logical_cmp(U) = NotU :-
if (U = 0_u32)
then (NotU = 1_u32)
else (NotU = 0_u32).
 
:- func logical_and(uint32, uint32) = uint32.
:- mode logical_and(in, in) = out is det.
:- pragma inline(logical_and/2).
logical_and(U, V) = U_and_V :-
if (U \= 0_u32, V \= 0_u32)
then (U_and_V = 1_u32)
else (U_and_V = 0_u32).
 
:- func logical_or(uint32, uint32) = uint32.
:- mode logical_or(in, in) = out is det.
:- pragma inline(logical_or/2).
logical_or(U, V) = U_or_V :-
if (U \= 0_u32; V \= 0_u32)
then (U_or_V = 1_u32)
else (U_or_V = 0_u32).
 
:- pred to_bytes(uint32, uint8, uint8, uint8, uint8).
:- mode to_bytes(in, out, out, out, out) is det.
:- pragma inline(to_bytes/5).
to_bytes(U, B3, B2, B1, B0) :-
(B0 = cast_from_int(cast_to_int(U /\ 0xFF_u32))),
(B1 = cast_from_int(cast_to_int((U >> 8) /\ 0xFF_u32))),
(B2 = cast_from_int(cast_to_int((U >> 16) /\ 0xFF_u32))),
(B3 = cast_from_int(cast_to_int((U >> 24) /\ 0xFF_u32))).
 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% String operations.
%%%
 
:- pred digit_u32(char, uint32).
:- mode digit_u32(in, out) is semidet.
digit_u32(('0'), 0_u32).
digit_u32(('1'), 1_u32).
digit_u32(('2'), 2_u32).
digit_u32(('3'), 3_u32).
digit_u32(('4'), 4_u32).
digit_u32(('5'), 5_u32).
digit_u32(('6'), 6_u32).
digit_u32(('7'), 7_u32).
digit_u32(('8'), 8_u32).
digit_u32(('9'), 9_u32).
 
:- pred is_not_digit(char).
:- mode is_not_digit(in) is semidet.
is_not_digit(C) :-
not is_digit(C).
 
:- pred is_not_alnum_nor_minus(char).
:- mode is_not_alnum_nor_minus(in) is semidet.
is_not_alnum_nor_minus(C) :-
not (is_alnum(C); C = ('-')).
 
:- pred det_string_to_uint32(string, uint32).
:- mode det_string_to_uint32(in, out) is det.
det_string_to_uint32(S, U) :-
to_char_list(S) = CL,
(if (det_string_to_uint32_loop(CL, 0_u32, U1))
then (U = U1)
else throw("cannot convert string to uint32")).
 
:- pred det_string_to_uint32_loop(list(char), uint32, uint32).
:- mode det_string_to_uint32_loop(in, in, out) is semidet.
det_string_to_uint32_loop([], U0, U1) :- U1 = U0.
det_string_to_uint32_loop([C | Tail], U0, U1) :-
digit_u32(C, Digit),
det_string_to_uint32_loop(Tail, (U0 * 10_u32) + Digit, U1).
 
:- pred det_signed_string_to_uint32(string, uint32).
:- mode det_signed_string_to_uint32(in, out) is det.
det_signed_string_to_uint32(S, U) :-
if prefix(S, "-")
then (det_remove_prefix("-", S, S1),
det_string_to_uint32(S1, U1),
U = twos_cmp(U1))
else det_string_to_uint32(S, U).
 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Parsing the "assembly" language.
%%%
 
:- func opcode_halt = uint8.
:- func opcode_add = uint8.
:- func opcode_sub = uint8.
:- func opcode_mul = uint8.
:- func opcode_div = uint8.
:- func opcode_mod = uint8.
:- func opcode_lt = uint8.
:- func opcode_gt = uint8.
:- func opcode_le = uint8.
:- func opcode_ge = uint8.
:- func opcode_eq = uint8.
:- func opcode_ne = uint8.
:- func opcode_and = uint8.
:- func opcode_or = uint8.
:- func opcode_neg = uint8.
:- func opcode_not = uint8.
:- func opcode_prtc = uint8.
:- func opcode_prti = uint8.
:- func opcode_prts = uint8.
:- func opcode_fetch = uint8.
:- func opcode_store = uint8.
:- func opcode_push = uint8.
:- func opcode_jmp = uint8.
:- func opcode_jz = uint8.
opcode_halt = 0_u8.
opcode_add = 1_u8.
opcode_sub = 2_u8.
opcode_mul = 3_u8.
opcode_div = 4_u8.
opcode_mod = 5_u8.
opcode_lt = 6_u8.
opcode_gt = 7_u8.
opcode_le = 8_u8.
opcode_ge = 9_u8.
opcode_eq = 10_u8.
opcode_ne = 11_u8.
opcode_and = 12_u8.
opcode_or = 13_u8.
opcode_neg = 14_u8.
opcode_not = 15_u8.
opcode_prtc = 16_u8.
opcode_prti = 17_u8.
opcode_prts = 18_u8.
opcode_fetch = 19_u8.
opcode_store = 20_u8.
opcode_push = 21_u8.
opcode_jmp = 22_u8.
opcode_jz = 23_u8.
 
:- pred opcode(string, uint8).
:- mode opcode(in, out) is semidet.
%:- mode opcode(out, in) is semidet. <-- Not needed.
opcode("halt", opcode_halt).
opcode("add", opcode_add).
opcode("sub", opcode_sub).
opcode("mul", opcode_mul).
opcode("div", opcode_div).
opcode("mod", opcode_mod).
opcode("lt", opcode_lt).
opcode("gt", opcode_gt).
opcode("le", opcode_le).
opcode("ge", opcode_ge).
opcode("eq", opcode_eq).
opcode("ne", opcode_ne).
opcode("and", opcode_and).
opcode("or", opcode_or).
opcode("neg", opcode_neg).
opcode("not", opcode_not).
opcode("prtc", opcode_prtc).
opcode("prti", opcode_prti).
opcode("prts", opcode_prts).
opcode("fetch", opcode_fetch).
opcode("store", opcode_store).
opcode("push", opcode_push).
opcode("jmp", opcode_jmp).
opcode("jz", opcode_jz).
 
:- pred parse_header(string, uint32, uint32).
:- mode parse_header(in, out, out) is det.
parse_header(S, Datasize, Strings_Count) :-
% Split S on any non-digit characters, leaving a list of the two
% runs of digits.
if (words_separator(is_not_digit, S) = [S_Datasize, S_Strings])
% Convert the runs of digits to uint32.
then (det_string_to_uint32(S_Datasize, Datasize),
det_string_to_uint32(S_Strings, Strings_Count))
else throw("cannot parse the header").
 
:- pred parse_string_literal(string, string).
:- mode parse_string_literal(in, out) is det.
parse_string_literal(S0, S) :-
% Strip leading/trailing space.
S1 = strip(S0),
% Remove the " characters.
det_remove_prefix("\"", S1, S2),
det_remove_suffix(S2, "\"") = S3,
% Deal with "\\" and "\n".
replace_escapes(S3, S).
 
:- pred replace_escapes(string, string).
:- mode replace_escapes(in, out) is det.
replace_escapes(S0, S) :-
CL0 = to_char_list(S0),
replace_escapes(CL0, [], CL),
S = from_rev_char_list(CL).
 
:- pred replace_escapes(list(char), list(char), list(char)).
:- mode replace_escapes(in, in, out) is det.
replace_escapes([], Dst0, Dst) :-
Dst = Dst0.
replace_escapes([C | Tail], Dst0, Dst) :-
if (C \= ('\\'))
then replace_escapes(Tail, [C | Dst0], Dst)
else (if (Tail = [C1 | Tail1])
then (if (C1 = ('n'))
then replace_escapes(Tail1, [('\n') | Dst0], Dst)
else if (C1 = ('\\'))
then replace_escapes(Tail1, [('\\') | Dst0], Dst)
else throw("illegal escape sequence"))
else throw("truncated escape sequence")).
 
:- pred parse_instruction(string, {uint32, uint8, uint32}).
:- mode parse_instruction(in, out) is det.
parse_instruction(S, {Address, Opcode, Arg}) :-
words_separator(is_not_alnum_nor_minus, S) = Lst,
(if parse_instr_lst(Lst, {Addr, Op, A})
then (Address = Addr, Opcode = Op, Arg = A)
else throw("cannot parse instruction")).
 
:- pred parse_instr_lst(list(string), {uint32, uint8, uint32}).
:- mode parse_instr_lst(in, out) is semidet.
parse_instr_lst([S_Address, S_Opcode],
{Address, Opcode, Arg}) :-
det_string_to_uint32(S_Address, Address),
opcode(S_Opcode, Opcode),
Arg = 0_u32.
parse_instr_lst([S_Address, S_Opcode, S_Arg | _],
{Address, Opcode, Arg}) :-
det_string_to_uint32(S_Address, Address),
opcode(S_Opcode, Opcode),
det_signed_string_to_uint32(S_Arg, Arg).
 
:- pred parse_assembly((io.text_input_stream), uint32, uint32,
array(string),
list({uint32, uint8, uint32}),
io, io).
:- mode parse_assembly(in, out, out, out, out, di, uo) is det.
parse_assembly(InpF, Datasize, Strings_Count, Strings,
Instructions, !IO) :-
read_line_as_string(InpF, Res, !IO),
(if (Res = ok(Line))
then (parse_header(Line, Datasize, Strings_Count),
read_and_parse_strings(InpF, Strings_Count, Strings, !IO),
read_and_parse_instructions(InpF, Instructions, !IO))
else if (Res = eof)
then throw("empty input")
else throw("read error")).
 
:- pred read_and_parse_strings((io.text_input_stream), uint32,
array(string), io, io).
:- mode read_and_parse_strings(in, in, out, di, uo) is det.
read_and_parse_strings(InpF, Strings_Count, Strings, !IO) :-
read_n_string_literals(InpF, Strings_Count, [], Lst, !IO),
Strings = array(Lst).
 
:- pred read_n_string_literals((io.text_input_stream), uint32,
list(string), list(string),
io, io).
:- mode read_n_string_literals(in, in, in, out, di, uo) is det.
read_n_string_literals(InpF, N, Lst0, Lst, !IO) :-
if (N = 0_u32)
then (Lst = reverse(Lst0))
else (read_line_as_string(InpF, Res, !IO),
(if (Res = ok(Line))
then (parse_string_literal(Line, S),
read_n_string_literals(InpF, N - 1_u32,
[S | Lst0], Lst, !IO))
else if (Res = eof)
then throw("premature end of input")
else throw("read error"))).
 
:- pred read_and_parse_instructions((io.text_input_stream),
list({uint32, uint8, uint32}),
io, io).
:- mode read_and_parse_instructions(in, out, di, uo) is det.
read_and_parse_instructions(InpF, Instructions, !IO) :-
read_all_instructions(InpF, [], Instructions, !IO).
 
:- pred read_all_instructions((io.text_input_stream),
list({uint32, uint8, uint32}),
list({uint32, uint8, uint32}),
io, io).
:- mode read_all_instructions(in, in, out, di, uo) is det.
read_all_instructions(InpF, Lst0, Lst, !IO) :-
read_line_as_string(InpF, Res, !IO),
(if (Res = eof)
then (Lst = Lst0) % There is no need to reverse the list.
else if (Res = ok(Line))
then (strip(Line) = S,
(if is_empty(S)
then read_all_instructions(InpF, Lst0, Lst, !IO)
else (parse_instruction(S, Instr),
read_all_instructions(InpF, [Instr | Lst0], Lst,
!IO))))
else throw("read error")).
 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Constructing the executable memory.
%%%
 
:- func greatest_address(list({uint32, uint8, uint32}),
uint32) = uint32.
:- mode greatest_address(in, in) = out is det.
greatest_address([], Min_Result) = Result :-
Result = Min_Result.
greatest_address([{Addr, _, _} | Tail], Min_Result) = Result :-
if (Min_Result < Addr)
then (Result = greatest_address(Tail, Addr))
else (Result = greatest_address(Tail, Min_Result)).
 
:- pred executable_memory(list({uint32, uint8, uint32}),
array(uint8)).
:- mode executable_memory(in, out) is det.
executable_memory(Instructions, Code) :-
greatest_address(Instructions, 0_u32) = Addr,
Code_Size = (Addr + 5_u32), % At least enough memory.
init(cast_to_int(Code_Size), opcode_halt, Code0),
fill_executable_memory(Instructions, Code0, Code).
 
:- pred fill_executable_memory(list({uint32, uint8, uint32}),
array(uint8), array(uint8)).
:- mode fill_executable_memory(in, array_di, array_uo) is det.
fill_executable_memory([], !Code) :- true.
fill_executable_memory([Instr | Tail], !Code) :-
Instr = {Address, Opcode, Arg},
Addr = cast_to_int(Address),
set(Addr, Opcode, !Code),
(if (Opcode = opcode_fetch;
Opcode = opcode_store;
Opcode = opcode_push;
Opcode = opcode_jmp;
Opcode = opcode_jz)
then (to_bytes(Arg, B3, B2, B1, B0),
% Store the argument in big-endian order.
set(Addr + 1, B3, !Code),
set(Addr + 2, B2, !Code),
set(Addr + 3, B1, !Code),
set(Addr + 4, B0, !Code))
else true),
fill_executable_memory(Tail, !Code).
 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%e
%%%
%%% Executing the code.
%%%
 
:- pred machine_add(array(uint32), array(uint32), uint32, uint32).
:- mode machine_add(array_di, array_uo, in, out) is det.
:- pragma inline(machine_add/4).
machine_add(Stack0, Stack, SP0, SP) :-
Result = unsigned_add(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
 
:- pred machine_sub(array(uint32), array(uint32), uint32, uint32).
:- mode machine_sub(array_di, array_uo, in, out) is det.
:- pragma inline(machine_sub/4).
machine_sub(Stack0, Stack, SP0, SP) :-
Result = unsigned_sub(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
 
:- pred machine_mul(array(uint32), array(uint32), uint32, uint32).
:- mode machine_mul(array_di, array_uo, in, out) is det.
:- pragma inline(machine_mul/4).
machine_mul(Stack0, Stack, SP0, SP) :-
Result = signed_mul(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
 
:- pred machine_div(array(uint32), array(uint32), uint32, uint32).
:- mode machine_div(array_di, array_uo, in, out) is det.
:- pragma inline(machine_div/4).
machine_div(Stack0, Stack, SP0, SP) :-
Result = signed_quot(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
 
:- pred machine_mod(array(uint32), array(uint32), uint32, uint32).
:- mode machine_mod(array_di, array_uo, in, out) is det.
:- pragma inline(machine_mod/4).
machine_mod(Stack0, Stack, SP0, SP) :-
Result = signed_rem(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
 
:- pred machine_lt(array(uint32), array(uint32), uint32, uint32).
:- mode machine_lt(array_di, array_uo, in, out) is det.
:- pragma inline(machine_lt/4).
machine_lt(Stack0, Stack, SP0, SP) :-
Result = signed_lt(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
 
:- pred machine_le(array(uint32), array(uint32), uint32, uint32).
:- mode machine_le(array_di, array_uo, in, out) is det.
:- pragma inline(machine_le/4).
machine_le(Stack0, Stack, SP0, SP) :-
Result = signed_le(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
 
:- pred machine_gt(array(uint32), array(uint32), uint32, uint32).
:- mode machine_gt(array_di, array_uo, in, out) is det.
:- pragma inline(machine_gt/4).
machine_gt(Stack0, Stack, SP0, SP) :-
Result = signed_gt(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
 
:- pred machine_ge(array(uint32), array(uint32), uint32, uint32).
:- mode machine_ge(array_di, array_uo, in, out) is det.
:- pragma inline(machine_ge/4).
machine_ge(Stack0, Stack, SP0, SP) :-
Result = signed_ge(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
 
:- pred machine_eq(array(uint32), array(uint32), uint32, uint32).
:- mode machine_eq(array_di, array_uo, in, out) is det.
:- pragma inline(machine_eq/4).
machine_eq(Stack0, Stack, SP0, SP) :-
Result = unsigned_eq(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
 
:- pred machine_ne(array(uint32), array(uint32), uint32, uint32).
:- mode machine_ne(array_di, array_uo, in, out) is det.
:- pragma inline(machine_ne/4).
machine_ne(Stack0, Stack, SP0, SP) :-
Result = unsigned_ne(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
 
:- pred machine_and(array(uint32), array(uint32), uint32, uint32).
:- mode machine_and(array_di, array_uo, in, out) is det.
:- pragma inline(machine_and/4).
machine_and(Stack0, Stack, SP0, SP) :-
Result = logical_and(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
 
:- pred machine_or(array(uint32), array(uint32), uint32, uint32).
:- mode machine_or(array_di, array_uo, in, out) is det.
:- pragma inline(machine_or/4).
machine_or(Stack0, Stack, SP0, SP) :-
Result = logical_or(lookup(Stack0, cast_to_int(SP - 1_u32)),
lookup(Stack0, cast_to_int(SP))),
set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
SP = SP0 - 1_u32.
 
:- pred machine_neg(array(uint32), array(uint32), uint32, uint32).
:- mode machine_neg(array_di, array_uo, in, out) is det.
:- pragma inline(machine_neg/4).
machine_neg(Stack0, Stack, SP0, SP) :-
SP = SP0,
(I = uint32.cast_to_int(SP0)),
Result = twos_cmp(lookup(Stack0, I - 1)),
set(I - 1, Result, Stack0, Stack).
 
:- pred machine_not(array(uint32), array(uint32), uint32, uint32).
:- mode machine_not(array_di, array_uo, in, out) is det.
:- pragma inline(machine_not/4).
machine_not(Stack0, Stack, SP0, SP) :-
SP = SP0,
(I = uint32.cast_to_int(SP0)),
Result = logical_cmp(lookup(Stack0, I - 1)),
set(I - 1, Result, Stack0, Stack).
 
:- pred machine_prtc((io.text_output_stream),
array(uint32), array(uint32),
uint32, uint32, io, io).
:- mode machine_prtc(in, array_di, array_uo, in, out,
di, uo) is det.
machine_prtc(OutF, Stack0, Stack, SP0, SP, !IO) :-
Stack = Stack0,
(I = uint32.cast_to_int(SP0)),
X = lookup(Stack0, I - 1),
C = (char.det_from_int(uint32.cast_to_int(X))),
(io.write_char(OutF, C, !IO)),
SP = SP0 - 1_u32.
 
:- pred machine_prti((io.text_output_stream),
array(uint32), array(uint32),
uint32, uint32, io, io).
:- mode machine_prti(in, array_di, array_uo, in, out,
di, uo) is det.
machine_prti(OutF, Stack0, Stack, SP0, SP, !IO) :-
Stack = Stack0,
(I = uint32.cast_to_int(SP0)),
(X = int32.cast_from_uint32(lookup(Stack0, I - 1))),
(io.write_int32(OutF, X, !IO)),
SP = SP0 - 1_u32.
 
:- pred machine_prts((io.text_output_stream),
array(string),
array(uint32), array(uint32),
uint32, uint32, io, io).
:- mode machine_prts(in, in, array_di, array_uo, in, out,
di, uo) is det.
machine_prts(OutF, Strings, Stack0, Stack, SP0, SP, !IO) :-
Stack = Stack0,
(I = uint32.cast_to_int(SP0)),
(K = uint32.cast_to_int(lookup(Stack0, I - 1))),
S = lookup(Strings, K),
(io.write_string(OutF, S, !IO)),
SP = SP0 - 1_u32.
 
:- func get_immediate(array(uint8), uint32) = uint32.
:- mode get_immediate(in, in) = out is det.
:- pragma inline(get_immediate/2).
get_immediate(Code, IP) = Immediate_Value :-
% Big-endian order.
I = cast_to_int(IP),
B3 = lookup(Code, I),
B2 = lookup(Code, I + 1),
B1 = lookup(Code, I + 2),
B0 = lookup(Code, I + 3),
Immediate_Value = from_bytes_be(B3, B2, B1, B0).
 
:- pred machine_fetch(array(uint32), array(uint32),
array(uint8), uint32, uint32,
array(uint32), array(uint32),
uint32, uint32).
:- mode machine_fetch(array_di, array_uo, in, in, out,
array_di, array_uo, in, out) is det.
:- pragma inline(machine_fetch/9).
machine_fetch(Data0, Data, Code, IP0, IP, !Stack, SP0, SP) :-
Data = Data0,
K = get_immediate(Code, IP0),
IP = IP0 + 4_u32,
X = lookup(Data0, cast_to_int(K)),
set(cast_to_int(SP0), X, !Stack),
SP = SP0 + 1_u32.
 
:- pred machine_store(array(uint32), array(uint32),
array(uint8), uint32, uint32,
array(uint32), array(uint32),
uint32, uint32).
:- mode machine_store(array_di, array_uo, in, in, out,
array_di, array_uo, in, out) is det.
:- pragma inline(machine_store/9).
machine_store(!Data, Code, IP0, IP, Stack0, Stack, SP0, SP) :-
Stack = Stack0,
K = get_immediate(Code, IP0),
IP = IP0 + 4_u32,
SP = SP0 - 1_u32,
X = lookup(Stack0, cast_to_int(SP)),
set(cast_to_int(K), X, !Data).
 
:- pred machine_push(array(uint8), uint32, uint32,
array(uint32), array(uint32),
uint32, uint32).
:- mode machine_push(in, in, out, array_di, array_uo, in, out) is det.
:- pragma inline(machine_push/7).
machine_push(Code, IP0, IP, !Stack, SP0, SP) :-
X = get_immediate(Code, IP0),
IP = IP0 + 4_u32,
set(cast_to_int(SP0), X, !Stack),
SP = SP0 + 1_u32.
 
:- pred machine_jmp(array(uint8), uint32, uint32).
:- mode machine_jmp(in, in, out) is det.
:- pragma inline(machine_jmp/3).
machine_jmp(Code, IP0, IP) :-
Offset = get_immediate(Code, IP0),
IP = unsigned_add(IP0, Offset).
 
:- pred machine_jz(array(uint8), uint32, uint32,
array(uint32), array(uint32),
uint32, uint32).
:- mode machine_jz(in, in, out, array_di, array_uo, in, out) is det.
:- pragma inline(machine_jz/7).
machine_jz(Code, IP0, IP, Stack0, Stack, SP0, SP) :-
Stack = Stack0,
SP = SP0 - 1_u32,
X = lookup(Stack0, cast_to_int(SP)),
(if (X = 0_u32)
then (Offset = get_immediate(Code, IP0),
IP = unsigned_add(IP0, Offset))
else (IP = IP0 + 4_u32)).
 
:- pred run_one_instruction((io.text_output_stream),
array(string),
array(uint32), array(uint32),
array(uint8), uint32, uint32,
array(uint32), array(uint32),
uint32, uint32, bool, io, io).
:- mode run_one_instruction(in, in, array_di, array_uo,
in, in, out, array_di, array_uo,
in, out, out, di, uo) is det.
run_one_instruction(OutF, Strings, !Data,
Code, IP0, IP, !Stack, !SP,
Halt, !IO) :-
%
% In the following implementation, any unrecognized instruction
% causes a HALT, just as an actual "halt" opcode would.
%
Opcode = lookup(Code, cast_to_int(IP0)),
IP1 = IP0 + 1_u32,
I = (Opcode >> 2),
J = (Opcode /\ 0x03_u8),
(if (I = 0_u8)
then (IP = IP1,
(if (J = 0_u8)
then (Halt = yes)
else if (J = 1_u8)
then (machine_add(!Stack, !SP),
Halt = no)
else if (J = 2_u8)
then (machine_sub(!Stack, !SP),
Halt = no)
else (machine_mul(!Stack, !SP),
Halt = no)))
else if (I = 1_u8)
then (Halt = no,
IP = IP1,
(if (J = 0_u8)
then machine_div(!Stack, !SP)
else if (J = 1_u8)
then machine_mod(!Stack, !SP)
else if (J = 2_u8)
then machine_lt(!Stack, !SP)
else machine_gt(!Stack, !SP)))
else if (I = 2_u8)
then (Halt = no,
IP = IP1,
(if (J = 0_u8)
then machine_le(!Stack, !SP)
else if (J = 1_u8)
then machine_ge(!Stack, !SP)
else if (J = 2_u8)
then machine_eq(!Stack, !SP)
else machine_ne(!Stack, !SP)))
else if (I = 3_u8)
then (Halt = no,
IP = IP1,
(if (J = 0_u8)
then machine_and(!Stack, !SP)
else if (J = 1_u8)
then machine_or(!Stack, !SP)
else if (J = 2_u8)
then machine_neg(!Stack, !SP)
else machine_not(!Stack, !SP)))
else if (I = 4_u8)
then (Halt = no,
(if (J = 0_u8)
then (machine_prtc(OutF, !Stack, !SP, !IO),
IP = IP1)
else if (J = 1_u8)
then (machine_prti(OutF, !Stack, !SP, !IO),
IP = IP1)
else if (J = 2_u8)
then (machine_prts(OutF, Strings, !Stack, !SP, !IO),
IP = IP1)
else machine_fetch(!Data, Code, IP1, IP, !Stack, !SP)))
else if (I = 5_u8)
then (Halt = no,
(if (J = 0_u8)
then machine_store(!Data, Code, IP1, IP, !Stack, !SP)
else if (J = 1_u8)
then machine_push(Code, IP1, IP, !Stack, !SP)
else if (J = 2_u8)
then machine_jmp(Code, IP1, IP)
else machine_jz(Code, IP1, IP, !Stack, !SP)))
else (Halt = yes, IP = IP1)).
 
:- pred run_program((io.text_output_stream), array(string),
array(uint32), array(uint32),
array(uint8), uint32, uint32,
array(uint32), array(uint32),
uint32, uint32, io, io).
:- mode run_program(in, in, array_di, array_uo,
in, in, out, array_di, array_uo,
in, out, di, uo) is det.
run_program(OutF, Strings, !Data, Code, !IP, !Stack, !SP, !IO) :-
run_one_instruction(OutF, Strings, !Data, Code, !IP, !Stack, !SP,
Halt, !IO),
(if (Halt = yes)
then true
else run_program(OutF, Strings, !Data, Code, !IP, !Stack,
!SP, !IO)).
 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
:- pred open_InpF(text_input_stream, string, io, io).
:- mode open_InpF(out, in, di, uo) is det.
open_InpF(InpF, InpF_filename, !IO) :-
if (InpF_filename = "-")
then (InpF = io.stdin_stream)
else (open_input(InpF_filename, InpF_result, !IO),
(if (InpF_result = ok(F))
then (InpF = F)
else throw("Error: cannot open " ++ InpF_filename ++
" for input"))).
 
:- pred open_OutF(text_output_stream, string, io, io).
:- mode open_OutF(out, in, di, uo) is det.
open_OutF(OutF, OutF_filename, !IO) :-
if (OutF_filename = "-")
then (OutF = io.stdout_stream)
else (open_output(OutF_filename, OutF_result, !IO),
(if (OutF_result = ok(F))
then (OutF = F)
else throw("Error: cannot open " ++ OutF_filename ++
" for output"))).
 
:- pred main_program(string, string, io, io).
:- mode main_program(in, in, di, uo) is det.
main_program(InpF_filename, OutF_filename, !IO) :-
open_InpF(InpF, InpF_filename, !IO),
open_OutF(OutF, OutF_filename, !IO),
parse_assembly(InpF, Datasize, _Strings_Count, Strings,
Instructions, !IO),
(if (InpF_filename = "-")
then true
else close_input(InpF, !IO)),
executable_memory(Instructions, Code),
init(cast_to_int(Datasize), 0_u32, Data0),
init(2048, 0_u32, Stack0), % Stack is 2048 words.
IP0 = 0_u32,
SP0 = 0_u32,
run_program(OutF, Strings, Data0, _Data, Code, IP0, _IP,
Stack0, _Stack, SP0, _SP, !IO),
(if (OutF_filename = "-")
then true
else close_output(OutF, !IO)).
 
:- pred usage_error(io, io).
:- mode usage_error(di, uo) is det.
usage_error(!IO) :-
progname("lex", ProgName, !IO),
(io.format("Usage: %s [INPUT_FILE [OUTPUT_FILE]]\n",
[s(ProgName)], !IO)),
(io.write_string(
"If INPUT_FILE is \"-\" or not present then standard input is used.\n",
!IO)),
(io.write_string(
"If OUTPUT_FILE is \"-\" or not present then standard output is used.\n",
!IO)),
set_exit_status(1, !IO).
 
main(!IO) :-
command_line_arguments(Args, !IO),
(if (Args = [])
then (InpF_filename = "-",
OutF_filename = "-",
main_program(InpF_filename, OutF_filename, !IO))
else if (Args = [F1])
then (InpF_filename = F1,
OutF_filename = "-",
main_program(InpF_filename, OutF_filename, !IO))
else if (Args = [F1, F2])
then (InpF_filename = F1,
OutF_filename = F2,
main_program(InpF_filename, OutF_filename, !IO))
else usage_error(!IO)).
 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Instructions for GNU Emacs--
%%% local variables:
%%% mode: mercury
%%% prolog-indent-width: 2
%%% end:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%</lang>
 
 
{{out}}
<pre>$ mmc -O6 --make vm && ./vm compiler-tests/count.vm
Making Mercury/int3s/vm.int3
Making Mercury/ints/vm.int
Making Mercury/cs/vm.c
Making Mercury/os/vm.o
Making vm
count is: 1
count is: 2
count is: 3
count is: 4
count is: 5
count is: 6
count is: 7
count is: 8
count is: 9</pre>
 
 
 
=={{header|Nim}}==
Chemoelectric
1,448

edits

Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/271295"