{
    Let emit. emit
}

Where

Let emit program.
    Let root_path. (program_root_path program)
    In
    Let output_path. (STRING.append root_path ".c")
    In
    Let file. (OS.file_create output_path)
    In
    Let emit texts.
        (LIST.for_each texts
            Func text. (OS.file_write file text))
    In
    Let emit_instr.
        (make_emit_instr emit program.nil_label program.cons_label)
    In
    Do (emit ["#include <stdint.h>\n"])
    Do (emit ["#include <stdio.h>\n"])
    Do (emit ["#include <stdlib.h>\n"])
    Do (emit ["#include <string.h>\n"])
    Do (emit ["\n"])
    Do (emit ["#include \"runtime.h\"\n"])
    Do (emit ["\n"])
    Do (emit ["// Labels:\n"])
    Do (LIST.for_each program.label_names
        Func pair.
            Let {i name}. pair
            In
            (emit ["// " (Z.show i) " " name "\n"]))
    Do (emit ["\n"])
    Do (emit ["uint16_t module_indices[] = {\n"])
    Do (LIST.for_each program.module_indexes
        Func index.
            Do (emit ["    "])
            Do (LIST.for_each index
                Func label.
                    (emit [(Z.show label) ", "]))
            Do (emit ["UINT16_MAX,\n"])
            In
            {})
    Do (emit ["};\n"])
    Do (emit ["\n"])
    Do (emit ["void *\n"])
    Do (emit ["run_machine(int argc, const char *argv[])\n"])
    Do (emit ["{\n"])
    Do (emit ["    struct value *stack;\n"])
    Do (emit ["    struct heap heap;\n"])
    Do (emit ["    struct value *closure_env;\n"])
    Do (emit ["    struct value *constant_env;\n"])
    Do (emit ["    struct value *package_env;\n"])
    Do (emit ["    struct value c;\n"])
    Do (emit ["    struct value a;\n"])
    Do (emit ["    uint32_t fp;\n"])
    Do (emit ["    uint32_t sp;\n"])
    Do (emit ["\n"])
    Do (emit ["entry_0:\n"])
    Do (emit ["    heap.size = 256*1024*1024;\n"])
    Do (emit ["    heap.values = malloc(sizeof(struct value) * heap.size);\n"])
    Do (emit ["    heap.top = 0;\n"])
    Do (emit ["    stack = malloc(sizeof(struct value) * 4096);\n"])
    Do (emit ["    fp = 0;\n"])
    Do (emit ["    sp = 0;\n"])
    Do (emit
        [
            "    constant_env = malloc("
            (Z.show (LIST.length program.constants))
            " * sizeof(struct value));\n"
        ])
    Do (emit
        [
            "    package_env = malloc("
            (Z.show (LIST.length program.packages))
            " * sizeof(struct value));\n"
        ])
    Do (LIST.for_each_numbered program.constants
        Func i const.
            Do Match const
                | `str.s
                    (emit
                        [
                            "    constant_env[" (Z.show i)
                            "] = alloc_string(&heap, " s ");\n"
                        ])
                | `prim.name
                    (emit
                        [
                            "    constant_env[" (Z.show i)
                            "] = alloc_prim(&heap, "
                            (Z.show (RUNTIME.prim_arity name))
                            ", prim_" name ");\n"
                        ])
                ;
            In
            {})
    Do (emit ["    push_frame(return_from_main);\n"])
    Do (LIST.for_each program.init_code emit_instr)
    Do (emit ["    a = labeled_empty_tuple(" (Z.show program.nil_label) ");\n"])
    Do (emit ["    for (int i = argc-1; i >= 0; i--) {\n"])
    Do (emit ["        struct value values[2] = {alloc_string(&heap, argv[i]), a};\n"])
    Do (emit ["        a = alloc_tuple(&heap, values, 2);\n"])
    Do (emit ["        a = alloc_labeled_value(&heap, "
                        (Z.show program.cons_label) ", a);\n"])
    Do (emit ["    }\n"])
    Do (emit ["    push_var(a);\n"])
    Do (emit
        [
            "    a = package_env["
            (Z.show $ LIST.length program.packages + -1)
            "];\n"
        ])
    Do (emit ["    fp = sp - 4;\n"])
    Do (emit ["    goto enter;\n"])
    Do (emit ["return_from_main:\n"])
    Do (emit ["    free(heap.values);\n"])
    Do (emit ["    free(stack);\n"])
    Do (emit ["    free(constant_env);\n"])
    Do (emit ["    free(package_env);\n"])
    Do (emit ["    return NULL;\n"])
    Do (LIST.for_each program.function_code emit_instr)
    Do (emit
        [
            "prim_cons:\n"
            "    a = var(0);\n"
            "    push_var(a);\n"
            "    a = var(1);\n"
            "    push_var(a);\n"
            "    a = alloc_tuple(&heap, &stack[sp-2], 2);\n"
            "    pop_vars(2);\n"
            "    a = alloc_labeled_value(&heap, "
                (Z.show program.cons_label) ", a);\n"
            "    goto pop_frame;\n"
        ])
    Do (LIST.for_each (collect_prims program)
        Func name.
            When Not (STRING.equal name "cons")
                Do (emit ["prim_" name ":\n"])
                Do (emit ["    a = prim_" name "(&heap"])
                Do Begin (emitting_args 0)
                    Define emitting_args i.
                        When (i < (RUNTIME.prim_arity name))
                            Do (emit [", var(" (Z.show i) ")"])
                            In
                            Goto (emitting_args (i + 1))
                Do (emit [");\n"])
                Do (emit ["    goto pop_frame;\n"])
                In
                {})
    Do (emit ["enter:\n"])
    Do (emit ["    {\n"])
    Do (emit ["        c = a;\n"])
    Do (emit ["        if (!has_tag(c, TAG_CLOSURE)) halt();\n"])
    Do (emit ["        struct closure *closure = (struct closure *)address(&heap, c);\n"])
    Do (emit ["        if (closure->num_params != sp - (fp + 3)) halt();\n"])
    Do (emit ["        closure_env = closure->free_values;\n"])
    Do (emit ["        goto *(&&entry_0 + closure->code_offset);\n"])
    Do (emit ["    }\n"])
    Do (emit ["pop_frame:\n"])
    Do (emit ["    {\n"])
    Do (emit ["        struct value *frame = &stack[fp];\n"])
    Do (emit ["        sp = fp;\n"])
    Do (emit ["        c = frame[0];\n"])
    Do (emit ["        fp = frame[1].bits;\n"])
    Do (emit ["        struct closure *closure = (struct closure *)address(&heap, c);\n"])
    Do (emit ["        closure_env = closure->free_values;\n"])
    Do (emit ["        goto *(&&entry_0 + (int32_t)frame[2].bits);\n"])
    Do (emit ["    }\n"])
    Do (emit ["}\n"])
    In
    Do (OS.file_close file)
    In
    {}

Where

Let make_emit_instr emit nil_label cons_label.
    Func instr.
        Match instr
        | `push (emit ["    push_var(a);\n"])
        | `pop_vars.n
            When (n > 0)
                (emit ["    pop_vars(" (Z.show n) ");\n"])
        | `open_tuple.n
            (emit
                [
                    "    open_tuple(&heap, &stack[sp], a, " (Z.show n) ");\n"
                    "    sp += " (Z.show n) ";\n"
                ])
        | `nil
            (emit ["    a = labeled_empty_tuple(" (Z.show nil_label) ");\n"])
        | `cons
            (emit
                [
                    "    a = alloc_labeled_value(&heap, "
                    (Z.show cons_label) ", a);\n"
                ])
        | `const.i
            (emit ["    a = constant_env[" (Z.show i) "];\n"])
        | `package.i
            (emit ["    a = package_env[" (Z.show i) "];\n"])
        | `package_env_store.i
            (emit ["    package_env[" (Z.show i) "] = a;\n"])
        | `swap
            (emit
                [
                    "    a = stack[sp-1];\n"
                    "    stack[sp-1] = stack[sp-2];\n"
                    "    stack[sp-2] = a;\n"
                ])
        | `alloc_tuple.n
            (emit
                If (n = 0)
                    ["    a = empty_tuple;\n"]
                    [
                        "    a = alloc_tuple(&heap, &stack[sp-"
                        (Z.show n) "], " (Z.show n) ");\n"
                        "    pop_vars(" (Z.show n) ");\n"
                    ])
        | `alloc_module.{layout size}
            (emit
                [
                    "    a = alloc_module(&heap, "
                    "&stack[sp-" (Z.show size) "], " (Z.show size) ", "
                    (Z.show layout) ");\n"
                    "    pop_vars(" (Z.show size) ");\n"
                ])
        | `true
            (emit ["    a = true_value;\n"])
        | `false
            (emit ["    a = false_value;\n"])
        | `not
            (emit ["    a = (a.bits == true_value.bits) ? false_value : true_value;\n"])
        | `block.i
            (emit ["block_" (Z.show i) ":\n"])
        | `jump.i
            (emit ["    goto block_" (Z.show i) ";\n"])
        | `jump_if_false.i
            (emit ["    if (a.bits == false_value.bits) goto block_" (Z.show i) ";\n"])
        | `jump_if_true.i
            (emit ["    if (a.bits == true_value.bits) goto block_" (Z.show i) ";\n"])
        | `labeled_empty_tuple.label
            (emit ["    a = labeled_empty_tuple(" (Z.show label) ");\n"])
        | `label.label
            (emit ["    a = alloc_labeled_value(&heap, " (Z.show label) ", a);\n"])
        | `halt
            (emit ["    halt();\n"])
        | `switch.{clauses default}
            Let emit_case clause.
                Let {n i}. clause
                In
                (emit
                    [
                        "    case " (Z.show n) ":\n"
                        "        goto block_" (Z.show i) ";\n"
                    ])
            In
            Do (emit ["    switch (value_unbox_int32(a)) {\n"])
            Do (LIST.for_each clauses emit_case)
            Do (emit ["    default:\n"])
            Do Match default
                | `nothing (emit ["        halt();\n"])
                | `just.transfer
                    Match transfer
                    | `push_and_jump.i
                        (emit
                            [
                                "        push_var(a);\n"
                                "        goto block_" (Z.show i) ";\n"
                            ])
                    | `jump.i
                        (emit ["        goto block_" (Z.show i) ";\n"])
                    ;
                ;
            Do (emit ["    }\n"])
            In
            {}
        | `match.{clauses default}
            Let emit_case clause.
                Let {pat i}. clause
                In
                Match pat
                | `default.label
                    (emit
                        [
                            "    case " (Z.show label) ":\n"
                            "        goto block_" (Z.show i) ";\n"
                        ])
                | `var.label
                    (emit
                        [
                            "    case " (Z.show label) ":\n"
                            "        a = remove_label(&heap, a);\n"
                            "        push_var(a);\n"
                            "        goto block_" (Z.show i) ";\n"
                        ])
                | `tuple.{label num_vars}
                    If (num_vars = 0)
                        (emit
                            [
                                "    case " (Z.show label) ":\n"
                                "        goto block_" (Z.show i) ";\n"
                            ])
                        (emit
                            [
                                "    case " (Z.show label) ":\n"
                                "        a = remove_label(&heap, a);\n"
                                "        open_tuple(&heap, &stack[sp], a, "
                                (Z.show num_vars) ");\n"
                                "        sp += " (Z.show num_vars) ";\n"
                                "        goto block_" (Z.show i) ";\n"
                            ])
                ;
            In
            Do (emit ["    switch (value_label(&heap, a)) {\n"])
            Do (LIST.for_each clauses emit_case)
            Do (emit ["    default:\n"])
            Do Match default
                | `nothing (emit ["        halt();\n"])
                | `just.i (emit ["        goto block_" (Z.show i) ";\n"])
                ;
            Do (emit ["    }\n"])
            In
            {}
        | `push_frame.i
            (emit ["    push_frame(block_" (Z.show i) ");\n"])
        | `pop_frame
            (emit ["    goto pop_frame;\n"])
        | `entry.i
            (emit ["entry_" (Z.show i) ":\n"])
        | `call.num_args
            (emit
                [
                    "    fp = sp - " (Z.show (3 + num_args)) ";\n"
                    "    goto enter;\n"
                ])
        | `tailcall.num_args
            Let n. (Z.show num_args)
            Let m. (Z.show (num_args + 3))
            In
            (emit
                [
                    "    memmove(stack+fp+3, stack+sp-" n ", "
                    n "*sizeof(struct value));\n"
                    "    sp = fp + " m ";\n"
                    "    goto enter;\n"
                ])
        | `stack.i
            (emit ["    a = var(" (Z.show i) ");\n"])
        | `free.i
            (emit ["    a = closure_env[" (Z.show i) "];\n"])
        | `self
            (emit ["    a = c;\n"])
        | `num.n
            (emit ["    a = number(" (Z.show n) ");\n"])
        | `alloc_closure.{i free num_params}
            Do (emit
                [
                    "    a = alloc_closure(&heap, " (Z.show num_params) ", "
                    (Z.show (LIST.length free)) ", "
                    "&&entry_" (Z.show i) " - &&entry_0);\n"
                ])
            In
            (LIST.for_each_numbered free
                Func j place.
                    Do (emit ["    closure_store(&heap, a, " (Z.show j) ", "])
                    Do Match place
                        | `stack.i (emit ["var(" (Z.show i) ")"])
                        | `free.i (emit ["closure_env[" (Z.show i) "]"])
                        | `self (emit ["c"])
                        | _ (die "Place not implemented.")
                        ;
                    Do (emit [");\n"])
                    In
                    {})
        | `module_fetch.i
            (emit ["    a = module_fetch(&heap, a, " (Z.show i) ");\n"])
        | `tuple_fetch.i
            (emit ["    a = tuple_fetch(&heap, a, " (Z.show i) ");\n"])
        | _ (die "Unknown instruction.")
        ;

Where

Let collect_prims program.
    (LIST.reduce program.constants []
        Func prims const. Match const | `prim.name (name::prims) | _ prims ;)

Let program_root_path program.
    Match (LIST.last program.packages)
    | `nothing (die "No packages.")
    | `just.package package.path
    ;

Where

Let die. Prim die

Where

Let LIST. Package "list"
Let OS. Package "os"
Let RUNTIME. Package "runtime"
Let SEARCH. Package "search"
Let STDIO. Package "stdio"
Let STRING. Package "string"
Let Z. Package "z"