Merge branch 'unrelocated-serialization' into 'master'

Add deserialization support for the WebAssembly interpreter

See merge request !103

lib/ABC/Interpreter.dcl

@@ -63,6 +63,17 @@ defaultDeserializationSettings :: DeserializationSettings
  */
 serialize :: a !String !*World -> *(!Maybe SerializedGraph, !*World)
 
+/**
+ * Serialize an expression for unrelocated interpretation. This is a mode of
+ * interpretation where the code and data addresses are fixed. It is useful for
+ * the WebAssembly interpreter where memory always starts at index 0.
+ *
+ * @param The value to serialize.
+ * @param The path to the executable's bytecode (set by the `ByteCode` option in the project file).
+ * @result The result may be `Nothing` if the bytecode could not be parsed.
+ */
+serialize_for_unrelocated_interpretation :: a !String !String !*World -> *(!Maybe String, !*World)
+
 /**
  * Deserialize an expression using the ABC interpreter.
  * This version copies nodes as soon as they are in head normal form.

lib/ABC/Interpreter.icl

 implementation module ABC.Interpreter
 
 import StdArray
+import StdBool
 import StdClass
 import StdFile
 import StdInt
@@ -42,20 +43,20 @@ defaultDeserializationSettings =
 
 serialize :: a !String !*World -> *(!Maybe SerializedGraph, !*World)
 serialize graph bcfile w
-# (graph,descs,mods) = copy_to_string_with_names graph
+# (graph,descinfo,modules) = copy_to_string_with_names graph
 
 # (bytecode,w) = readFile bcfile w
 | isNothing bytecode = (Nothing, w)
 # bytecode = fromJust bytecode
 
-#! (len,bytecodep) = strip_bytecode bytecode {#symbol_name di mods \\ di <-: descs}
+#! (len,bytecodep) = strip_bytecode bytecode {#symbol_name di modules \\ di <-: descinfo}
 #! bytecode = derefCharArray bytecodep len
 | free_to_false bytecodep = (Nothing, w)
 
 # rec =
 	{ graph    = graph
-	, descinfo = descs
-	, modules  = mods
+	, descinfo = descinfo
+	, modules  = modules
 	, bytecode = bytecode
 	}
 = (Just rec, w)
@@ -74,6 +75,144 @@ where
 		ccall strip_bytecode "sA:VIp"
 	}
 
+serialize_for_unrelocated_interpretation :: a !String !String !*World -> *(!Maybe String, !*World)
+serialize_for_unrelocated_interpretation graph bcfile thisexe w
+# (host_syms,w) = accFiles (read_symbols thisexe) w
+
+# (graph,descinfo,modules) = copy_to_string_with_names graph
+
+# (bytecode,w) = readFile bcfile w
+| isNothing bytecode = (Nothing, w)
+# bytecode = fromJust bytecode
+
+# pgm = parse host_syms bytecode
+| isNothing pgm = (Nothing, w)
+# pgm = fromJust pgm
+# code_start = get_code pgm
+
+# int_syms = {#s \\ s <- getInterpreterSymbols pgm}
+# int_syms = {#predef_or_lookup_symbol code_start d modules int_syms \\ d <-: descinfo}
+
+# graph = replace_desc_numbers_by_descs 0 graph int_syms 0 code_start // relocate relative to beginning of code segment
+= (Just graph, w)
+where
+	get_code :: !Pointer -> Pointer
+	get_code pgm = code {
+		ccall get_code "p:p"
+	}
+
+	predef_or_lookup_symbol :: !Int !DescInfo !{#String} !{#Symbol} -> Int
+	predef_or_lookup_symbol code_start di mods syms = case di.di_name of
+		"_ARRAY_"  -> code_start-1*8+2
+		"_STRING_" -> code_start-2*8+2
+		"BOOL"     -> code_start-3*8+2
+		"CHAR"     -> code_start-4*8+2
+		"REAL"     -> code_start-5*8+2
+		"INT"      -> code_start-6*8+2
+		"dINT"     -> code_start-6*8+2
+		_          -> lookup_symbol_value 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_a symbol_offset array_desc
+	| i>=size s
+		| i==size s = s
+		| otherwise = abort "error in replace_desc_numbers_by_descs\n"
+	#! desc=get_word_from_string s i
+	| desc<0
+		= replace_desc_numbers_by_descs (i+IF_INT_64_OR_32 8 4) s symbol_a symbol_offset array_desc
+	# desc = symbol_a.[desc-1]
+	# 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_desc_numbers_by_descs (i+(IF_INT_64_OR_32 8 4)+(d<<(IF_INT_64_OR_32 3 2))) s symbol_a symbol_offset array_desc
+	# (d,not_array) = get_descriptor_n_non_pointers_and_not_array desc
+	| not_array
+		= replace_desc_numbers_by_descs (i+(IF_INT_64_OR_32 8 4)+(d<<(IF_INT_64_OR_32 3 2))) s symbol_a symbol_offset array_desc
+	| d==0 // _STRING_
+		#! l = get_word_from_string s (i+IF_INT_64_OR_32 8 4)
+		# l = IF_INT_64_OR_32 ((l+7) bitand -8) ((l+3) bitand -4)
+		= replace_desc_numbers_by_descs (i+(IF_INT_64_OR_32 16 8)+l) s symbol_a symbol_offset array_desc
+	| d==1 // _ARRAY_
+		#! d = get_word_from_string s (i+IF_INT_64_OR_32 16 8)
+		| d==0
+			= replace_desc_numbers_by_descs (i+(IF_INT_64_OR_32 24 12)) s symbol_a symbol_offset array_desc
+		# d = symbol_a.[d-1]
+		# d = d+symbol_offset
+		# s=store_int_in_string s (i+IF_INT_64_OR_32 16 8) (d-array_desc)
+		#! l = get_word_from_string s (i+IF_INT_64_OR_32 8 4)
+		| d==array_desc-5*8+2 // REAL
+			# l = l << IF_INT_64_OR_32 3 2
+			= replace_desc_numbers_by_descs (i+(IF_INT_64_OR_32 24 12)+l) s symbol_a symbol_offset array_desc
+		| d==array_desc-6*8+2 // INT
+			# l = l << 3
+			= replace_desc_numbers_by_descs (i+(IF_INT_64_OR_32 24 12)+l) s symbol_a symbol_offset array_desc
+		| d==array_desc-3*8+2 // BOOL
+			# l = IF_INT_64_OR_32 ((l+7) bitand -8) ((l+3) bitand -4)
+			= replace_desc_numbers_by_descs (i+(IF_INT_64_OR_32 24 12)+l) s symbol_a symbol_offset array_desc
+		# 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) << IF_INT_64_OR_32 3 2
+			= replace_desc_numbers_by_descs (i+(IF_INT_64_OR_32 24 12)+l) s symbol_a symbol_offset array_desc
+		= abort (toString l+++" "+++toString d)
+	where
+		get_word_from_string :: !{#Char} !Int -> Int // get_D_from_string_64
+		get_word_from_string s i = code inline {
+			push_a_b 0
+			pop_a 1
+			addI
+			load_i 16
+		}
+
+		store_int_in_string :: !*{#Char} !Int !Int -> *{#Char} // 64-bit variant
+		store_int_in_string s i n =
+			{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)}
+
+		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 // 64-bit version
+			get_thunk_arity a = code {
+				load_si32 -4
+			}
+
+		get_descriptor_n_non_pointers_and_not_array :: !Int -> (!Int,!Bool)
+		get_descriptor_n_non_pointers_and_not_array d
+		| d<array_desc
+			| d==array_desc-1*8+2 = (1,False) // _ARRAY_
+			| d==array_desc-2*8+2 = (0,False) // _STRING_
+			| d==array_desc-3*8+2 = (1,True)  // BOOL
+			| d==array_desc-4*8+2 = (1,True)  // CHAR
+			| d==array_desc-5*8+2 = (IF_INT_64_OR_32 1 2,True) // REAL
+			| d==array_desc-6*8+2 = (1,True)  // INT/dINT
+			| otherwise = abort "internal error in serialize_for_unrelocated_interpretation\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_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
+		}
+
 deserialize :: !DeserializationSettings !SerializedGraph !String !*World -> *(!Maybe a, !*World)
 deserialize dsets graph thisexe w = deserialize` False dsets graph thisexe w
 

src-js/interpret.js

@@ -95,6 +95,29 @@ intp = new Uint8Array(intp);
 		{
 			clean: {
 				memory: memory,
+
+				debug: function(what,a,b,c) {
+					switch (what) {
+						case 0:
+							console.log('loop',a,'/',b,'; hp at',c);
+							break;
+						case 1:
+							console.log('desc',a);
+							break;
+						case 2:
+							console.log('arity',a);
+							break;
+						case 3:
+							console.log('unimplemented:',['large hnf','thunk'][a]);
+							break;
+						case 4:
+							console.log('redirect',a,c,'(from',b,')');
+							break;
+						case 5:
+							console.log('a arity',a);
+							break;
+					}
+				}
 			}
 		}
 	);
@@ -192,6 +215,20 @@ intp = new Uint8Array(intp);
 		});
 	}
 
+	var i=scriptArgs.indexOf('--graph');
+	if (i >= 0) {
+		var graph = os.file.readFile(scriptArgs[i+1], 'binary');
+		graph = new Uint32Array(graph.buffer);
+		var unused_semispace = util.instance.exports.get_unused_semispace();
+		for (var i=0; i<graph.length; i++)
+			membuffer[unused_semispace/4+i] = graph[i];
+		var node = hp;
+		hp = util.instance.exports.copy_from_string(unused_semispace,graph.length/2,asp,bsp,hp,code_offset*8);
+		asp+=8;
+		membuffer[asp/4] = node;
+		start+=32; /* skip bootstrap to build start node; jump to _print_graph */
+	}
+
 	var time_start=new Date().getTime();
 
 	var r=intp.instance.exports.interpret(start, asp, bsp, csp, hp, heap_size/8);

src-js/util.wat

 (module
 	(import "clean" "memory" (memory 1))
+	;;(func $debug (import "clean" "debug") (param i32 i32 i32 i32))
 
 	(global $start-heap (mut i32) (i32.const 0))
 	(global $half-heap (mut i32) (i32.const 0))
@@ -87,6 +88,14 @@
 		(global.set $caf-list (local.get 3))
 	)
 
+	(func (export "get_unused_semispace") (result i32)
+		(select
+			(global.get $half-heap)
+			(global.get $start-heap)
+			(global.get $in-first-semispace)
+		)
+	)
+
 	;; upper half of result is new hp pointer;
 	;; lower half is hp-free
 	(func (export "gc") (param $asp i32) (result i64)
@@ -545,4 +554,476 @@
 			(i32.lt_s (local.get $arity) (i32.const 2))
 		)
 	)
+
+	(func $copy (param $to i32) (param $from i32) (param $n-words i32)
+		(block $end
+			(loop $loop
+				(local.set $n-words (i32.sub (local.get $n-words) (i32.const 1)))
+				(br_if $end (i32.lt_s (local.get $n-words) (i32.const 0)))
+				(i64.store
+					(i32.add (local.get $to) (i32.shl (local.get $n-words) (i32.const 3)))
+					(i64.load (i32.add (local.get $from) (i32.shl (local.get $n-words) (i32.const 3)))))
+				(br $loop)
+			)
+		)
+	)
+
+	(func (export "copy_from_string")
+		(param $s i32) (param $len i32)
+		(param $asp i32) (param $bsp i32) (param $hp i32)
+		(param $code-offset i32)
+		(result i32)
+
+		(local $ptr-stack i32)
+		(local $a-size-stack i32)
+		(local $i i32)
+		(local $desc i32)
+		(local $a-arity i32)
+		(local $b-arity i32)
+		(local $arity i32)
+		(local $a i32)
+		(local $j i32)
+		(local $k i32)
+
+		(local.set $ptr-stack (local.get $asp))
+		(local.set $a-size-stack (local.get $bsp))
+
+		(i32.store (local.tee $ptr-stack (i32.add (local.get $ptr-stack) (i32.const 4))) (local.get $s)) ;; dummy
+		(i32.store (local.tee $a-size-stack (i32.sub (local.get $a-size-stack) (i32.const 2))) (i32.const 1))
+
+		(local.set $i (i32.const -8))
+		(local.set $len (i32.shl (local.get $len) (i32.const 3)))
+		(block $end
+			(loop $loop
+				(local.set $i (i32.add (local.get $i) (i32.const 8)))
+				(br_if $end (i32.ge_u (local.get $i) (local.get $len)))
+
+				(if
+					(i32.eqz (i32.load16_s (local.get $a-size-stack)))
+					(then
+						(local.set $i (i32.sub (local.get $i) (i32.const 8)))
+						(local.set $a-size-stack (i32.add (local.get $a-size-stack) (i32.const 2)))
+						(br $loop)
+					)
+				)
+
+				;; "loop"
+				;;(call $debug (i32.const 0) (local.get $i) (local.get $len) (local.get $hp))
+
+				(i32.store16 (local.get $a-size-stack) (i32.sub (i32.load16_s (local.get $a-size-stack)) (i32.const 1)))
+
+				(local.set $desc (i32.load (i32.add (local.get $s) (local.get $i))))
+				(i64.store (i32.add (local.get $s) (local.get $i)) (i64.extend_i32_u (local.get $hp)))
+
+				(if ;; redirection or predefined constructor
+					(i32.lt_s (local.get $desc) (i32.const 0))
+					(then
+						(block $no-predefined-constructor
+							(block $predefined-constructor
+								;; predefined constructors: see ABC.Interpreter for the $desc values;
+								;; the constructors written to the heap are from the interpreter generator.
+								(if ;; BOOL
+									(i32.eq (local.get $desc) (i32.const -22))
+									(then
+										(i64.store (local.get $hp) (i64.const 90))
+										(i64.store offset=8 (local.get $hp) (i64.load offset=8 (i32.add (local.get $s) (local.get $i))))
+										(br $predefined-constructor)
+									)
+								)
+								(if ;; CHAR
+									(i32.eq (local.get $desc) (i32.const -30))
+									(then
+										(i64.store (local.get $hp) (i64.const 130))
+										(i64.store offset=8 (local.get $hp) (i64.load offset=8 (i32.add (local.get $s) (local.get $i))))
+										(br $predefined-constructor)
+									)
+								)
+								(if ;; REAL
+									(i32.eq (local.get $desc) (i32.const -38))
+									(then
+										(i64.store (local.get $hp) (i64.const 170))
+										(i64.store offset=8 (local.get $hp) (i64.load offset=8 (i32.add (local.get $s) (local.get $i))))
+										(br $predefined-constructor)
+									)
+								)
+								(if ;; INT
+									(i32.eq (local.get $desc) (i32.const -46))
+									(then
+										(i64.store (local.get $hp) (i64.const 210))
+										(i64.store offset=8 (local.get $hp) (i64.load offset=8 (i32.add (local.get $s) (local.get $i))))
+										(br $predefined-constructor)
+									)
+								)
+
+								(br $no-predefined-constructor)
+							)
+
+							(i64.store (i32.load (local.get $ptr-stack)) (i64.extend_i32_u (local.get $hp)))
+							(local.set $ptr-stack (i32.sub (local.get $ptr-stack) (i32.const 4)))
+							(local.set $hp (i32.add (local.get $hp) (i32.const 16)))
+							(local.set $i (i32.add (local.get $i) (i32.const 8)))
+							(br $loop)
+						)
+
+						(if ;; _STRING_
+							(i32.eq (local.get $desc) (i32.const -14))
+							(then
+								(i64.store (i32.load (local.get $ptr-stack)) (i64.extend_i32_u (local.get $hp)))
+								(local.set $ptr-stack (i32.sub (local.get $ptr-stack) (i32.const 4)))
+
+								(i64.store (local.get $hp) (i64.const 50))
+								(local.set $a (i32.load offset=8 (i32.add (local.get $s) (local.get $i))))
+								(i64.store offset=8 (local.get $hp) (i64.extend_i32_u (local.get $a)))
+								(local.set $a (i32.shr_u (i32.add (local.get $a) (i32.const 7)) (i32.const 3)))
+								(call $copy
+									(i32.add (local.get $hp) (i32.const 16))
+									(i32.add (local.get $s) (i32.add (local.get $i) (i32.const 16)))
+									(local.get $a))
+
+								(local.set $hp (i32.add (local.get $hp) (i32.add (i32.const 8) (i32.shl (local.get $a) (i32.const 3)))))
+								(local.set $i (i32.add (local.get $i) (i32.add (i32.const 16) (i32.shl (local.get $a) (i32.const 3)))))
+								(br $loop)
+							)
+						)
+
+						(if ;; _ARRAY_
+							(i32.eq (local.get $desc) (i32.const -6))
+							(then
+								(i64.store (i32.load (local.get $ptr-stack)) (i64.extend_i32_u (local.get $hp)))
+								(local.set $ptr-stack (i32.sub (local.get $ptr-stack) (i32.const 4)))
+
+								(local.set $a (i32.load offset=8 (i32.add (local.get $s) (local.get $i))))
+								(local.set $desc (i32.load offset=16 (i32.add (local.get $s) (local.get $i))))
+
+								(i64.store (local.get $hp) (i64.const 10))
+								(i64.store offset=8 (local.get $hp) (i64.extend_i32_u (local.get $a)))
+
+								(if ;; INT elements
+									(i32.eq (local.get $desc) (i32.const -46))
+									(then
+										(i64.store offset=16 (local.get $hp) (i64.const 210))
+										(call $copy
+											(i32.add (local.get $hp) (i32.const 24))
+											(i32.add (local.get $s) (i32.add (local.get $i) (i32.const 24)))
+											(local.get $a))
+										(local.set $a (i32.shl (local.get $a) (i32.const 3)))
+										(local.set $hp (i32.add (local.get $hp) (i32.add (i32.const 24) (local.get $a))))
+										(local.set $i (i32.add (local.get $i) (i32.add (i32.const 16) (local.get $a))))
+										(br $loop)
+									)
+								)
+								(if ;; REAL elements
+									(i32.eq (local.get $desc) (i32.const -38))
+									(then
+										(i64.store offset=16 (local.get $hp) (i64.const 170))
+										(call $copy
+											(i32.add (local.get $hp) (i32.const 24))
+											(i32.add (local.get $s) (i32.add (local.get $i) (i32.const 24)))
+											(local.get $a))
+										(local.set $a (i32.shl (local.get $a) (i32.const 3)))
+										(local.set $hp (i32.add (local.get $hp) (i32.add (i32.const 24) (local.get $a))))
+										(local.set $i (i32.add (local.get $i) (i32.add (i32.const 16) (local.get $a))))
+										(br $loop)
+									)
+								)
+								(if ;; BOOL elements
+									(i32.eq (local.get $desc) (i32.const -22))
+									(then
+										(i64.store offset=16 (local.get $hp) (i64.const 90))
+										(local.set $a (i32.shr_u (i32.add (local.get $a) (i32.const 7)) (i32.const 3)))
+										(call $copy
+											(i32.add (local.get $hp) (i32.const 24))
+											(i32.add (local.get $s) (i32.add (local.get $i) (i32.const 24)))
+											(local.get $a))
+										(local.set $a (i32.shl (local.get $a) (i32.const 3)))
+										(local.set $hp (i32.add (local.get $hp) (i32.add (i32.const 24) (local.get $a))))
+										(local.set $i (i32.add (local.get $i) (i32.add (i32.const 16) (local.get $a))))
+										(br $loop)
+									)
+								)
+
+								(if
+									(i32.eqz (local.get $desc))
+									(then
+										(local.set $arity (i32.const 1))
+										(local.set $a-arity (i32.const 1))
+									)
+									(else
+										(local.set $desc (i32.add (local.get $desc) (local.get $code-offset)))
+										(local.set $arity (i32.sub (i32.load16_u (i32.sub (local.get $desc) (i32.const 2))) (i32.const 256)))
+										(local.set $a-arity (i32.load16_u (local.get $desc)))
+									)
+								)
+								(local.set $b-arity (i32.sub (local.get $arity) (local.get $a-arity)))
+
+								(i64.store offset=16 (local.get $hp) (i64.extend_i32_u (local.get $desc)))
+								(local.set $hp (i32.add (local.get $hp) (i32.const 24)))
+								(local.set $i (i32.add (local.get $i) (i32.const 16)))
+
+								(local.set $ptr-stack (i32.add (local.get $ptr-stack)
+									(i32.shl (i32.mul (local.get $a) (local.get $a-arity)) (i32.const 2))))
+								(i32.store16 (local.tee $a-size-stack (i32.sub (local.get $a-size-stack) (i32.const 2)))
+									(i32.mul (local.get $a) (local.get $a-arity)))
+
+								(local.set $arity (i32.shl (local.get $arity) (i32.const 3)))
+								(local.set $j (i32.const 0))
+								(block $end-copy-array-elements
+									(loop $copy-array-elements
+										(br_if $end-copy-array-elements (i32.eq (local.get $j) (local.get $a)))
+
+										(local.set $k (i32.const 0))
+										(block $end-push-pointers
+											(loop $push-pointers
+												(br_if $end-push-pointers (i32.eq (local.get $k) (local.get $a-arity)))
+												(i32.store
+													(i32.sub (local.get $ptr-stack)
+														(i32.shl (i32.add (i32.mul (local.get $j) (local.get $a-arity)) (local.get $k)) (i32.const 2)))
+													(i32.add (local.get $hp) (i32.shl (local.get $k) (i32.const 3))))
+												(local.set $k (i32.add (local.get $k) (i32.const 1)))
+												(br $push-pointers)
+											)
+										)
+
+										(call $copy
+											(i32.add (local.get $hp) (i32.shl (local.get $a-arity) (i32.const 3)))
+											(i32.add (local.get $s) (i32.add (local.get $i) (i32.const 8)))
+											(local.get $b-arity))
+										(local.set $i (i32.add (local.get $i) (i32.shl (local.get $b-arity) (i32.const 3))))
+
+										(local.set $hp (i32.add (local.get $hp) (local.get $arity)))
+										(local.set $j (i32.add (local.get $j) (i32.const 1)))
+										(br $copy-array-elements)
+									)
+								)
+
+								(br $loop)
+							)
+						)
+
+						;; not a predefined constructor; redirection
+						(i64.store
+							(i32.load (local.get $ptr-stack))
+							(i64.load (i32.add (local.get $s) (i32.add (local.get $i) (i32.sub (local.get $desc) (i32.const 1))))))
+						(local.set $ptr-stack (i32.sub (local.get $ptr-stack) (i32.const 4)))
+						(br $loop)
+					)
+				)
+
+				(local.set $desc (i32.add (local.get $desc) (local.get $code-offset)))
+
+				;; "desc"
+				;;(call $debug (i32.const 1) (local.get $desc) (i32.const 0) (i32.const 0))
+
+				(if
+					(i32.and (local.get $desc) (i32.const 2))
+					(then
+						;; hnf
+						(local.set $arity (i32.load16_s (i32.sub (local.get $desc) (i32.const 2))))
+						(local.set $a-arity (local.get $arity))
+
+						;; "arity"
+						;;(call $debug (i32.const 2) (local.get $arity) (i32.const 0) (i32.const 0))
+
+						(if
+							(i32.gt_u (local.get $arity) (i32.const 256))
+							(then
+								(local.set $a-arity (i32.load16_s (local.get $desc)))
+								(local.set $arity (i32.sub (local.get $arity) (i32.const 256)))
+							)
+						)
+
+						(if
+							(i32.eq (local.get $arity) (i32.const 0))
+							(then
+								(local.set $desc (i32.sub (local.get $desc) (i32.const 10)))
+								(i64.store (i32.load (local.get $ptr-stack)) (i64.extend_i32_u (local.get $desc)))
+								(local.set $ptr-stack (i32.sub (local.get $ptr-stack) (i32.const 4)))
+								(i64.store (i32.add (local.get $s) (local.get $i)) (i64.extend_i32_u (local.get $desc)))
+								(i32.store16 (local.tee $a-size-stack (i32.sub (local.get $a-size-stack) (i32.const 2))) (i32.const 0))
+								(br $loop)
+							)
+						)
+
+						(i64.store (i32.load (local.get $ptr-stack)) (i64.extend_i32_u (local.get $hp)))
+						(local.set $ptr-stack (i32.sub (local.get $ptr-stack) (i32.const 4)))
+
+						(i64.store (local.get $hp) (i64.extend_i32_u (local.get $desc)))
+
+						(if
+							(i32.eq (local.get $arity) (i32.const 1))
+							(then
+								(if
+									(i32.eq (local.get $a-arity) (i32.const 1))
+									(then
+										(i32.store
+											(local.tee $ptr-stack (i32.add (local.get $ptr-stack) (i32.const 4)))
+											(i32.add (local.get $hp) (i32.const 8)))
+									)
+									(else
+										(i64.store offset=8 (local.get $hp)
+											(i64.load (i32.add (local.get $s)
+												(local.tee $i (i32.add (local.get $i) (i32.const 8))))))
+									)
+								)
+								(local.set $hp (i32.add (local.get $hp) (i32.const 16)))
+								(i32.store16 (local.tee $a-size-stack (i32.sub (local.get $a-size-stack) (i32.const 2))) (i32.const 1))
+								(br $loop)
+							)
+						)
+						(if
+							(i32.eq (local.get $arity) (i32.const 2))
+							(then
+								;;(call $debug (i32.const 5) (local.get $a-arity) (i32.const 0) (i32.const 0))
+								(if
+									(i32.eq (local.get $a-arity) (i32.const 2))
+									(then
+										(i32.store offset=8 (local.get $ptr-stack) (i32.add (local.get $hp) (i32.const 8)))
+										(i32.store offset=4 (local.get $ptr-stack) (i32.add (local.get $hp) (i32.const 16)))
+										(local.set $ptr-stack (i32.add (local.get $ptr-stack) (i32.const 8)))
+									)
+									(else
+										(if
+											(i32.eq (local.get $a-arity) (i32.const 1))
+											(then
+												(i32.store offset=4 (local.get $ptr-stack) (i32.add (local.get $hp) (i32.const 8)))
+												(local.set $ptr-stack (i32.add (local.get $ptr-stack) (i32.const 4)))
+												(i64.store offset=16 (local.get $hp)
+													(i64.load (i32.add (local.get $s)
+														(local.tee $i (i32.add (local.get $i) (i32.const 8))))))
+											)
+											(else ;; b-arity=2
+												(i64.store offset=8 (local.get $hp)
+													(i64.load (i32.add (local.get $s) (i32.add (local.get $i) (i32.const 8)))))
+												(i64.store offset=16 (local.get $hp)
+													(i64.load (i32.add (local.get $s) (i32.add (local.get $i) (i32.const 16)))))
+												(local.set $i (i32.add (local.get $i) (i32.const 16)))
+											)
+										)
+									)
+								)
+								(local.set $hp (i32.add (local.get $hp) (i32.const 24)))
+								(i32.store16 (local.tee $a-size-stack (i32.sub (local.get $a-size-stack) (i32.const 2))) (i32.const 2))
+								(br $loop)
+							)
+						)
+
+						;; large hnf
+						;;(call $debug (i32.const 3) (i32.const 0) (i32.const 0) (i32.const 0))
+						(i64.store offset=16 (local.get $hp) (i64.extend_i32_u (i32.add (local.get $hp) (i32.const 24))))
+
+						(if
+							(i32.eq (local.get $a-arity) (i32.const 0))
+							(then
+								(i64.store offset=8 (local.get $hp)
+									(i64.load (i32.add (local.get $s)
+										(local.tee $i (i32.add (local.get $i) (i32.const 8))))))
+								(local.set $arity (i32.sub (local.get $arity) (i32.const 1)))
+								(call $copy
+									(i32.add (local.get $hp) (i32.const 24))
+									(i32.add (local.get $s) (local.get $i))
+									(local.get $arity))
+								(local.set $i (i32.add (local.get $i) (i32.shl (local.get $arity) (i32.const 3))))
+							)