Start putting all this into a Clean library

src/.gitignore

@@ -3,4 +3,9 @@ debug
 interpret
 link
 optimise
+
+graph_copy_with_names.dcl
+graph_copy_with_names.icl
+
 CodeSharing
+GraphTest

src/ABC/Interpreter.dcl

+definition module ABC.Interpreter
+
+from System.FilePath import :: FilePath
+
+:: SerializedGraph
+
+serialize_for_interpretation :: a !FilePath !FilePath !*World -> *(!SerializedGraph, !*World)
+
+:: InterpretedExpression
+:: *InterpretationEnvironment
+
+get_start_rule_as_expression :: !FilePath !*World -> *(a, *World)

src/ABC/Interpreter.icl

+implementation module ABC.Interpreter
+
+import StdArray
+import StdFile
+import StdInt
+import StdMisc
+
+import Data._Array
+import Data.Error
+import Data.Maybe
+import System.CommandLine
+import System.File
+import System.FilePath
+import System._Pointer
+import System._Posix
+
+import graph_copy_with_names
+import symbols_in_program
+
+import ABC.Interpreter.Internal
+import ABC.Interpreter.Util
+
+:: SerializedGraph =
+	{ graph    :: !String
+	, bytecode :: !String
+	}
+
+// The arguments are:
+// - Pointer to C function;
+// - Argument for function (in our case, pointer to the interpret node)
+// - Pointer to rest of the finalizers (dealt with in the RTS)
+:: Finalizer = Finalizer !Int !Int !Int
+:: InterpretedExpression :== Finalizer
+:: *InterpretationEnvironment = E.a:
+	{ ie_finalizer :: !Finalizer
+	, ie_snode_ptr :: !Int
+	, ie_snodes    :: !*{a}
+	}
+
+serialize_for_interpretation :: a !FilePath !FilePath !*World -> *(!SerializedGraph, !*World)
+serialize_for_interpretation graph thisexe bcfile w
+
+# (host_syms,w) = accFiles (read_symbols thisexe) w
+
+# (bytecode,w) = readFile bcfile w
+| isError bytecode = abort "Failed to read the bytecode file\n"
+# bytecode = fromOk bytecode
+# pgm = parse host_syms bytecode
+| isNothing pgm = abort "Failed to parse bytecode file\n"
+# pgm = fromJust pgm
+
+# (graph,descs,mods) = copy_to_string_with_names graph
+# graph = replace_symbols_in_graph graph descs mods host_syms
+
+= ({graph=graph, bytecode=bytecode}, w)
+
+STACK_SIZE :== (512 << 10) * 2
+HEAP_SIZE :== 2 << 20
+
+get_start_rule_as_expression :: !FilePath !*World -> *(a, *World)
+get_start_rule_as_expression filename w
+# ([prog:_],w) = getCommandLine w
+# (syms,w) = accFiles (read_symbols prog) w
+# (bc,w) = readFile filename w
+| isError bc = abort "Failed to read the file\n"
+# bc = fromOk bc
+# pgm = parse syms bc
+| isNothing pgm = abort "Failed to parse program\n"
+# pgm = fromJust pgm
+# stack = malloc (IF_INT_64_OR_32 8 4 * STACK_SIZE)
+# asp = stack
+# bsp = stack + IF_INT_64_OR_32 8 4 * (STACK_SIZE-1)
+# csp = stack + IF_INT_64_OR_32 4 2 * STACK_SIZE
+# heap = malloc (IF_INT_64_OR_32 8 4 * HEAP_SIZE)
+# ie_settings = build_interpretation_environment
+	pgm
+	heap HEAP_SIZE stack STACK_SIZE
+	asp bsp csp heap
+# start_node = build_start_node ie_settings
+#! (ie,_) = make_finalizer ie_settings
+# ie = {ie_finalizer=ie, ie_snode_ptr=0, ie_snodes=unsafeCreate 1}
+= (interpret ie (Finalizer 0 0 start_node), w)
+	// Obviously, this is not a "valid" finalizer in the sense that it can be
+	// called from the garbage collector. But that's okay, because we don't add
+	// it to the finalizer_list anyway. This is just to ensure that the first
+	// call to interpret gets the right argument.
+where
+	build_interpretation_environment :: !Pointer !Pointer !Int !Pointer !Int !Pointer !Pointer !Pointer !Pointer -> Pointer
+	build_interpretation_environment pgm heap hsize stack ssize asp bsp csp hp = code {
+		ccall build_interpretation_environment "ppIpIpppp:p"
+	}
+
+	build_start_node :: !Pointer -> Pointer
+	build_start_node ie = code {
+		ccall build_start_node "p:p"
+	}
+
+	make_finalizer :: !Int -> (!.Finalizer,!Int)
+	make_finalizer ie_settings = code {
+		push_finalizers
+		ccall get_interpretation_environment_finalizer ":p"
+		push_a_b 0
+		pop_a 1
+		build_r e__system_kFinalizer 0 3 0 0
+		pop_b 3
+		set_finalizers
+		pushI 0
+	}

src/CodeSharing.dcl → src/ABC/Interpreter/Internal.dcl

-definition module CodeSharing
+definition module ABC.Interpreter.Internal
 
-from System._Pointer import :: Pointer
-from symbols_in_program import :: Symbol
-
-:: InterpretedExpression
-:: *InterpretationEnvironment
+import ABC.Interpreter
 
 add_shared_node :: !Int !*{a} a -> *(!Int, !*{a}, !Int)
 

src/ABC/Interpreter/Internal.icl

+implementation module ABC.Interpreter.Internal
+
+import StdArray
+import StdClass
+import StdInt
+
+import Data._Array
+
+import ABC.Interpreter
+
+add_shared_node :: !Int !*{a} a -> *(!Int, !*{a}, !Int)
+add_shared_node ptr nodes node
+# (arraysize,nodes) = usize nodes
+# (spot,nodes) = find_empty_spot ptr nodes
+| spot == -1
+	= (arraysize, {copy 0 arraysize nodes (unsafeCreate (arraysize+100)) & [arraysize]=node}, arraysize+1)
+| otherwise
+	= (spot, {nodes & [spot]=node}, if (spot+1 >= arraysize) 0 (spot+1))
+where
+	copy :: !Int !Int !*{a} !*{a} -> *{a}
+	copy i end fr to
+	| i == end = to
+	# (x,fr) = fr![i]
+	# to & [i] = x
+	= copy (i+1) end fr to
+
+	find_empty_spot :: !Int !*{a} -> (!Int, !*{a})
+	find_empty_spot start nodes = code {
+		push_a 0
+		push_arraysize _ 1 0
+		push_b 1
+	:find_empty_spot_loop
+		push_b 0
+		push_a 0
+		select _ 1 0
+		eq_desc _Nil 0 0
+		pop_a 1
+		jmp_true find_empty_spot_found
+		incI
+		push_b 0
+		push_b 2
+		eqI
+		jmp_true find_empty_spot_overflow
+		push_b 0
+		push_b 3
+		eqI
+		jmp_true find_empty_spot_full
+		jmp find_empty_spot_loop
+	:find_empty_spot_overflow
+		eqI_b 0 2
+		jmp_true find_empty_spot_full
+		pop_b 1
+		pushI 0
+		jmp find_empty_spot_loop
+	:find_empty_spot_full
+		pop_b 1
+		pushI -1
+	:find_empty_spot_found
+		updatepop_b 0 2
+		.d 1 1 i
+		rtn
+	}
+
+interpret :: InterpretationEnvironment !InterpretedExpression -> .a
+interpret ie fin = code {
+	.d 2 0
+	jsr _interpret_copy_node_asm
+	.o 1 0
+}
+
+interpret_1 :: InterpretationEnvironment !InterpretedExpression b -> a
+interpret_1 ie fin arg = code {
+	jsr_eval 0
+	pushI 0
+	.d 3 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_2  :: InterpretationEnvironment !InterpretedExpression b b -> .a
+interpret_2  _ _ _ _ = code {
+	jsr_eval 0
+	pushI 1
+	.d 4 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_3  :: InterpretationEnvironment !InterpretedExpression b b b -> .a
+interpret_3  _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 2
+	.d 5 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_4  :: InterpretationEnvironment !InterpretedExpression b b b b -> .a
+interpret_4  _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 3
+	.d 6 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_5  :: InterpretationEnvironment !InterpretedExpression b b b b b -> .a
+interpret_5  _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 4
+	.d 6 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_6  :: InterpretationEnvironment !InterpretedExpression b b b b b b -> .a
+interpret_6  _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 5
+	.d 7 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_7  :: InterpretationEnvironment !InterpretedExpression b b b b b b b -> .a
+interpret_7  _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 6
+	.d 8 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_8  :: InterpretationEnvironment !InterpretedExpression b b b b b b b b -> .a
+interpret_8  _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 7
+	.d 9 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_9  :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b -> .a
+interpret_9  _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 8
+	.d 10 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_10 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b -> .a
+interpret_10 _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 9
+	.d 11 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_11 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b -> .a
+interpret_11 _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 10
+	.d 12 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_12 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b -> .a
+interpret_12 _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 11
+	.d 13 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_13 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b -> .a
+interpret_13 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 12
+	.d 14 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_14 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b -> .a
+interpret_14 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 13
+	.d 15 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_15 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b -> .a
+interpret_15 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 14
+	.d 16 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_16 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b -> .a
+interpret_16 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 15
+	.d 17 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_17 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b b -> .a
+interpret_17 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 16
+	.d 18 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_18 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b b b -> .a
+interpret_18 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 17
+	.d 19 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_19 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b b b b -> .a
+interpret_19 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 18
+	.d 20 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_20 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b b b b b -> .a
+interpret_20 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 19
+	.d 21 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_21 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b b b b b b -> .a
+interpret_21 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 20
+	.d 22 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_22 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b b b b b b b -> .a
+interpret_22 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 21
+	.d 23 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_23 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b b b b b b b b -> .a
+interpret_23 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 22
+	.d 24 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_24 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b b b b b b b b b -> .a
+interpret_24 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 23
+	.d 25 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_25 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b b b b b b b b b b -> .a
+interpret_25 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 24
+	.d 26 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_26 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b b b b b b b b b b b -> .a
+interpret_26 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 25
+	.d 27 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_27 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b b b b b b b b b b b b -> .a
+interpret_27 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 26
+	.d 28 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_28 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b b b b b b b b b b b b b -> .a
+interpret_28 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 27
+	.d 29 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_29 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b b b b b b b b b b b b b b -> .a
+interpret_29 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 28
+	.d 30 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_30 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b -> .a
+interpret_30 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 29
+	.d 31 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}
+
+interpret_31 :: InterpretationEnvironment !InterpretedExpression b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b -> .a
+interpret_31 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = code {
+	jsr_eval 0
+	pushI 30
+	.d 32 1 i
+	jsr _interpret_copy_node_asm_n
+	.o 1 0
+}

src/ABC/Interpreter/Util.dcl

+definition module ABC.Interpreter.Util
+
+from StdMaybe import :: Maybe
+from System._Pointer import :: Pointer
+from symbols_in_program import :: Symbol
+
+:: Program :== Pointer
+
+parse :: !{#Symbol} !String -> Maybe Program
+new_parser :: !{#Symbol} -> Pointer
+new_string_char_provider :: !String -> Pointer
+free_char_provider_to_false :: !Pointer -> Bool
+parse_program :: !Pointer !Pointer -> Int
+free_to_false :: !Pointer -> Bool

src/ABC/Interpreter/Util.icl

+implementation module ABC.Interpreter.Util
+
+import StdArray
+import StdBool
+import StdClass
+import StdInt
+import StdList
+
+import Data._Array
+import Data.Maybe
+import System._Pointer
+import System._Posix
+
+import symbols_in_program
+
+import code from "interpret.a"
+
+OFFSET_PARSER_PROGRAM :== 8 // Offset to the program field in the parser struct (parse.h)
+
+parse :: !{#Symbol} !String -> Maybe Program
+parse syms s
+#! cp = new_string_char_provider s
+#! parser = new_parser syms
+#! res = parse_program parser cp
+| free_char_provider_to_false cp || free_to_false cp = Nothing
+| res <> 0 = Nothing
+#! pgm = readInt parser OFFSET_PARSER_PROGRAM // TODO 32-bit offset?
+#! parser = free_parser parser parser
+| free_to_false parser = Nothing
+= Just pgm
+where
+	free_parser :: !Pointer !Pointer -> Pointer
+	free_parser _ _ = code {
+		ccall free_parser "p:V:p"
+	}
+
+new_parser :: !{#Symbol} -> Pointer
+new_parser syms
+# parser = malloc 100 // size of the parser struct + some extra to be sure
+= init parser symbol_n symbol_string_length symbol_string parser
+where
+	symbol_n = size syms
+	symbol_string_length = sum [size s.symbol_name \\ s <-: syms]
+	symbol_string = build_symbol_string 0 0 (createArrayUnsafe (symbol_n * IF_INT_64_OR_32 9 5 + symbol_string_length))
+
+	build_symbol_string :: !Int !Int !*{#Char}-> *{#Char}
+	build_symbol_string i j s
+	| i == symbol_n = s
+	# sym = syms.[i]
+	# (j,s) = int_to_string sym.symbol_value j s
+	# (j,s) = copyString sym.symbol_name (size sym.symbol_name) 0 j s
+	= build_symbol_string (i+1) j s
+	where
+		int_to_string :: !Int !Int !*{#Char} -> *(!Int, !*{#Char})
+		int_to_string val j s = (j+IF_INT_64_OR_32 8 4, {s & [j+k]=toChar (val >> (8*k)) \\ k <- [0..IF_INT_64_OR_32 7 3]})
+
+		copyString :: !String !Int !Int !Int !*{#Char} -> *(!Int, !*{#Char})
+		copyString org orgsize i desti dest
+		| i == orgsize = (desti+1, {dest & [desti]='\0'})
+		| otherwise    = copyString org orgsize (i+1) (desti+1) {dest & [desti]=org.[i]}
+
+	init :: !Pointer !Int !Int !.{#Char} !Pointer -> Pointer
+	init _ _ _ _ _ = code {
+		ccall init_parser "pIIs:V:p"
+	}
+
+new_string_char_provider :: !String -> Pointer
+new_string_char_provider s
+# cp = malloc 16
+= init cp s (size s) 1 cp
+where
+	init :: !Pointer !String !Int !Int !Pointer -> Pointer
+	init _ _ _ _ _ = code {
+		ccall new_string_char_provider "IsII:V:I"
+	}