1
0

Improved bytecode output when calling a locally defined lambda.

This commit is contained in:
Jon Michael Aanes 2019-01-02 18:33:03 +01:00
parent e1f72a08ba
commit 5b508bf75c

View File

@ -13,6 +13,8 @@ let /* Booleans */
var DEBUG_PRINT_TAPE : bool := false
var DEBUG_PRINT_PARSED : bool := false
var DEBUG_PRINT_JUMPS : bool := false
var DEBUG_PRINT_MACRO : bool := true
var DEBUG_SHOW_FULL_ENVIRONMENT : bool := false
var ALLOW_TAPE_RESIZE : bool := true
@ -116,11 +118,14 @@ let /* Booleans */
type pos = { at_char: int, line_num: int }
function new_pos (line_num: int, at_char: int): pos =
pos { at_char = at_char, line_num = line_num }
function line_num (pos: pos): int = pos.line_num
function line_num (pos: pos): int =
if pos <> nil
then pos.line_num
else -3
function at_char (pos: pos): int =
if pos <> nil
then pos.at_char
else -1
else -3
function pos_delta_char (pos: pos, delta: int): pos =
new_pos( line_num(pos)
@ -128,9 +133,12 @@ let /* Booleans */
var pos_unknown : pos := new_pos(-1, -1)
var pos_preamble: pos := new_pos(-2, -2)
var pos_bad : pos := new_pos(-3, -3)
function pos_to_string (pos: pos): string =
if pos = pos_unknown
if pos <> nil
then "no position"
else if pos = pos_unknown
then "unknown position"
else if pos = pos_preamble
then "preamble"
@ -403,6 +411,13 @@ let /* Booleans */
& b.typ = type_integer
& a.val_i = b.val_i
function scheme_value_is_proper_list (ls: scheme_value): bool =
if ls = nil
then false
else ls.typ = type_nil
| ls.typ = type_pair
& scheme_value_is_proper_list(ls.val_cdr)
/* evq? See for definition:
* https://people.csail.mit.edu/jaffer/r5rs/Equivalence-predicates.html
* */
@ -594,7 +609,9 @@ let /* Booleans */
function parse_rec (): sexp_ast =
( ignore_ws()
; if is_symbol(index)
; if index >= size(str)
then (parse_error("Reached end of string"); nil)
else if is_symbol(index)
then let var start_pos := new_pos(line_number, index)
in while index < size(str) & is_symbol(index)
do index := index + 1
@ -726,7 +743,9 @@ let /* Booleans */
; print("\n")
end
in parse_rec()
in if size(str) > 0
then parse_rec()
else (parse_error("Nothing to parse. Given string empty!"); nil)
end
/**** Instructions ****/
@ -781,6 +800,7 @@ let /* Booleans */
var OPCODE_EXIT := 27
var OPCODE_EQV := 28
var OPCODE_CONCAT := 29
var OPCODE_FORGET := 32
var OPCODE_DEBUG := 31
@ -821,6 +841,7 @@ let /* Booleans */
; code(OPCODE_RET, "RET", 1, 0, 0)
; code(OPCODE_DEF, "DEF", 0, 1, 0)
; code(OPCODE_FORGET, "FORGET", 1, 0, 0)
; code(OPCODE_SETG, "SETG", 0, 1, 0)
; code(OPCODE_DEFFUN, "DEFFUN", 1, 0, 0)
; code(OPCODE_POP, "POP", 0, 0, 0)
@ -988,6 +1009,7 @@ let /* Booleans */
, pos_r = pos_r }))
; ())
function app_insn2 (insns: vm_insn_list, opcode:int, arg3: scheme_value, pos_l: pos, pos_r: pos) =
( concat_lists(insns, single_insn(vm_insn { opcode = opcode
, arg1 = 0
@ -1253,6 +1275,15 @@ let /* Booleans */
; stdfun("exit")
; app(OPCODE_EXIT, true, "")
/* Misc??? */
; stdfun("symbol?")
; app(OPCODE_TYPEOF, 0, "")
; app2(OPCODE_PUSH, int_val(type_symbol))
; app(OPCODE_NUMEQ, 0, "")
; app(OPCODE_RET, 1, "")
; std_insns
end
@ -1348,6 +1379,9 @@ let /* Booleans */
, value)
, env )
function env_pop(env: vm_env): vm_env =
env.val_cdr
function global_env_push (env: vm_env, key: string, value: vm_env_elem): vm_env =
let
in if env.val_car.val_s <> GLOBAL_ENV_SENTINEL
@ -1728,6 +1762,17 @@ let /* Booleans */
; insns_car )
end
function compile_load_of_arguments ( insns: vm_insn_list
, sexp_args: sexp_ast
, pos_l: pos
, pos_r: pos) =
if sexp_args = nil
| sexp_args.typ = type_nil
| sexp_args.val_car = nil
then ()
else ( compile_load_of_arguments(insns, sexp_args.val_cdr, pos_l, pos_r)
; app_insn(insns, OPCODE_DEF, 0, sexp_args.val_car.val_s, pos_l, pos_r) )
function compile_rec ( ast: sexp_ast
, can_tail_call: bool
, expected_type: type_type ): vm_insn_list =
@ -1744,8 +1789,13 @@ let /* Booleans */
tail_position_one( atom_to_insn(ast, ast.pos_l, ast.pos_r, expected_type)
, can_tail_call)
else if ast.val_car = nil
| ast.val_cdr = nil
then ( compile_error("Attemping to compile malformed ast", ast)
; nil )
/* If statements */
else if ast.val_car <> nil
else if ast.val_car.typ = type_symbol
& ast.val_car.val_s = "if"
then let var insns_test := compile_rec(ast.val_cdr.val_car, false, type_any)
var insns_then := compile_rec(ast.val_cdr.val_cdr.val_car, can_tail_call, type_any)
@ -1754,36 +1804,43 @@ let /* Booleans */
else tail_position_one( atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r, 0)
, can_tail_call)
var jump_then := sexp_ast_length(insns_then) + 1
var jump_else := sexp_ast_length(insns_else) + 1 + 1
var jump_then := sexp_ast_length(insns_then) + 1 + (if can_tail_call then 0 else 1)
var jump_else := sexp_ast_length(insns_else) + 1
var pos_l := ast.pos_l
var pos_r := ast.pos_r
in app_insn(insns_test, OPCODE_CSKIP, 2, "" , pos_l, pos_r)
; app_insn(insns_test, OPCODE_DGOTO, jump_else, "" , pos_l, pos_r)
; concat_lists(insns_test, insns_else)
; app_insn(insns_test, OPCODE_DGOTO, jump_then, "" , pos_l, pos_r)
in app_insn(insns_test, OPCODE_CSKIP, jump_then, "" , pos_l, pos_r)
; concat_lists(insns_test, insns_then)
; if not(can_tail_call)
then app_insn(insns_test, OPCODE_DGOTO, jump_else, "" , pos_l, pos_r)
; concat_lists(insns_test, insns_else)
; insns_test
end
/* Define statements */
else if ast.val_car <> nil & ast.val_car.val_s = "define"
else if ast.val_car.typ = type_symbol
& ast.val_car.val_s = "define"
then compile_define(ast)
/* Syntax define statements */
else if ast.val_car <> nil & ast.val_car.val_s = "define-syntax"
else if ast.val_car.typ = type_symbol
& ast.val_car.val_s = "define-syntax"
then ( compile_error("Please do not compile define-syntax", ast)
; single_insn(atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r, 0)))
/* Syntax rules expression */
/*
else if ast.val_car <> nil & ast.val_car.val_s = "syntax-rules"
then compile_syntax_rules(ast)
*/
/* Begin expressions */
else if ast.val_car <> nil & ast.val_car.val_s = "begin"
/* TODO: Implement using macroes, when those are
* available. */
else if ast.val_car.typ = type_symbol
& ast.val_car.val_s = "begin"
then let var insns := vm_insn_list { first = nil, last = nil }
var head := ast.val_cdr
@ -1798,7 +1855,8 @@ let /* Booleans */
end
/* Quote expressions */
else if ast.val_car <> nil & ast.val_car.val_s = "quote"
else if ast.val_car.typ = type_symbol
& ast.val_car.val_s = "quote"
then let var datum := ast.val_cdr.val_car
in tail_position_one( vm_insn { opcode = OPCODE_PUSH
@ -1811,7 +1869,8 @@ let /* Booleans */
end
/* Quasi-Quote expressions */
else if ast.val_car <> nil & ast.val_car.val_s = "quasiquote"
else if ast.val_car.typ = type_symbol
& ast.val_car.val_s = "quasiquote"
then let var datum := ast.val_cdr.val_car
var insns := compile_quasiquote(datum)
@ -1827,7 +1886,8 @@ let /* Booleans */
end
/* Set statements */
else if ast.val_car <> nil & ast.val_car.val_s = "set!"
else if ast.val_car.typ = type_symbol
& ast.val_car.val_s = "set!"
then let var sym := ast.val_cdr.val_car.val_s
var exp_insns := compile_rec(ast.val_cdr.val_cdr.val_car, false, type_any)
@ -1837,46 +1897,30 @@ let /* Booleans */
end
/* Lambda expressions */
else if ast.val_car <> nil & ast.val_car.val_s = "lambda"
else if ast.val_car.typ = type_symbol
& ast.val_car.val_s = "lambda"
then let var insns_body := compile_rec(ast.val_cdr.val_cdr.val_car, true, type_any)
var pos_l := ast.pos_l
var pos_r := ast.pos_r
function build_insns_arguments (args: sexp_ast, derp: vm_insn_list_link): vm_insn_list_link =
if args = nil
| args.typ = type_nil
| args.val_car = nil
then derp
else
build_insns_arguments( args.val_cdr
, vm_insn_list_link { insn = vm_insn { opcode = OPCODE_DEF
, arg1 = 0
, arg2 = args.val_car.val_s
, arg3 = nil
, pos_l = pos_l
, pos_r = pos_r }
, next = derp })
var insns_ass_args := list(build_insns_arguments(ast.val_cdr.val_car, nil))
var jump_lambda := sexp_ast_length(insns_body)
+ sexp_ast_length(insns_ass_args)
+ sexp_list_length(ast.val_cdr.val_car)
+ 1
var insns := vm_insn_list { first = nil, last = nil }
in app_insn(insns, OPCODE_DEFFUN, 2, "", pos_l, pos_r)
; app_insn(insns, OPCODE_DGOTO, jump_lambda, "" , pos_l, pos_r)
; concat_lists(insns, insns_ass_args)
; compile_load_of_arguments(insns, ast.val_cdr.val_car, pos_l, pos_r)
; concat_lists(insns, insns_body)
; tail_position(insns, can_tail_call, ast.pos_l, ast.pos_r)
; insns
end
/* Macro applications */
else if ast.val_car <> nil
& ast.val_car.typ = type_symbol
else if ast.val_car.typ = type_symbol
& ast.val_car.val_s <> ""
& env_seek_elem(env_macro, ast.val_car.val_s) <> nil
then let var stack := stack_new()
@ -1895,11 +1939,61 @@ let /* Booleans */
, ast)
; TRIGGERED_EXIT := true
; nil )
else ( vm_run(macro_tape, fun.val_i, stack, fun.val_car, "", env_global)
/* TODO: Assert that there is something on the stack */
; compile_rec(stack_pop(stack), can_tail_call, type_any) )
else let var derp: scheme_value := nil
in vm_run(macro_tape, fun.val_i, stack, fun.val_car, "", env_global)
; /* TODO: Assert that there is something on the stack */
derp := stack_pop(stack)
; if DEBUG_PRINT_MACRO
then ( print("Macro expanded to: ")
; print(value_to_string(derp))
; print("\n") )
; compile_rec(derp, can_tail_call, type_any)
end
end
/* Call-lambda expressions: A system for binding local
* variables */
/* Lambda expressions */
else if ast.val_car.typ = type_pair
& ast.val_car.val_car.typ = type_symbol
& ast.val_car.val_car.val_s = "lambda"
/* Does not support non-proper lists, currently: */
& scheme_value_is_proper_list (ast.val_car.val_cdr.val_car)
then
let var pos_l := ast.pos_l
var pos_r := ast.pos_r
var insns := vm_insn_list { first = nil, last = nil }
var num_required_args := sexp_list_length (ast.val_car.val_cdr.val_car)
var num_given_args := sexp_list_length (ast.val_cdr)
/* TODO: Give error when numbers of arguments does
* not match */
var ast_iter := ast.val_cdr
in ()
/* First compile arguments onto stack */
; while ast_iter <> nil & ast_iter.typ = type_pair
do ( concat_lists(insns, compile_rec(ast_iter.val_car, false, type_any))
; ast_iter := ast_iter.val_cdr )
/* Then assign them to variables */
; print(concat(value_to_string(ast.val_car.val_cdr.val_car), "\n"))
; compile_load_of_arguments(insns, ast.val_car.val_cdr.val_car, pos_l, pos_r)
/* Perform body */
; concat_lists(insns, compile_rec(ast.val_car.val_cdr.val_cdr.val_car, can_tail_call, type_any))
/* Forget variables again */
; app_insn(insns, OPCODE_FORGET, num_required_args, "", pos_l, pos_r)
/* Return instructions */
; insns
end
/* Call expressions */
else let var num_args := 0
var args_insns := vm_insn_list { first = nil, last = nil }
@ -1926,8 +2020,8 @@ let /* Booleans */
end
function compile_error(errmsg: string, errast: sexp_ast) =
let var repr_pos_l := pos_to_string(errast.pos_l)
var repr_pos_r := pos_to_string(errast.pos_r)
let var repr_pos_l := pos_to_string(if errast = nil then nil else errast.pos_l)
var repr_pos_r := pos_to_string(if errast = nil then nil else errast.pos_r)
in print("Tiger-scheme compile error\n ")
; print(errmsg)
; print("\n For scheme: ")
@ -1940,8 +2034,12 @@ let /* Booleans */
; print("\n")
end
var base_insns := compile_rec(ast, false, type_any)
in app_insn (base_insns, OPCODE_EXIT, 0, "", ast.pos_l, ast.pos_r)
var base_insns :=
if ast = nil
then (compile_error("Given ast was nil!", ast); nil)
else compile_rec(ast, false, type_any)
in if ast <> nil
then app_insn (base_insns, OPCODE_EXIT, 0, "", ast.pos_l, ast.pos_r)
; base_insns
end
@ -2163,9 +2261,12 @@ let /* Booleans */
if value = nil
then run_error(concat5( "Attempting to access unknown variable \""
, tape[ip].arg2
, "\"\n Environment looks like "
, env_to_string(env)
, ""))
, "\"\n"
, ""
, if DEBUG_SHOW_FULL_ENVIRONMENT
then concat( "\tEnvironment looks like "
, env_to_string(env))
else ""))
else if tape[ip].arg1 <> 0
& tape[ip].arg1 <> value.typ
then run_error(concat6( "Attempting to access variable \""
@ -2185,6 +2286,11 @@ let /* Booleans */
; ip := ip + 1
end
else if tape[ip].opcode = OPCODE_FORGET
then ( for i := 1 to tape[ip].arg1
do env := env_pop(env)
; ip := ip + 1 )
else if tape[ip].opcode = OPCODE_SETG
then let var value := stack_pop(stack)
var new_env := global_env_push(global_env, tape[ip].arg2, value)
@ -2450,14 +2556,26 @@ let /* Booleans */
let var depth := 0
var char := "BAD SHIT HAPPENED"
var text := ""
var comment_mode := false
in while char <> ""
do ( char := getchar()
; text := concat(text, char)
; if char = "("
; if comment_mode
& char = "\n"
then comment_mode := false
else if comment_mode
then () /* Do nothing */
/* We can assume that comment mode is not enabled for
* these: */
else if char = "("
then depth := depth + 1
else if char = ")"
then ( depth := depth - 1
; if depth = 0 then break ))
; if depth = 0 then break )
else if char = ";"
then comment_mode := true
)
; text
end
@ -2473,9 +2591,12 @@ in print("Ready for the scheming Tiger?\n")
var macro_name := "" /* Not macro is "" */
var sexp := parse_string(text)
var sexp := if size(text) > 0
then parse_string(text)
else nil
var sexp_compile :=
if sexp.typ = type_pair
if sexp <> nil
& sexp.typ = type_pair
& sexp.val_car.typ = type_symbol
& sexp.val_car.val_s = "define-syntax"
then ( macro_name := sexp.val_cdr.val_car.val_s