implementation module ABC.Interpreter

import StdArray
import StdBool
import StdClass
import StdFile
import StdInt
import StdList
import StdMisc
import StdOrdList

import graph_copy
import graph_copy_with_names
import symbols_in_program

import ABC.Interpreter.Internal
import ABC.Interpreter._Util

defaultDeserializationSettings :: DeserializationSettings
defaultDeserializationSettings =
	{ heap_size  = 2 << 20
	, stack_size = (512 << 10) * 2
	, file_io    = False
	}

:: *SerializedGraph =
	{ graph    :: !*String
	, descinfo :: !{#DescInfo}
	, modules  :: !{#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 :: a !String !*World -> *(!?SerializedGraph, !*World)
serialize graph bcfile w
# (graph,descinfo,modules) = copy_to_string_with_names graph

# (bytecode,w) = readFile bcfile w
| bytecode =: ?None = (?None, w)
# (?Just bytecode) = bytecode

#! (len,bytecodep) = strip_bytecode False bytecode {#symbol_name di modules \\ di <-: descinfo}
#! bytecode = derefCharArray bytecodep len
| free_to_false bytecodep = (?None, w)

# rec =
	{ graph    = graph
	, descinfo = descinfo
	, modules  = modules
	, bytecode = bytecode
	}
= (?Just rec, w)
where
	symbol_name :: !DescInfo !{#String} -> String
	symbol_name {di_prefix_arity_and_mod,di_name} mod_a
	# prefix_n = di_prefix_arity_and_mod bitand 0xff
	# module_n = (di_prefix_arity_and_mod >> 8)-1
	# module_name = mod_a.[module_n]
	= make_symbol_name module_name di_name (min prefix_n PREFIX_D) +++ "\0"
	where
		PREFIX_D = 4

	strip_bytecode :: !Bool !String !{#String} -> (!Int, !Pointer)
	strip_bytecode include_symbol_table bytecode descriptors = code {
		ccall strip_bytecode "IsA:VIp"
	}

instance toString (DeserializedValue a)
where
	toString DV_ParseError             = "parse error"
	toString DV_HeapFull               = "heap full"
	toString DV_StackOverflow          = "stack overflow"
	toString DV_FloatingPointException = "floating point exception"
	toString DV_Halt                   = "program end reached"
	toString DV_IllegalInstruction     = "illegal instruction"
	toString DV_FileIOAttempted        = "file I/O is not allowed"
	toString DV_HostHeapFull           = "host heap full"
	toString (DV_Ok _)                 = "deserialized value"

deserialize :: !DeserializationSettings !SerializedGraph !String !*World -> *(!?^a, !*World)
deserialize dsets graph thisexe w = deserialize` False dsets graph thisexe w

deserialize_strict :: !DeserializationSettings !SerializedGraph !String !*World -> *(!DeserializedValue a, !*World)
deserialize_strict dsets graph thisexe w = case deserialize` True dsets graph thisexe w of
	(?^None,  w) -> (DV_ParseError, w)
	(?^Just v,w) -> (v, w)

deserialize` :: !Bool !DeserializationSettings !SerializedGraph !String !*World -> *(?^a, !*World)
deserialize` strict dsets {graph,descinfo,modules,bytecode} thisexe w
| not ensure_interpreter_init = abort "internal error in deserialize`\n"

# (host_syms,w) = accFiles (read_symbols thisexe) w

# pgm = parse host_syms bytecode
| pgm =: ?None = (?^None, w)
# (?Just pgm) = pgm
# int_syms = {#s \\ s <- getInterpreterSymbols False pgm}
# int_syms = {#lookup_symbol_value (IF_INT_64_OR_32 4 3) d modules int_syms \\ d <-: descinfo}

# stack = malloc (IF_INT_64_OR_32 8 4 * dsets.stack_size)
# asp = stack
# bsp = stack + IF_INT_64_OR_32 8 4 * (dsets.stack_size-1)
# csp = stack + IF_INT_64_OR_32 4 2 * dsets.stack_size
# heap = malloc (IF_INT_64_OR_32 8 4 * (dsets.heap_size+4))
# ie_settings = build_interpretation_environment
	pgm
	heap dsets.heap_size stack dsets.stack_size
	asp bsp csp heap
	strict dsets.file_io
# graph = replace_desc_numbers_by_descs 0 graph int_syms 0 0
# graph_node = string_to_interpreter graph ie_settings
#! (ie,_) = make_finalizer ie_settings
# ie = {ie_finalizer=ie, ie_snode_ptr=0, ie_snodes=create_array_ 1}
= (?^Just (interpret ie (Finalizer 0 0 (graph_node + if strict 2 0))), w)
where
	string_to_interpreter :: !String !Pointer -> Pointer
	string_to_interpreter graph ie = code {
		ccall string_to_interpreter "Sp:p"
	}

getInterpreterSymbols :: !Bool !Pointer -> [Symbol]
getInterpreterSymbols get_64_bit_offset_on_32_bit pgm = getSymbols 0 (get_symbol_table_size pgm-1)
where
	symbol_table = get_symbol_table pgm

	getSymbols :: !Int !Int -> [Symbol]
	getSymbols i max
	| i > max = []
	# sym = getSymbol i
	# rest = getSymbols (i+1) max
	| size sym.symbol_name == 0
		= []
	| sym.symbol_value == -1
		= rest
		= [sym:rest]

	getSymbol :: !Int -> Symbol
	getSymbol i
	#! offset = symbol_table + (i * IF_INT_64_OR_32 16 12) /* size of struct host_symbol */
	#! loc = derefInt (IF_INT_64_OR_32 offset (if get_64_bit_offset_on_32_bit (offset + 8) offset))
	#! name = derefString (derefInt (offset + IF_INT_64_OR_32 8 4))
	= {symbol_name=name, symbol_value=loc}

	get_symbol_table_size :: !Pointer -> Int
	get_symbol_table_size pgm = code {
		ccall get_symbol_table_size "p:I"
	}

	get_symbol_table :: !Pointer -> Pointer
	get_symbol_table pgm = code {
		ccall get_symbol_table "p:p"
	}

lookup_symbol_value :: !Int !DescInfo !{#String} !{#Symbol} -> Int
lookup_symbol_value arity_shift {di_prefix_arity_and_mod,di_name} mod_a symbols
	# prefix_n = di_prefix_arity_and_mod bitand 0xff
	# module_n = (di_prefix_arity_and_mod >> 8)-1
	# module_name = mod_a.[module_n]
	| prefix_n<PREFIX_D
		# symbol_name = make_symbol_name module_name di_name prefix_n
		# symbol_value = get_symbol_value symbol_name symbols
		| prefix_n<=1
			| symbol_value== -1
				= abort ("lookup_desc_info not found "+++symbol_name+++"\n")
				= symbol_value
			| symbol_value== -1
				= abort ("lookup_desc_info not found "+++symbol_name+++"\n")
				= symbol_value+2
		# symbol_name = make_symbol_name module_name di_name PREFIX_D
		# symbol_value = get_symbol_value symbol_name symbols
		| symbol_value== -1
			= abort ("lookup_desc_info not found "+++symbol_name+++"\n")
			# arity = prefix_n - PREFIX_D
			= symbol_value+(arity << arity_shift)+2
where
	PREFIX_D = 4

get_start_rule_as_expression :: !DeserializationSettings !String !String !*World -> *(!?^a, !*World)
get_start_rule_as_expression settings filename prog w = get_start_rule False settings filename prog w

get_start_rule_as_expression_strict :: !DeserializationSettings !String !String !*World -> *(!DeserializedValue a, !*World)
get_start_rule_as_expression_strict settings filename prog w =
	case get_start_rule True settings filename prog w of
		(?^None,w)   -> (DV_ParseError, w)
		(?^Just v,w) -> (v, w)

get_start_rule :: !Bool !DeserializationSettings !String !String !*World -> *(!?^a, !*World)
get_start_rule strict dsets filename prog w
| not ensure_interpreter_init = abort "internal error in get_start_rule_as_expression\n"
# (syms,w) = accFiles (read_symbols prog) w
# (bc,w) = readFile filename w
| bc =: ?None = (?^None, w)
# (?Just bc) = bc
# pgm = parse syms bc
| pgm =: ?None = (?^None, w)
# (?Just pgm) = pgm
# stack = malloc (IF_INT_64_OR_32 8 4 * dsets.stack_size)
# asp = stack
# bsp = stack + IF_INT_64_OR_32 8 4 * (dsets.stack_size-1)
# csp = stack + IF_INT_64_OR_32 4 2 * dsets.stack_size
# heap = malloc (IF_INT_64_OR_32 8 4 * dsets.heap_size)
# ie_settings = build_interpretation_environment
	pgm
	heap dsets.heap_size stack dsets.stack_size
	asp bsp csp heap
	strict dsets.file_io
# start_node = build_start_node ie_settings
#! (ie,_) = make_finalizer ie_settings
# ie = {ie_finalizer=ie, ie_snode_ptr=0, ie_snodes=create_array_ 1}
= (?^Just (interpret ie (Finalizer 0 0 (start_node + if strict 2 0))), 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.

build_interpretation_environment :: !Pointer !Pointer !Int !Pointer !Int !Pointer !Pointer !Pointer !Pointer !Bool !Bool -> Pointer
build_interpretation_environment pgm heap hsize stack ssize asp bsp csp hp strict file_io = code {
	ccall build_interpretation_environment "ppIpIppppII: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
}

graph_to_string :: !*SerializedGraph -> *(!.String, !*SerializedGraph)
graph_to_string g=:{graph,descinfo,modules,bytecode}
# (graph_cpy,graph,graph_size) = copy graph
# g & graph = graph
# string_size = sum
	[ 4 + graph_size
	, 4 + sum [4 + size di.di_name + 1 \\ di <-: descinfo]
	, 4 + sum [size mod + 1 \\ mod <-: modules]
	, 4 + size bytecode
	]
# s = createArray string_size '\0'
# (i,s) = writeInt graph_size 0 s
# (i,s) = writeString {#c \\ c <- graph_cpy} i s
# (i,s) = writeInt (size descinfo) i s
# (i,s) = writeArray writeDescInfo 0 descinfo i s
# (i,s) = writeInt (size modules) i s
# (i,s) = writeArray writeTerminatedString 0 modules i s
# (i,s) = writeInt (size bytecode) i s
# (i,s) = writeString bytecode i s
| i <> string_size = abort "internal error in graphToString\n"
= (s,g)
where
	copy :: !*(b a) -> *(![a], !*b a, !Int) | Array b a
	copy arr
	# (s,arr) = usize arr
	# (cpy,arr) = copy (s-1) arr []
	= (cpy,arr,s)
	where
		copy :: !Int !*(b a) ![a] -> *(![a], !*b a) | Array b a
		copy -1 arr cpy = (cpy, arr)
		copy i  arr cpy
		# (x,arr) = arr![i]
		= copy (i-1) arr [x:cpy]

	writeInt :: !Int !Int !*String -> (!Int, !.String)
	writeInt n i s = (i+4, {s & [i]=toChar n, [i+1]=toChar (n>>8), [i+2]=toChar (n>>16), [i+3]=toChar (n>>24)})

	writeString :: !String !Int !*String -> (!Int, !.String)
	writeString src i s = (i+size src, {s & [j]=c \\ j <- [i..] & c <-: src})

	writeTerminatedString :: !String !Int !*String -> (!Int, !.String)
	writeTerminatedString src i s
	# (i,s) = writeString src i s
	= (i+1, {s & [i]='\0'})

	writeDescInfo :: !DescInfo !Int !*String -> (!Int, !.String)
	writeDescInfo di i s
	# (i,s) = writeInt di.di_prefix_arity_and_mod i s
	= writeTerminatedString di.di_name i s

	writeArray :: !(a Int *String -> (Int, *String)) !Int !{#a} !Int !*String -> (!Int, !.String) | Array {#} a
	writeArray write n arr i s
	| n >= size arr = (i,s)
	# (i,s) = write arr.[n] i s
	= writeArray write (n+1) arr i s

graph_from_string :: !String -> ? *SerializedGraph
graph_from_string s = read 0 s
where
	read :: !Int !String -> ? *SerializedGraph
	read i s
	# (i,graph_size) = readInt i s
	| i < 0 = ?None
	# (i,graph) = readString i graph_size s
	| i < 0 = ?None
	# graph = {c \\ c <-: graph}

	# (i,descinfo_size) = readInt i s
	| i < 0 = ?None
	# (i,descinfo) = readArray readDescInfo descinfo_size i s
	| i < 0 = ?None
	# descinfo = {di \\ di <- descinfo}

	# (i,modules_size) = readInt i s
	| i < 0 = ?None
	# (i,modules) = readArray readTerminatedString modules_size i s
	| i < 0 = ?None
	# modules = {mod \\ mod <- modules}

	# (i,bytecode_size) = readInt i s
	| i < 0 = ?None
	# (i,bytecode) = readString i bytecode_size s
	| i < 0 = ?None

	| i <> size s = ?None
	= ?Just {graph=graph,descinfo=descinfo,modules=modules,bytecode=bytecode}

	readInt :: !Int !String -> (!Int, !Int)
	readInt i s
	| i >= size s-4 = (-1,0)
	| otherwise = (i+4, sum [toInt s.[i+j] << (8*j) \\ j <- [0,1,2,3]])

	readString :: !Int !Int !String -> (!Int, !String)
	readString i len s
	| i > size s - len = (-1,"")
	| otherwise = (i+len, s % (i,i+len-1))

	readTerminatedString :: !Int !String -> (!Int, !String)
	readTerminatedString i s
	# len = findNull i s - i
	| len < 0 = (-1, "")
	# (i,s`) = readString i len s
	| i < 0 = (i,s`)
	= (i+1,s`)
	where
		findNull :: !Int !String -> Int
		findNull i s
		| i >= size s   = -1
		| s.[i] == '\0' = i
		| otherwise     = findNull (i+1) s

	readDescInfo :: !Int !String -> (!Int, !DescInfo)
	readDescInfo i s
	| i >= size s = (-1, {di_prefix_arity_and_mod=0, di_name=""})
	# (i,arity) = readInt i s
	| i < 0 = (-1, {di_prefix_arity_and_mod=0, di_name=""})
	# (i,name) = readTerminatedString i s
	| i < 0 = (-1, {di_prefix_arity_and_mod=0, di_name=""})
	= (i, {di_prefix_arity_and_mod=arity, di_name=name})

	readArray :: !(Int String -> (Int, a)) !Int !Int !String -> (!Int, ![a])
	readArray read len i s
	| len <= 0 = (i,[])
	# (i,x) = read i s
	| i < 0 = (i,[])
	# (i,xs) = readArray read (len-1) i s
	= (i,[x:xs])

graph_to_file :: !*SerializedGraph !*File -> *(!*SerializedGraph, !*File)
graph_to_file g f
# (s,g) = graph_to_string g
# f = f <<< size s <<< s
= (g,f)

graph_from_file :: !*File -> *(!? *SerializedGraph, !*File)
graph_from_file f
# (_,size,f) = freadi f
# (s,f) = freads f size
# g = graph_from_string s
= (g,f)

malloc :: !Int -> Pointer
malloc _ = code {
	ccall malloc "I:p"
}

readFile :: !String !*World -> (!?String, !*World)
readFile fname w
# (ok,f,w) = fopen fname FReadData w
| not ok = (?None, w)
# (ok,f) = fseek f 0 FSeekEnd
| not ok
	# (_,w) = fclose f w
	= (?None, w)
# (size,f) = fposition f
# (ok,f) = fseek f 0 FSeekSet
| not ok
	# (_,w) = fclose f w
	= (?None, w)
# (s,f) = freads f size
# (_,w) = fclose f w
= (?Just s,w)

:: Pointer :== Int

derefInt :: !Pointer -> Int
derefInt ptr = code {
	load_i 0
}

derefChar :: !Pointer -> Char
derefChar ptr = code inline {
	load_ui8 0
}

derefCharArray :: !Pointer !Int -> {#Char}
derefCharArray ptr len = copy 0 (createArray len '\0')
where
	copy :: !Int *{#Char} -> *{#Char}
	copy i arr
	| i == len = arr
	# c = derefChar (ptr+i)
	= copy (i+1) {arr & [i]=c}

derefString :: !Pointer -> String
derefString ptr
# len = findNull ptr - ptr
= derefCharArray ptr len
where
	findNull :: !Pointer -> Pointer
	findNull ptr = case derefChar ptr of
		'\0' -> ptr
		_    -> findNull (ptr+1)

prepare_prelinked_interpretation :: !String !String !*World -> *(!?PrelinkedInterpretationEnvironment, !*World)
prepare_prelinked_interpretation exefile bcfile w
# (bytecode,w) = readFile bcfile w
| bytecode =: ?None = (?None, w)
# (?Just bytecode) = bytecode

# (host_syms,w) = accFiles (read_symbols exefile) w

# pgm = parse {} bytecode // No matching with the host is required
| pgm =: ?None = (?None, w)
# (?Just pgm) = pgm
# code_start = get_code pgm

/* NB: create the node before the array comprehension; otherwise the expression
 * is evaluated twice (once to evaluate the length; then to fill the array). */
#! int_syms = getInterpreterSymbols False pgm
#! int_syms = {#s \\ s <- int_syms}
#  int_syms_64 = getInterpreterSymbols True pgm
#! int_syms_64 = IF_INT_64_OR_32 int_syms {#s \\ s <- int_syms_64}
#! sorted_syms = sortBy (\a b -> a.symbol_value < b.symbol_value) [s \\ s <-: int_syms_64]
#! sorted_syms = {#s \\ s <- sorted_syms}

# pie =
	{ pie_code_start     = code_start
	, pie_symbols        = int_syms
	, pie_symbols_64     = int_syms_64
	, pie_sorted_symbols = sorted_syms
	, pie_host_symbols   = {#find_host_sym (size host_syms-1) s.symbol_name host_syms \\ s <-: sorted_syms}
	, pie_symbol_offset  = get_array_D {} - get_symbol_value "__ARRAY__" host_syms - 2
	}
= (?Just pie, w)
where
	get_code :: !Int -> Int
	get_code pgm = code {
		ccall get_code "p:p"
	}

	find_host_sym :: !Int !String !{#Symbol} -> Int
	find_host_sym -1 _ _ = -1
	find_host_sym i s syms
		| syms.[i].symbol_name == s
			= syms.[i].symbol_value
			= find_host_sym (i-1) s syms

serialize_for_prelinked_interpretation :: a !PrelinkedInterpretationEnvironment -> String
serialize_for_prelinked_interpretation graph pie
# (graph,descinfo,modules) = copy_to_string_with_names graph
# symbols = {#predef_or_lookup_symbol (IF_INT_64_OR_32 4 3) d modules pie.pie_symbols \\ d <-: descinfo}
# symbol_values = IF_INT_64_OR_32 symbols {#predef_or_lookup_symbol 4 d modules pie.pie_symbols_64 \\ d <-: descinfo}
# graph = IF_INT_64_OR_32 graph (fixup_32_bit_graph pie.pie_symbol_offset pie.pie_code_start symbols graph)
= replace_desc_numbers_by_descs 0 graph symbol_values symbols pie.pie_code_start
where
	predef_or_lookup_symbol :: !Int !DescInfo !{#String} !{#Symbol} -> Int
	predef_or_lookup_symbol arity_shift di mods syms
	# module_name = mods.[(di.di_prefix_arity_and_mod>>8)-1]
	| module_name == "_system" = case di.di_name of
		"_ARRAY_"  -> pie.pie_code_start-1*8+2
		"_STRING_" -> pie.pie_code_start-2*8+2
		"BOOL"     -> pie.pie_code_start-3*8+2
		"CHAR"     -> pie.pie_code_start-4*8+2
		"REAL"     -> pie.pie_code_start-5*8+2
		"INT"      -> pie.pie_code_start-6*8+2
		"_ind"     -> pie.pie_code_start-7*8+2
		_          -> lookup_symbol_value arity_shift di mods syms
	| otherwise    =  lookup_symbol_value arity_shift di mods syms

	// This is like the function with the same name in GraphCopy's
	// graph_copy_with_names, but it assigns even negative descriptor numbers
	// to predefined symbols so that it matches predef_or_lookup_symbol above.
	replace_desc_numbers_by_descs :: !Int !*{#Char} !{#Int} !{#Int} !Int -> *{#Char}
	replace_desc_numbers_by_descs i s symbol_values symbols code_start
	| i>=size s
		| i==size s = s
		| otherwise = abort "error in replace_desc_numbers_by_descs\n"
	#! (desc,s) = get_word_from_string s i
	| desc<0
		= replace_desc_numbers_by_descs (i+8) s symbol_values symbols code_start
	# val = symbol_values.[desc-1]
	# desc = symbols.[desc-1]
	# s = store_int_in_string s i (val-code_start)
	| desc bitand 2==0
		# d = get_thunk_n_non_pointers desc
		= replace_desc_numbers_by_descs (i+8+(d<<3)) s symbol_values symbols code_start
	# (d,not_array) = get_descriptor_n_non_pointers_and_not_array_interpreter code_start desc
	| not_array
		= replace_desc_numbers_by_descs (i+8+(d<<3)) s symbol_values symbols code_start
	| d==0 // _STRING_
		#! (l,s) = get_word_from_string s (i+8)
		# l = (l+7) bitand -8
		= replace_desc_numbers_by_descs (i+16+l) s symbol_values symbols code_start
	| d==1 // _ARRAY_
		#! (d,s) = get_word_from_string s (i+16)
		| d==0
			= replace_desc_numbers_by_descs (i+24) s symbol_values symbols code_start
		# val = symbol_values.[d-1]
		# d = symbols.[d-1]
		# s = store_int_in_string s (i+16) (val-code_start)
		#! (l,s) = get_word_from_string s (i+8)
		| d==code_start-5*8+2 // REAL
			# l = l << 3
			= replace_desc_numbers_by_descs (i+24+l) s symbol_values symbols code_start
		| d==code_start-6*8+2 // INT
			# l = l << 3
			= replace_desc_numbers_by_descs (i+24+l) s symbol_values symbols code_start
		| d==code_start-3*8+2 // BOOL
			# l = (l+7) bitand -8
			= replace_desc_numbers_by_descs (i+24+l) s symbol_values symbols code_start
		# arity = get_D_node_arity d
		| arity>=256
			# record_a_arity = get_D_record_a_arity d
			# record_b_arity = arity-256-record_a_arity
			# l = (l * record_b_arity) << 3
			= replace_desc_numbers_by_descs (i+24+l) s symbol_values symbols code_start
		= abort (toString l+++" "+++toString d)

/* To deserialize a graph from the prelinked interpreter we first need to
 * convert the string to the right format to pass to `copy_from_string`. This
 * means:
 * 1. Fixing the offset of descriptors based on `pie_symbol_offset`, so that
 *    they match the descriptors in the host instead of those in the
 *    interpreter. This is done in `replace_descs`.
 * 2. On 32-bit systems, convert the string to use 4-bit instead of 8-bit
 *    integers (including descriptors). This is done in `fixup_64_bit_graph`.
 *    This is needed because the 32-bit implementation of GraphCopy expects the
 *    string this way whereas the prelinked interpreter always runs in 64-bit
 *    mode. Unfortunately this means integer overflow issues. Also, `Real`
 *    values are not handled properly because a `Real` takes 2 stack spaces on
 *    32-bit systems but only 1 on 64-bit systems.
 * 3. On systems with address space randomization (position-independent code),
 *    subtracting `_ARRAY_` from the descriptors. On 64-bit systems this is
 *    done in `replace_descs`, but on 32-bit systems this is done in
 *    `fixup_64_bit_graph`.
 * After this the string is passed to GraphCopy's `copy_from_string`.
 */
deserialize_from_prelinked_interpreter :: !*String !PrelinkedInterpretationEnvironment -> (.a,!Int)
deserialize_from_prelinked_interpreter s pie
# array_desc = if
	/* On 32-bit systems with position-independent code, _ARRAY_ is subtracted
	 * in `fixup_64_bit_graph`. */
	(IF_INT_64_OR_32 (is_using_desc_relative_to_array==1) False)
	(get_array_D {} - 2)
	pie.pie_symbol_offset
#! s = replace_descs 0 s pie.pie_symbol_offset array_desc
#! s = IF_INT_64_OR_32 s (fixup_64_bit_graph pie.pie_symbol_offset s)
= copy_from_string s
where
	replace_descs :: !Int !*String !Int !Int -> *String
	replace_descs i s symbol_offset array_desc
	| i>=size s
		| i==size s = s
		| otherwise = abort "error in replace_descs\n"
	#! (desc,s) = get_word_from_string s i
	| desc<0 && desc rem 2<>0 // redirection
		= replace_descs (i+8) s symbol_offset array_desc
	#! desc = find_desc symbol_offset desc
	#! desc = desc + symbol_offset
	#! s = store_int_in_string s i (desc-array_desc)
	| desc bitand 2==0
		# d = get_thunk_n_non_pointers desc
		= replace_descs (i+8+(d<<3)) s symbol_offset array_desc
	#! (d,not_array) = get_descriptor_n_non_pointers_and_not_array_native desc
	| not_array
		= replace_descs (i+8+(d<<3)) s symbol_offset array_desc
	#! (l,s) = get_word_from_string s (i+8)
	| d==0 // _STRING_
		#! l = (l+7) bitand -8
		= replace_descs (i+16+l) s symbol_offset array_desc
	| d==1 // _ARRAY_
		#! (old_elem_desc,s) = get_word_from_string s (i+16)
		| old_elem_desc==0
			= replace_descs (i+24) s symbol_offset array_desc
		#! elem_desc = find_desc symbol_offset old_elem_desc
		#! elem_desc = elem_desc + symbol_offset
		#! s = store_int_in_string s (i+16) (elem_desc-array_desc)
		| old_elem_desc== -46 || old_elem_desc== -38 // INT or REAL
			#! l = l<<3
			= replace_descs (i+24+l) s symbol_offset array_desc
		| old_elem_desc== -22 // BOOL
			#! l = (l+7) bitand -8
			= replace_descs (i+24+l) s symbol_offset array_desc
		#! rec_arity = get_D_node_arity elem_desc
		| rec_arity<256 = abort
			("illegal array element descriptor "+++toString elem_desc+++
				" with arity "+++toString rec_arity+++"\n")
		#! a_arity = get_D_record_a_arity elem_desc
		#! b_arity = rec_arity-256-a_arity
		#! l = (l*b_arity) << 3
		= replace_descs (i+24+l) s symbol_offset array_desc

	find_desc :: !Int !Int -> Int
	find_desc symbol_offset d
	| d<0 = find_predef_desc d
	# d = d+pie.pie_code_start
	# idx = find_desc 0 (size pie.pie_sorted_symbols-1) d
	# sym = pie.pie_sorted_symbols.[idx]
	# offset = fix_offset (d-sym.symbol_value)
	# d = pie.pie_host_symbols.[idx]
	| d<0
		= abort ("replace_descs: descriptor "+++sym.symbol_name+++" unknown in the host\n")
		= d+offset
	where
		find_predef_desc :: !Int -> Int
		find_predef_desc d = case d of
			-46 -> get_D 1 - symbol_offset
			-14 -> get_string_D "" - symbol_offset
			-22 -> get_D True - symbol_offset
			-30 -> get_D 'a' - symbol_offset
			-6  -> get_array_D {} - symbol_offset
			-38 -> get_D 1.0 - symbol_offset
			_   -> abort ("unknown predefined descriptor "+++toString d+++"\n")
		where
			get_string_D :: !String -> Int
			get_string_D _ = code {
				pushD_a 0
				pop_a 1
			}
			get_D :: !a -> Int
			get_D _ = code {
				pushD_a 0
				pop_a 1
			}

		find_desc :: !Int !Int !Int -> Int
		find_desc start end d
		| start>end
			| start>0 && pie.pie_sorted_symbols.[start-1].symbol_value<d
				= start-1
				= abort "find_desc failed\n"
		# mid = start + (end-start)/2
		# v = pie.pie_sorted_symbols.[mid].symbol_value
		| d<v = find_desc start (mid-1) d
		| d>v = find_desc (mid+1) end d
		| otherwise = mid

		fix_offset :: !Int -> Int
		fix_offset offset
		# (arity,add) = (offset/16, offset rem 16)
		| add==2 = get_desc_arity_offset*arity+2
		| add==0 && arity==0 = 0
		| otherwise = abort ("illegal offset "+++toString offset+++"\n")
		where
			get_desc_arity_offset :: Int
			get_desc_arity_offset = code {
				get_desc_arity_offset
			}

resolve_pie_symbol :: !Int !PrelinkedInterpretationEnvironment -> (!?String, !Int)
resolve_pie_symbol loc {pie_sorted_symbols,pie_code_start} =
	search ((loc << 3) + pie_code_start) 0 (size pie_sorted_symbols-1)
where
	search loc lo hi
		| lo > hi
			| hi >= 0
				# {symbol_name,symbol_value} = pie_sorted_symbols.[hi]
				= (?Just symbol_name, (loc-symbol_value) >> 3)
				= (?None, loc)
		# mid = lo + (hi-lo+1) / 2
		# {symbol_name,symbol_value} = pie_sorted_symbols.[mid]
		| symbol_value < loc
			= search loc (mid+1) hi
		| symbol_value > loc
			= search loc lo (mid-1)
			= (?Just symbol_name, 0)

/**
 * Given a graph from 32-bit graphcopy, create the 64-bit graph that we can
 * send to the prelinked interpreter (which is always 64-bit).
 * TODO: this does not work if the graph contains Reals!
 */
fixup_32_bit_graph :: !Int !Int !{#Int} !*String -> *String
fixup_32_bit_graph symbol_offset code_start symbol_values s
# (ns,s) = new_size s 0 0
= copy s 0 (createArray ns '\0') 0
where
	new_size :: !*{#Char} !Int !Int -> (!Int, !*{#Char})
	new_size s i len
	| i>=size s
		| i==size s = (len,s)
		| otherwise = abort "error in fixup_32_bit_graph\n"
	# (desc,s) = get_word_from_string s i
	| desc<0 && desc rem 2<>0 // redirection
		= new_size s (i+4) (len+8)
	# desc = symbol_values.[desc-1]
	| desc bitand 2==0
		# d = get_thunk_n_non_pointers desc
		= new_size s (i+4+(d<<2)) (len+8+(d<<3)) // TODO: check for Reals
	# (d,not_array) = get_descriptor_n_non_pointers_and_not_array_interpreter code_start desc
	| not_array
		| d==1 && desc==code_start-5*8+2 // REAL
			= new_size s (i+12) (len+16)
			= new_size s (i+4+(d<<2)) (len+8+(d<<3))
	# (l,s) = get_word_from_string s (i+4)
	| d==0 // _STRING_
		= new_size s (i+8+((l+3) bitand -4)) (len+16+((l+7) bitand -8))
	| d==1 // _ARRAY_
		# (d,s) = get_word_from_string s (i+8)
		| d==0
			= new_size s (i+12) (len+24)
		# d = symbol_values.[d-1]
		| d==code_start-5*8+2 // REAL
			= abort "{#Real} in fixup_32_bit_graph\n" // TODO
		| d==code_start-6*8+2 // INT
			= new_size s (i+12+(l<<2)) (len+24+(l<<3))
		| d==code_start-3*8+2 // BOOL
			= new_size s (i+12+((l+3) bitand -4)) (len+24+((l+7) bitand -8))
		# arity = get_D_node_arity d
		| arity>=256
			# record_a_arity = get_D_record_a_arity d
			# record_b_arity = arity-256-record_a_arity
			= new_size s (i+12+((l*record_b_arity)<<2)) (len+24+((l*record_b_arity)<<3))
			= abort "error in fixup_32_bit_graph ({#})\n"

	copy :: !*{#Char} !Int !*{#Char} !Int -> .String
	copy old oi new ni
	| oi>=size old
		| oi==size old = new
		| otherwise    = abort "error in fixup_32_bit_graph\n"
	# (desc,old) = get_word_from_string old oi
	| desc<0 && desc rem 2<>0 // redirection
		# (ref,old) = get_word_from_string old (oi+desc-1)
		# new = store_int_in_string new ni (1+ref-ni)
		# new = store_int_in_string new (ni+4) -1
		= copy old (oi+4) new (ni+8)
	# old = store_int_in_string old oi ni // to fix redirections
	# new = store_int_in_string new ni desc
	# desc = symbol_values.[desc-1]
	| desc bitand 2==0
		# d = get_thunk_n_non_pointers desc
		# (old,oi,new,ni) = copy_words d old (oi+4) new (ni+8) // TODO: check for Reals
		= copy old oi new ni
	# (d,not_array) = get_descriptor_n_non_pointers_and_not_array_interpreter code_start desc
	| not_array
		| d==1 && desc==code_start-5*8+2 // REAL
			# (v,old) = get_word_from_string old (oi+4)
			# new = store_int_in_string new (ni+8) v
			# (v,old) = get_word_from_string old (oi+8)
			# new = store_int_in_string new (ni+12) v
			= copy old (oi+12) new (ni+16)
		# (old,oi,new,ni) = copy_words d old (oi+4) new (ni+8) // TODO: check for Reals
		= copy old oi new ni
	# (l,old) = get_word_from_string old (oi+4)
	# new = store_int_in_string new (ni+8) l
	| d==0 // _STRING_
		# (old,oi,new,ni) = copy_chars l old (oi+8) new (ni+16)
		= copy old oi new ni
	| d==1 // _ARRAY_
		# (d,old) = get_word_from_string old (oi+8)
		# new = store_int_in_string new (ni+16) d
		# new = if (d<0) (store_int_in_string new (ni+20) -1) new
		| d==0
			= copy old (oi+12) new (ni+24)
		# d = symbol_values.[d-1]
		| d==code_start-5*8+2 // REAL
			= abort "{#Real} in fixup_32_bit_graph\n" // TODO
		| d==code_start-6*8+2 // INT
			# (old,oi,new,ni) = copy_words l old (oi+12) new (ni+24)
			= copy old oi new ni
		| d==code_start-3*8+2 // BOOL
			# (old,oi,new,ni) = copy_chars l old (oi+12) new (ni+24)
			= copy old oi new ni
		# arity = get_D_node_arity d
		| arity>=256
			# record_a_arity = get_D_record_a_arity d
			# record_b_arity = arity-256-record_a_arity
			# (old,oi,new,ni) = copy_words (l*record_b_arity) old (oi+12) new (ni+24)
			= copy old oi new ni
			= abort "error in fixup_32_bit_graph ({#})\n"
	where
		copy_words :: !Int !*{#Char} !Int !*{#Char} !Int -> (!*{#Char},!Int,!*{#Char},!Int)
		copy_words n old oi new ni
		| n==0 = (old,oi,new,ni)
		# (v,old) = get_word_from_string old oi
		# new = store_int_in_string new ni v
		| v<0
			# new = store_int_in_string new (ni+4) -1
			= copy_words (n-1) old (oi+4) new (ni+8)
			= copy_words (n-1) old (oi+4) new (ni+8)

		copy_chars :: !Int !*{#Char} !Int !*{#Char} !Int -> (!*{#Char},!Int,!*{#Char},!Int)
		copy_chars n old oi new ni
		| n>=4
			# (v,old) = get_word_from_string old oi
			# new = store_int_in_string new ni v
			= copy_chars (n-4) old (oi+4) new (ni+4)
		| n==0
			= (old,(oi+3) bitand -4,new,(ni+7) bitand -8)
			# (c,old) = old![oi]
			# new & [ni] = c
			= copy_chars (n-1) old (oi+1) new (ni+1)

/**
 * Given a graph from the 64-bit prelinked interpreter, in which symbols have
 * been corrected to their respective host values, create the 32-bit graph that
 * we can use in GraphCopy (which is 32-bit on 32-bit systems).
 * TODO: this does not work if the graph contains Reals!
 */
fixup_64_bit_graph :: !Int !*String -> *String
fixup_64_bit_graph symbol_offset s
# (ns,s) = new_size s 0 0
# array_desc = if (is_using_desc_relative_to_array==1) (get_array_D {}-2) 0
= copy array_desc s 0 (createArray ns '\0') 0
where
	new_size :: !*{#Char} !Int !Int -> (!Int, !*{#Char})
	new_size s i len
	| i>=size s
		| i==size s = (len,s)
		| otherwise = abort "error in fixup_64_bit_graph\n"
	# (desc,s) = get_word_from_string s i
	| desc<0 && desc rem 2<>0 // redirection
		= new_size s (i+8) (len+4)
	# desc = desc + symbol_offset
	| desc bitand 2==0
		# d = get_thunk_n_non_pointers desc
		= new_size s (i+8+(d<<3)) (len+4+(d<<2)) // TODO: check for Reals
	# (d,not_array) = get_descriptor_n_non_pointers_and_not_array_native desc
	| not_array
		= new_size s (i+8+(d<<3)) (len+4+(d<<2)) // TODO: check for Reals
	# (l,s) = get_word_from_string s (i+8)
	| d==0 // _STRING_
		= new_size s (i+16+((l+7) bitand -8)) (len+8+((l+3) bitand -4))
	| d==1 // _ARRAY_
		# (d,s) = get_word_from_string s (i+16)
		| d==0
			= new_size s (i+24) (len+12)
		# d = d + symbol_offset
		| is_Real_D d
			= abort "{#Real} in fixup_64_bit_graph\n" // TODO
		| is_Int_D d
			= new_size s (i+24+(l<<3)) (len+12+(l<<2))
		| is_Bool_D d
			= new_size s (i+24+((l+7) bitand -8)) (len+12+((l+3) bitand -4))
		# arity = get_D_node_arity d
		| arity>=256
			# record_a_arity = get_D_record_a_arity d
			# record_b_arity = arity-256-record_a_arity
			= new_size s (i+24+((l*record_b_arity)<<3)) (len+12+((l*record_b_arity)<<3))
			= abort "error in fixup_64_bit_graph ({#})\n"

	copy :: !Int !*{#Char} !Int !*{#Char} !Int -> *{#Char}
	copy array_desc old oi new ni
	| oi>=size old
		| oi==size old = new
		| otherwise    = abort "error in fixup_64_bit_graph\n"
	# (desc,old) = get_word_from_string old oi
	| desc<0 && desc rem 2<>0 // redirection
		# (ref,old) = get_word_from_string old (oi+desc-1)
		# new = store_int_in_string new ni (1+ref-ni)
		= copy array_desc old (oi+8) new (ni+4)
	# old = store_int_in_string old oi ni // to fix redirections
	# desc = desc + symbol_offset
	# new = store_int_in_string new ni (desc-array_desc)
	| desc bitand 2==0
		# d = get_thunk_n_non_pointers desc
		# (old,oi,new,ni) = copy_words d old (oi+8) new (ni+4) // TODO: check for Reals
		= copy array_desc old oi new ni
	# (d,not_array) = get_descriptor_n_non_pointers_and_not_array_native desc
	| not_array
		# (old,oi,new,ni) = copy_words d old (oi+8) new (ni+4) // TODO: check for Reals
		= copy array_desc old oi new ni
	# (l,old) = get_word_from_string old (oi+8)
	# new = store_int_in_string new (ni+4) l
	| d==0 // _STRING_
		# (old,oi,new,ni) = copy_chars l old (oi+16) new (ni+8)
		= copy array_desc old oi new ni
	| d==1 // _ARRAY_
		# (d,old) = get_word_from_string old (oi+16)
		# new = store_int_in_string new (ni+8) (d-array_desc)
		| d==0
			= copy array_desc old (oi+24) new (ni+12)
		# d = d + symbol_offset
		| is_Real_D d
			= abort "{#Real} in fixup_64_bit_graph\n" // TODO
		| is_Int_D d
			# (old,oi,new,ni) = copy_words l old (oi+24) new (ni+12)
			= copy array_desc old oi new ni
		| is_Bool_D d
			# (old,oi,new,ni) = copy_chars l old (oi+24) new (ni+12)
			= copy array_desc old oi new ni
		# arity = get_D_node_arity d
		| arity>=256
			# record_a_arity = get_D_record_a_arity d
			# record_b_arity = arity-256-record_a_arity
			# (old,oi,new,ni) = copy_words (l*record_b_arity) old (oi+24) new (ni+12)
			= copy array_desc old oi new ni
			= abort "error in fixup_64_bit_graph ({#})\n"
	where
		copy_words :: !Int !*{#Char} !Int !*{#Char} !Int -> (!*{#Char},!Int,!*{#Char},!Int)
		copy_words n old oi new ni
		| n==0 = (old,oi,new,ni)
		# (v,old) = get_word_from_string old oi
		# new = store_int_in_string new ni v
		= copy_words (n-1) old (oi+8) new (ni+4)

		copy_chars :: !Int !*{#Char} !Int !*{#Char} !Int -> (!*{#Char},!Int,!*{#Char},!Int)
		copy_chars n old oi new ni
		| n>=4
			# (v,old) = get_word_from_string old oi
			# new = store_int_in_string new ni v
			= copy_chars (n-4) old (oi+4) new (ni+4)
		| n==0
			= (old,(oi+7) bitand -8,new,(ni+3) bitand -4)
			# (c,old) = old![oi]
			# new & [ni] = c
			= copy_chars (n-1) old (oi+1) new (ni+1)

// Supporting code for serialize_for_prelinked_interpretation and
// deserialize_from_prelinked_interpreter, taken from GraphCopy
get_word_from_string :: !.{#Char} !Int -> (!Int, !.{#Char}) // like get_D_from_string from GraphCopy
get_word_from_string s i = IF_INT_64_OR_32 (get_64 s i) (get_32 s i)
where
	get_64 :: !.{#Char} !Int -> (!Int, !.{#Char})
	get_64 s i = code inline {
		push_a_b 0
		addI
		load_i 16
	}

	get_32 :: !.{#Char} !Int -> (!Int, !.{#Char})
	get_32 s i = code inline {
		push_a_b 0
		addI
		load_i 8
	}

store_int_in_string :: !*{#Char} !Int !Int -> *{#Char} // 64-bit version
store_int_in_string s i n = IF_INT_64_OR_32 store_int_in_string_64 store_int_in_string_32
where
	store_int_in_string_64 =
		{ s
		& [i]=toChar n,[i+1]=toChar (n>>8),[i+2]=toChar (n>>16),[i+3]=toChar (n>>24)
		, [i+4]=toChar (n >> 32),[i+5]=toChar (n>>40),[i+6]=toChar (n>>48),[i+7]=toChar (n>>56)
		}

	store_int_in_string_32 =
		{ s
		& [i]=toChar n,[i+1]=toChar (n>>8),[i+2]=toChar (n>>16),[i+3]=toChar (n>>24)
		}

get_array_D :: !{#Int} -> Int
get_array_D _ = code {
	pushD_a 0
	pop_a 1
}

get_descriptor_n_non_pointers_and_not_array_native :: !Int -> (!Int,!Bool)
get_descriptor_n_non_pointers_and_not_array_native d
	# arity = get_D_node_arity d
	| arity==0
		| is_Int_D d      = (1,True)
		| is_Char_D d     = (1,True)
		| is_Real_D d     = (1,True)
		| is_Bool_D d     = (1,True)
		| is__String__D d = (0,False)
		| is__Array__D d  = (1,False)
		| otherwise       = (0,True)
	| arity<256
		= (0,True)
		# record_a_arity = get_D_record_a_arity d
		# record_b_arity = arity-256-record_a_arity
		= (record_b_arity,True)

is_Int_D :: !Int -> Bool
is_Int_D d = code inline {
	eq_desc_b INT 0
}
is_Char_D :: !Int -> Bool
is_Char_D d = code inline {
	eq_desc_b CHAR 0
}
is_Real_D :: !Int -> Bool
is_Real_D d = code inline {
	eq_desc_b REAL 0
}
is_Bool_D :: !Int -> Bool
is_Bool_D d = code inline {
	eq_desc_b BOOL 0
}
is__String__D :: !Int -> Bool
is__String__D d = code inline {
	eq_desc_b _STRING_ 0
}
is__Array__D :: !Int -> Bool
is__Array__D d = code inline {
	eq_desc_b _ARRAY_ 0
}

get_descriptor_n_non_pointers_and_not_array_interpreter :: !Int !Int -> (!Int,!Bool)
get_descriptor_n_non_pointers_and_not_array_interpreter code_start d
| d<code_start
	| d==code_start-1*8+2 = (1,False) // _ARRAY_
	| d==code_start-2*8+2 = (0,False) // _STRING_
	| d==code_start-3*8+2 = (1,True)  // BOOL
	| d==code_start-4*8+2 = (1,True)  // CHAR
	| d==code_start-5*8+2 = (1,True)  // REAL
	| d==code_start-6*8+2 = (1,True)  // INT
	| d==code_start-7*8+2 = (0,True)  // _ind
	| otherwise = abort "internal error in get_descriptor_n_non_pointers_and_not_array_interpreter\n"
# arity = get_D_node_arity d
| arity<256 = (0,True)
# record_a_arity = get_D_record_a_arity d
# record_b_arity = arity-256-record_a_arity
= (record_b_arity,True)

get_thunk_n_non_pointers:: !Int -> Int
get_thunk_n_non_pointers d
# arity = get_thunk_arity d
| arity<256
	= 0
	# b_size = arity>>8
	= b_size
where
	get_thunk_arity :: !Int -> Int
	get_thunk_arity a = code {
		get_thunk_arity
	}

get_D_node_arity :: !Int -> Int
get_D_node_arity d = code inline {
	load_si16 -2
}

get_D_record_a_arity :: !Int -> Int
get_D_record_a_arity d = code inline {
	load_si16 0
}

is_using_desc_relative_to_array :: Int
is_using_desc_relative_to_array = code {
	ccall is_using_desc_relative_to_array ":I"
}
