From f52e59cc820cdf446c0b43ec7228b77afb070d69 Mon Sep 17 00:00:00 2001 From: Torben Ewert Date: Fri, 26 Jun 2026 16:44:57 +0200 Subject: [PATCH] feat: compile functions and function calls without parameters --- lib/pinc_bytecode/instruction.ml | 16 ++- lib/pinc_bytecode/value.ml | 5 + lib/pinc_compiler/compiler.ml | 171 +++++++++++++++++++++++-------- lib/pinc_vm/vm.ml | 53 ++++++++-- lib/pinc_vm/vm_frame.ml | 8 ++ test/vm/functions.pi | 24 +++++ test/vm/run.t | 33 ++++++ 7 files changed, 258 insertions(+), 52 deletions(-) create mode 100644 lib/pinc_vm/vm_frame.ml create mode 100644 test/vm/functions.pi diff --git a/lib/pinc_bytecode/instruction.ml b/lib/pinc_bytecode/instruction.ml index 4015d17..1d3e727 100644 --- a/lib/pinc_bytecode/instruction.ml +++ b/lib/pinc_bytecode/instruction.ml @@ -31,6 +31,8 @@ type t = | I_Dot_Index | I_Range | I_Range_Inclusive + | I_Call + | I_Return let byte = function | I_Pop -> 0x00 @@ -65,6 +67,8 @@ let byte = function | I_Dot_Index -> 0x1D | I_Range -> 0x1E | I_Range_Inclusive -> 0x1F + | I_Call -> 0x20 + | I_Return -> 0x21 ;; let operands_length = function @@ -99,7 +103,9 @@ let operands_length = function | I_Index | I_Dot_Index | I_Range - | I_Range_Inclusive -> 0 + | I_Range_Inclusive + | I_Call + | I_Return -> 0 ;; let decode bytes offset = @@ -152,6 +158,8 @@ let decode bytes offset = | 0x1D -> (offset, I_Dot_Index) | 0x1E -> (offset, I_Range) | 0x1F -> (offset, I_Range_Inclusive) + | 0x20 -> (offset, I_Call) + | 0x21 -> (offset, I_Return) | _ -> raise_notrace (Invalid_argument (Printf.sprintf "unknown instruction: 0x%.2X" instruction)) @@ -190,6 +198,8 @@ let pp fmt = function | I_Dot_Index -> Format.fprintf fmt "I_Dot_Index" | I_Range -> Format.fprintf fmt "I_Range" | I_Range_Inclusive -> Format.fprintf fmt "I_Range_Inclusive" + | I_Call -> Format.fprintf fmt "I_Call" + | I_Return -> Format.fprintf fmt "I_Return" ;; let to_bytes t = @@ -235,7 +245,9 @@ let to_bytes t = | I_Index | I_Dot_Index | I_Range - | I_Range_Inclusive -> () + | I_Range_Inclusive + | I_Call + | I_Return -> () in bytes diff --git a/lib/pinc_bytecode/value.ml b/lib/pinc_bytecode/value.ml index 61b382c..896cbc0 100644 --- a/lib/pinc_bytecode/value.ml +++ b/lib/pinc_bytecode/value.ml @@ -7,6 +7,7 @@ type t = | String of string | Array of t array | Record of t StringMap.t + | Function of Bytes.t let rec to_string = function | Null -> "" @@ -38,6 +39,7 @@ let rec to_string = function is_first := false) m; Buffer.contents b + | Function _ -> "" ;; let is_true = function @@ -50,6 +52,7 @@ let is_true = function | Array [||] -> false | Array _ -> true | Record m -> not (StringMap.is_empty m) + | Function _ -> true ;; let rec equal a b = @@ -64,6 +67,7 @@ let rec equal a b = | Null, Null -> true | Array a, Array b -> Array.equal equal a b | Record a, Record b -> StringMap.equal equal a b + | Function a, Function b -> Bytes.equal a b | _ -> false ;; @@ -81,6 +85,7 @@ let compare a b = | Null, Null -> 0 | Array a, Array b -> Int.compare (Array.length a) (Array.length b) | Record a, Record b -> StringMap.compare compare a b + | Function _, Function _ -> 0 | _ -> 0 ;; diff --git a/lib/pinc_compiler/compiler.ml b/lib/pinc_compiler/compiler.ml index 99d72c8..7eccb64 100644 --- a/lib/pinc_compiler/compiler.ml +++ b/lib/pinc_compiler/compiler.ml @@ -5,40 +5,97 @@ type emitted_instruction = { instruction : Pinc_Bytecode.Instruction.t; } -type t = { +type scope = { instructions : Buffer.t; + last_instruction : emitted_instruction; + previous_instruction : emitted_instruction; +} + +type t = { constants : Pinc_Bytecode.Value.t Int32.Map.t; - mutable last_instruction : emitted_instruction; - mutable previous_instruction : emitted_instruction; symbol_table : SymbolTable.t; + scopes : scope list; } +let current_scope t = + match t.scopes with + | [] -> assert false + | scope :: _ -> scope +;; + +let current_instructions t = + let scope = current_scope t in + scope.instructions +;; + +let last_instruction t = + let scope = current_scope t in + scope.last_instruction.instruction +;; + +let last_instruction_offset t = + let scope = current_scope t in + scope.last_instruction.offset +;; + let set_last_instruction t offset instruction = - t.previous_instruction <- t.last_instruction; - t.last_instruction <- { offset; instruction } + match t.scopes with + | [] -> assert false + | scope :: scopes -> + let scope' = + { + scope with + previous_instruction = scope.last_instruction; + last_instruction = { offset; instruction }; + } + in + { t with scopes = scope' :: scopes } ;; let replace_instruction t offset instruction = - let current_instructions = Buffer.to_bytes t.instructions in - let src = Pinc_Bytecode.Instruction.to_bytes instruction in - let srcoff = 0 in - let len = Bytes.length src in - Bytes.blit src srcoff current_instructions offset len; - Buffer.truncate t.instructions 0; - Buffer.add_bytes t.instructions current_instructions; - t + match t.scopes with + | [] -> assert false + | scope :: _ -> + let current_instructions = Buffer.to_bytes scope.instructions in + let src = Pinc_Bytecode.Instruction.to_bytes instruction in + let srcoff = 0 in + let len = Bytes.length src in + Bytes.blit src srcoff current_instructions offset len; + Buffer.truncate scope.instructions 0; + Buffer.add_bytes scope.instructions current_instructions; + t ;; let remove_last_instruction t = - Buffer.truncate t.instructions t.last_instruction.offset; - t.last_instruction <- t.previous_instruction; - t + match t.scopes with + | [] -> assert false + | scope :: scopes -> + Buffer.truncate scope.instructions scope.last_instruction.offset; + let scope' = { scope with last_instruction = scope.previous_instruction } in + { t with scopes = scope' :: scopes } ;; -let remove_last_pop t = - match t.last_instruction.instruction with - | I_Pop -> remove_last_instruction t - | _ -> t +let match_last_instruction t check = + let scope = current_scope t in + scope.last_instruction.instruction == check +;; + +let add_scope t = + let empty_instruction = { offset = 0; instruction = I_Null } in + let scope = + { + instructions = Buffer.create 8; + previous_instruction = empty_instruction; + last_instruction = empty_instruction; + } + in + { t with scopes = scope :: t.scopes } +;; + +let pop_scope t = + match t.scopes with + | [] -> assert false + | scope :: scopes -> ({ t with scopes }, scope) ;; let add_constant = @@ -55,9 +112,10 @@ let add_constant = ;; let emit t opcode = - let offset = Buffer.length t.instructions in - Buffer.add_bytes t.instructions @@ Pinc_Bytecode.Instruction.to_bytes @@ opcode; - set_last_instruction t offset opcode; + let scope = current_scope t in + let offset = Buffer.length scope.instructions in + Buffer.add_bytes scope.instructions @@ Pinc_Bytecode.Instruction.to_bytes @@ opcode; + let t = set_last_instruction t offset opcode in t ;; @@ -128,8 +186,37 @@ let rec compile_expr t (expr : Pinc_Types.Ast.expression) = let length = Int32.of_int @@ List.length keys in let t = emit t @@ Pinc_Bytecode.Instruction.I_Record length in t - | Function _ -> raise_notrace TODO - | FunctionCall _ -> raise_notrace TODO + | Function { identifier = _; parameters = _; body } -> + let t = add_scope t in + let t = + match body.expression_desc with + | Pinc_Types.Ast.BlockExpression _ -> compile_expr t body + | _ -> + let t = compile_expr t body in + emit t @@ Pinc_Bytecode.Instruction.I_Return + in + let t = + if match_last_instruction t I_Pop then ( + let t = remove_last_instruction t in + emit t @@ Pinc_Bytecode.Instruction.I_Return) + else + t + in + let t = + if not @@ match_last_instruction t I_Return then ( + let t = emit t @@ Pinc_Bytecode.Instruction.I_Null in + emit t @@ Pinc_Bytecode.Instruction.I_Return) + else + t + in + let t, scope = pop_scope t in + let instructions = Buffer.to_bytes scope.instructions in + let t = emit_constant t @@ Pinc_Bytecode.Value.Function instructions in + t + | FunctionCall { function_definition; arguments = _ } -> + let t = compile_expr t function_definition in + let t = emit t @@ Pinc_Bytecode.Instruction.I_Call in + t | TagExpression _ -> raise_notrace TODO | ForInExpression _ -> raise_notrace TODO | TemplateExpression node -> compile_template_node t node @@ -242,14 +329,19 @@ and compile_conditional_expression t ~condition ~consequent ~alternate = (* Consequent *) (* We create a conditional jump with a temporary address first, because we do not know where we should jump to next. *) let t = emit t (Pinc_Bytecode.Instruction.I_Jump_If_False 0xFFFFFFFl) in - let jump_consequent_offset = t.last_instruction.offset in + let jump_consequent_offset = last_instruction_offset t in let t = compile_expr t consequent in - let t = remove_last_pop t in + let t = + if match_last_instruction t I_Pop then + remove_last_instruction t + else + t + in (* Alternate *) let t = emit t (Pinc_Bytecode.Instruction.I_Jump 0xFFFFFFFl) in - let jump_alternate_offset = t.last_instruction.offset in - let jump_address = Int32.of_int (Buffer.length t.instructions) in + let jump_alternate_offset = last_instruction_offset t in + let jump_address = Int32.of_int (Buffer.length @@ current_instructions t) in let t = replace_instruction t jump_consequent_offset @@ Pinc_Bytecode.Instruction.I_Jump_If_False jump_address @@ -259,10 +351,15 @@ and compile_conditional_expression t ~condition ~consequent ~alternate = | None -> emit t Pinc_Bytecode.Instruction.I_Null | Some alternate -> let t = compile_expr t alternate in - let t = remove_last_pop t in + let t = + if match_last_instruction t I_Pop then + remove_last_instruction t + else + t + in t in - let jump_address = Int32.of_int (Buffer.length t.instructions) in + let jump_address = Int32.of_int (Buffer.length @@ current_instructions t) in let t = replace_instruction t jump_alternate_offset @@ Pinc_Bytecode.Instruction.I_Jump jump_address @@ -299,18 +396,12 @@ let compile_declaration (decl : Pinc_Types.Ast.declaration) t = ;; let compile (ast : Pinc_Types.Ast.t) = - let empty_instruction = { offset = 0; instruction = I_Null } in let t = - { - instructions = Buffer.create 8; - constants = Int32.Map.empty; - previous_instruction = empty_instruction; - last_instruction = empty_instruction; - symbol_table = SymbolTable.make (); - } + { constants = Int32.Map.empty; symbol_table = SymbolTable.make (); scopes = [] } in + let t = add_scope t in let t = StringMap.fold (fun _ -> compile_declaration) ast t in Pinc_Bytecode.Bytecode.make - ~instructions:(Buffer.to_bytes t.instructions) + ~instructions:(Buffer.to_bytes @@ current_instructions t) ~constants:t.constants ;; diff --git a/lib/pinc_vm/vm.ml b/lib/pinc_vm/vm.ml index 795846c..c4d4b07 100644 --- a/lib/pinc_vm/vm.ml +++ b/lib/pinc_vm/vm.ml @@ -1,25 +1,45 @@ open Pinc_Types open Pinc_Bytecode module Stack = Vm_stack +module Frame = Vm_frame exception TODO type t = { - bytecode : Bytecode.t; stack : Value.t Stack.t; mutable globals : Value.t Int32.Map.t; + mutable frames : Frame.t list; + constants : Value.t Int32.Map.t; } let stack_size = 2048 let make (bytecode : Bytecode.t) = + let main_frame = Frame.make bytecode.instructions in { - bytecode; + constants = bytecode.constants; stack = Stack.make ~size:stack_size ~default_value:Value.Null; globals = Int32.Map.empty; + frames = [ main_frame ]; } ;; +let current_frame t = + match t.frames with + | [] -> assert false + | hd :: _ -> hd +;; + +let push_frame t frame = t.frames <- frame :: t.frames + +let pop_frame t = + match t.frames with + | [] -> assert false + | frame :: frames -> + t.frames <- frames; + frame +;; + let rec execute_binary_operation t op = let r = Stack.pop t.stack in let l = Stack.pop t.stack in @@ -293,16 +313,16 @@ and execute_unary_not r = ;; let run t = - let ip = ref 0 in - let instruction_length = Bytes.length t.bytecode.instructions in - while !ip < instruction_length do - let new_ip, op = Instruction.decode t.bytecode.instructions !ip in - let () = ip := new_ip in + Printexc.record_backtrace true; + while (current_frame t).pointer < Bytes.length (current_frame t).instructions do + let frame = current_frame t in + let new_ip, op = Instruction.decode frame.instructions frame.pointer in + Frame.set_pointer frame new_ip; let () = match op with | Instruction.I_Pop -> ignore @@ Stack.pop t.stack | Instruction.I_Constant addr -> - let constant = Int32.Map.find addr t.bytecode.constants in + let constant = Int32.Map.find addr t.constants in Stack.push t.stack constant | Instruction.I_Add -> execute_binary_operation t Operators.Binary.PLUS | Instruction.I_Sub -> execute_binary_operation t Operators.Binary.MINUS @@ -329,12 +349,12 @@ let run t = execute_binary_operation t Operators.Binary.INCLUSIVE_RANGE | Instruction.I_Minus -> execute_unary_operation t Operators.Unary.MINUS | Instruction.I_Not -> execute_unary_operation t Operators.Unary.NOT - | Instruction.I_Jump addr -> ip := Int32.to_int addr + | Instruction.I_Jump addr -> Frame.set_pointer frame @@ Int32.to_int addr | Instruction.I_Jump_If_False addr -> let condition = Stack.pop t.stack in let () = if not @@ Value.is_true condition then - ip := Int32.to_int addr + Frame.set_pointer frame @@ Int32.to_int addr in () | Instruction.I_Null -> Stack.push t.stack Value.Null @@ -360,6 +380,19 @@ let run t = let record = StringMap.of_list @@ List.combine keys values in let value = Value.Record record in Stack.push t.stack value + | Instruction.I_Call -> ( + let fn = Stack.top t.stack in + match fn with + | Value.Function instructions -> push_frame t @@ Frame.make instructions + | _ -> raise_notrace @@ Invalid_argument "Trying to call a non function value") + | Instruction.I_Return -> + let value = Stack.pop t.stack in + let () = ignore @@ pop_frame t in + let () = + (* This is the function from the I_Call instruction *) + ignore @@ Stack.pop t.stack + in + Stack.push t.stack value in () done; diff --git a/lib/pinc_vm/vm_frame.ml b/lib/pinc_vm/vm_frame.ml new file mode 100644 index 0000000..da9c34f --- /dev/null +++ b/lib/pinc_vm/vm_frame.ml @@ -0,0 +1,8 @@ +type t = { + instructions : Bytes.t; + mutable pointer : int; +} + +let make instructions = { instructions; pointer = 0 } +let instructions t = t.instructions +let set_pointer t i = t.pointer <- i diff --git a/test/vm/functions.pi b/test/vm/functions.pi new file mode 100644 index 0000000..240933f --- /dev/null +++ b/test/vm/functions.pi @@ -0,0 +1,24 @@ +component FunctionEmpty { + let noop = fn () -> { + + }; + + noop() +} + +component Function { + let onePlusTwo = fn () -> { + let one = 1; + let two = 2; + one + two + }; + + onePlusTwo() +} + +component FunctionCurried { + let returns_one = fn () -> if (true) 1 else 2; + let returns_returns_one = fn () -> returns_one; + + returns_returns_one()() +} diff --git a/test/vm/run.t b/test/vm/run.t index 122a639..cff8fa8 100644 --- a/test/vm/run.t +++ b/test/vm/run.t @@ -500,3 +500,36 @@ 0051 I_Constant 0x00000007 (00000007) 0056 I_Index 0057 I_Pop + + $ NO_COLOR="1" print_vm . FunctionEmpty + + + $ NO_COLOR="1" print_instructions . FunctionEmpty + 0000 I_Constant 0x00000001 (00000001) + 0005 I_Set_Global 0x00000001 (00000001) + 0010 I_Get_Global 0x00000001 (00000001) + 0015 I_Call + 0016 I_Pop + + $ NO_COLOR="1" print_vm . Function + 3 + + $ NO_COLOR="1" print_instructions . Function + 0000 I_Constant 0x00000003 (00000003) + 0005 I_Set_Global 0x00000003 (00000003) + 0010 I_Get_Global 0x00000003 (00000003) + 0015 I_Call + 0016 I_Pop + + $ NO_COLOR="1" print_vm . FunctionCurried + 1 + + $ NO_COLOR="1" print_instructions . FunctionCurried + 0000 I_Constant 0x00000003 (00000003) + 0005 I_Set_Global 0x00000001 (00000001) + 0010 I_Constant 0x00000004 (00000004) + 0015 I_Set_Global 0x00000002 (00000002) + 0020 I_Get_Global 0x00000002 (00000002) + 0025 I_Call + 0026 I_Call + 0027 I_Pop -- 2.51.2