Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
abc-interpreter
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
8
Issues
8
List
Boards
Labels
Service Desk
Milestones
Merge Requests
3
Merge Requests
3
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
clean-and-itasks
abc-interpreter
Commits
05a6350b
Commit
05a6350b
authored
Apr 03, 2019
by
Camil Staps
🚀
Browse files
Options
Browse Files
Download
Plain Diff
Merge branch 'unrelocated-serialization' into 'master'
Add deserialization support for the WebAssembly interpreter See merge request
!103
parents
404cc93b
c0f4ecb2
Pipeline
#20593
passed with stages
in 17 minutes and 51 seconds
Changes
9
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
9 changed files
with
705 additions
and
31 deletions
+705
-31
lib/ABC/Interpreter.dcl
lib/ABC/Interpreter.dcl
+11
-0
lib/ABC/Interpreter.icl
lib/ABC/Interpreter.icl
+143
-4
src-js/interpret.js
src-js/interpret.js
+37
-0
src-js/util.wat
src-js/util.wat
+481
-0
src/bytecode.c
src/bytecode.c
+4
-2
src/bytecode.h
src/bytecode.h
+4
-0
src/copy_interpreter_to_host.c
src/copy_interpreter_to_host.c
+10
-12
src/parse.c
src/parse.c
+7
-5
tools/interpretergen-wasm/target.icl
tools/interpretergen-wasm/target.icl
+8
-8
No files found.
lib/ABC/Interpreter.dcl
View file @
05a6350b
...
...
@@ -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
View file @
05a6350b
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
,
desc
s
,
mod
s
)
=
copy_to_string_with_names
graph
#
(
graph
,
desc
info
,
module
s
)
=
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
mod
s
\\
di
<-:
descs
}
#!
(
len
,
bytecodep
)
=
strip_bytecode
bytecode
{#
symbol_name
di
mod
ules
\\
di
<-:
descinfo
}
#!
bytecode
=
derefCharArray
bytecodep
len
|
free_to_false
bytecodep
=
(
Nothing
,
w
)
#
rec
=
{
graph
=
graph
,
descinfo
=
desc
s
,
modules
=
mods
,
descinfo
=
desc
info
,
modules
=
mod
ule
s
,
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
View file @
05a6350b
...
...
@@ -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
View file @
05a6350b
(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))))
)