Performance CLOS make实例非常慢，会导致SBCL中的堆耗尽

我正在用Common Lisp（64位Debian GNU/Linux中的SBCL 1.1.5）编写一个多体系结构的汇编程序/反汇编程序，目前该汇编程序为x86-64的一个子集生成正确的代码。对于汇编x86-64汇编代码，我使用了一个哈希表，其中汇编指令助记符（字符串）如

“jc-rel8”

和

“stosb”

是返回一个或多个编码函数列表的键，如下所示：

(defparameter *emit-function-hash-table-x64* (make-hash-table :test 'equalp)) (setf (gethash "jc-rel8" *emit-function-hash-table-x64*) (list #'jc-rel8-x86)) (setf (gethash "stosb" *emit-function-hash-table-x64*) (list #'stosb-x86)) 我已经使用一个简单的Perl脚本将NASM的

insns.dat

转换为通用的Lisp语法（如上图所示）（下面进一步介绍，但对脚本本身不感兴趣），原则上它可以工作。所以它是可行的，但编译这些7193对象的速度非常慢，通常会导致堆耗尽。在拥有16G内存的Linux Core i7-2760QM笔记本电脑上，编译带有7193个对象（如上述对象）的

（eval when（：compile top level:load top level:execute）

代码块需要7分钟以上的时间，有时会导致堆耗尽，如下所示：

;; Swank started at port: 4005. * Heap exhausted during garbage collection: 0 bytes available, 32 requested. Gen StaPg UbSta LaSta LUbSt Boxed Unboxed LB LUB !move Alloc Waste Trig WP GCs Mem-age 0: 0 0 0 0 0 0 0 0 0 0 0 41943040 0 0 0.0000 1: 0 0 0 0 0 0 0 0 0 0 0 41943040 0 0 0.0000 2: 0 0 0 0 0 0 0 0 0 0 0 41943040 0 0 0.0000 3: 38805 38652 0 0 49474 15433 389 416 0 2144219760 9031056 1442579856 0 1 1.5255 4: 127998 127996 0 0 45870 14828 106 143 199 1971682720 25428576 2000000 0 0 0.0000 5: 0 0 0 0 0 0 0 0 0 0 0 2000000 0 0 0.0000 6: 0 0 0 0 1178 163 0 0 0 43941888 0 2000000 985 0 0.0000 Total bytes allocated = 4159844368 Dynamic-space-size bytes = 4194304000 GC control variables: *GC-INHIBIT* = true *GC-PENDING* = in progress *STOP-FOR-GC-PENDING* = false fatal error encountered in SBCL pid 9994(tid 46912556431104): Heap exhausted, game over. Welcome to LDB, a low-level debugger for the Lisp runtime environment. ldb> 使用OOP（CLOS）可以合并指令助记符（例如上面的

jc

或

stosb

，

：name

），指令的允许操作数（

：操作数

），指令的二进制编码（例如

stosb

，

：代码字符串

）一个对象中的指令可能存在架构限制（

：arch flags

），但似乎至少我3年的计算机效率不足以快速编译大约7000个CLOS对象实例

我的问题是：有没有办法让SBCL的

使实例更快，或者我应该让汇编代码生成保持在常规函数中，比如上面的例子？我也很乐意知道任何其他可能的解决方案。

以下是Perl脚本，以防万一：

#!/usr/bin/env perl
use strict;
use warnings;

# this program converts NASM's `insns.dat` to Common Lisp Object System (CLOS) syntax.

my $firstchar;
my $line_length;
my $are_there_square_brackets;
my $mnemonic_and_operands;
my $mnemonic;
my $operands;
my $code_string;
my $flags;
my $mnemonic_of_current_mnemonic_array;

my $clos_object_name;
my $clos_mnemonic;
my $clos_operands;
my $clos_code_string;
my $clos_flags;

my @object_name_array = ();
my @mnemonic_array = ();
my @operands_array = ();
my @code_string_array = ();
my @flags_array = ();

my @each_mnemonic_only_once_array = ();

my @instruction_variants_array = ();
my @instruction_variants_for_current_instruction_array = ();

open(FILE, 'insns.dat');

$mnemonic_of_current_mnemonic_array = "";

# read one line at once.
while (<FILE>)
{
    $firstchar = substr($_, 0, 1);
    $line_length = length($_);
    $are_there_square_brackets = ($_ =~ /\[.*\]/);
    chomp;
    if (($line_length > 1) && ($firstchar =~ /[^\t ;]/))
    {
        if ($are_there_square_brackets)
        {
            ($mnemonic_and_operands, $code_string, $flags) = split /[\[\]]+/, $_;
            $code_string = "[" . $code_string . "]";
            ($mnemonic, $operands) = split /[\t ]+/, $mnemonic_and_operands;
        }
        else
        {
            ($mnemonic, $operands, $code_string, $flags) = split /[\t ]+/, $_;
        }
        $mnemonic =~ s/[\t ]+/ /g;
        $operands =~ s/[\t ]+/ /g;
        $code_string =~ s/[\t ]+/ /g;
        $flags =~ s/[\t ]+//g;

        # we don't want non-x86-64 instructions here.
        unless ($flags =~ "NOLONG")
        {
            # ok, the content of each field is now filtered,
            # let's convert them to a suitable Common Lisp format.
            $clos_object_name = $mnemonic . "-" . $operands;

            # in Common Lisp object names `|`, `,`, and `:` must be escaped with a backslash `\`,
            # but that would get too complicated.
            # so we'll simply replace them:
            # `|` -> `-`.
            # `,` -> `.`.
            # `:` -> `.`.
            $clos_object_name =~ s/\|/-/g;              
            $clos_object_name =~ s/,/./g;              
            $clos_object_name =~ s/:/./g;              

            $clos_mnemonic    = "\"" . $mnemonic . "\"";
            $clos_operands    = "\"" . $operands . "\"";
            $clos_code_string = "\"" . $code_string . "\"";

            $clos_flags = "\"" . $flags . "\"";        # add first and last double quotes.
            $clos_flags =~ s/,/" "/g;                  # make each flag its own Common Lisp string.
            $clos_flags = "(list " . $clos_flags. ")"; # convert to `list` syntax.

            push @object_name_array, $clos_object_name;
            push @mnemonic_array, $clos_mnemonic;
            push @operands_array, $clos_operands;
            push @code_string_array, $clos_code_string;
            push @flags_array, $clos_flags;

            if ($mnemonic eq $mnemonic_of_current_mnemonic_array)
            {
                # ok, same mnemonic as the previous one,
                # so the current object name goes to the list.
                push @instruction_variants_for_current_instruction_array, $clos_object_name;
            }
            else
            {
                # ok, this is a new mnemonic.
                # so we'll mark this as current mnemonic.
                $mnemonic_of_current_mnemonic_array = $mnemonic;
                push @each_mnemonic_only_once_array, $mnemonic;

                # we first push the old array (unless it's empty), then clear it,
                # and then push the current object name to the cleared array.

                if (@instruction_variants_for_current_instruction_array)
                {
                    # push the variants array, unless it's empty.
                    push @instruction_variants_array, [ @instruction_variants_for_current_instruction_array ];
                }
                @instruction_variants_for_current_instruction_array = ();
                push @instruction_variants_for_current_instruction_array, $clos_object_name;
            }
        }
    }
}

# the last instruction's instruction variants must be pushed too.
if (@instruction_variants_for_current_instruction_array)
{
    # push the variants array, unless it's empty.
    push @instruction_variants_array, [ @instruction_variants_for_current_instruction_array ];
}

close(FILE);

# these objects need be created already during compilation.
printf("(eval-when (:compile-toplevel :load-toplevel :execute)\n");

# print the code to create each instruction + operands combination object.

for (my $i=0; $i <= $#mnemonic_array; $i++)
{
    $clos_object_name = $object_name_array[$i];
    $mnemonic         = $mnemonic_array[$i];
    $operands         = $operands_array[$i];
    $code_string      = $code_string_array[$i];
    $flags            = $flags_array[$i];

    # print the code to create a variant object.
    # each object here is a variant of a single instruction (or a single mnemonic).
    # actually printed as 6 lines to make it easier to read (for us humans, I mean), with an empty line in the end.
    printf("(setf %s (make-instance 'x86-asm-instruction\n:name %s\n:operands %s\n:code-string %s\n:arch-flags %s\n:is-variant t))",
        $clos_object_name,
        $mnemonic,
        $operands,
        $code_string,
        $flags);
    printf("\n\n");
}

# print the code to create each instruction + operands combination object.

# for (my $i=0; $i <= $#each_mnemonic_only_once_array; $i++)
for my $i (0 .. $#instruction_variants_array)
{
    $mnemonic = $each_mnemonic_only_once_array[$i];

    # print the code to create a container object.
    printf("(setf %s (make-instance 'x86-asm-instruction :name \"%s\" :is-container t :variants (list \n", $mnemonic, $mnemonic);
    @instruction_variants_for_current_instruction_array = $instruction_variants_array[$i];

    # for (my $j=0; $j <= $#instruction_variants_for_current_instruction_array; $j++)
    for my $j (0 .. $#{$instruction_variants_array[$i]} )
    {
        printf("%s", $instruction_variants_array[$i][$j]);

        # print 3 closing brackets if this is the last variant.
        if ($j == $#{$instruction_variants_array[$i]})
        {
            printf(")))");
        }
        else
        {
            printf(" ");
        }
    }

    # if this is not the last instruction, print two newlines.
    if ($i < $#instruction_variants_array)
    {
        printf("\n\n");
    }
}

# print the closing bracket to close `eval-when`.
print(")");

exit;

！/usr/bin/env perl
严格使用；
使用警告；
#此程序将NASM的'insns.dat'转换为公共Lisp对象系统（CLOS）语法。
我的$firstchar；
我的$line_长度；
我的美元在方括号内；
我的$助记符和操作数；
我的$记忆法；
我的$操作数；
我的$code\u字符串；
我的$flags；
我的当前助记符数组的$助记符数组；
我的$clos\u对象\u名称；
我的$clos_记忆法；
我的$clos_操作数；
我的$clos\u代码\u字符串；
我的$clos_旗帜；
我的@object_name_数组=（）；
我的@助记符数组=（）；
my@Operators_数组=（）；
我的@code_字符串_数组=（）；
我的@flags_数组=（）；
我的@each_助记符_only_only_数组=（）；
我的@instruction_变体_数组=（）；
我的@instruction\u variants\u用于当前的\u指令\u数组=（）；
打开（文件“insns.dat”）；
$mnemonic_of_current_mnemonic_array=“”；
#一次读一行。
而（）
{
$firstchar=substr（$，0，1）；
$line\u length=长度（$\u）；
$有方括号=（$\=~/\[.\]/）；
咀嚼；
如果（$line_length>1）和（$firstchar=~/[^\t；]/）
{
如果（$有方括号）
{
（$助记符和操作数，$code\u字符串，$flags）=拆分/[\[\]]+/，$；
$code_string=“[”$code_string.]”；
（$mnemonic，$operans）=拆分/[\t]+/，$mnemonic_和_操作数；
}
其他的
{
（$助记符，$Operators，$code_string，$flags）=拆分/[\t]+/，$；
}
$mnemonic=~s/[\t]+//g；
$Operators=~s/[\t]+//g；
$code\u string=~s/[\t]+///g；
$flags=~s/[\t]+//g；
#这里不需要非x86-64指令。
除非（$flags=~“NOLONG”）
{
#好的，现在每个字段的内容都被过滤了，
#让我们将它们转换为合适的通用Lisp格式。
$clos_object_name=$助记符。“-”$操作数；
#在公共Lisp中，对象名“|”、”和“：”必须用反斜杠“\”转义，
#但这会变得太复杂。
#因此，我们将简单地替换它们：
# `|` -> `-`.
# `,` -> `.`.
# `:` -> `.`.
$clos\u object\u name=~s/\\124;/-/g；
$clos_object_name=~s/，//g；
$clos_object_name=~s/：//g；
$clos\U助记符=“\”.$助记符。“\”；
$clos\U操作数=“\”.$Operators.“\”；
$clos\U code\U string=“\”.$code\U string。“\”；
$clos\U flags=“\”.$flags。“\”；#添加第一个和最后一个双引号。
$clos_flags=~s/，/“”/g；#使每个标志都有自己的公共Lisp字符串。
$clos_flags=“（list.“$clos_flags.””）”；#转换为`list`语法。
推送@object\u name\u数组，$clos\u object\u name；
push@助记符数组，$clos\u助记符；
push@operans\u数组，$clos\u操作数；
push@code\u string\u数组，$clos\u code\u string；
推送@flags\u数组，$clos\u flags；
if（$mnemonic eq$mnemonic_of_current_mnemonic_array）
{
#好的，和前一个一样的助记符，
#因此，当前对象的名称将进入列表。
将@instruction\u variants\u推送到当前的\u指令\u数组，$clos\u object\u name；
}
其他的
{
#好的，这是一个新的助记符。
#所以我们将其标记为当前助记符。
$mnemonic_of_current_mnemonic_数组=$mnemonic；
按@each_mnemonic_only_一次_数组，$mnemonic；
#我们首先推送旧数组（除非它是空的），然后清除它，
#然后将当前对象名称推送到清除的数组中。
if（@instruction\u variants\u用于当前的\u指令\u数组）
{
#按下变体数组，除非它为空。
推送@instruction_variants_array，[@instruction_variants_用于当前_instruction_array]；
}
@当前指令的指令变量数组=（）；
聚氨基甲酸酯
;; Swank started at port: 4005.
* Heap exhausted during garbage collection: 0 bytes available, 32 requested.
 Gen StaPg UbSta LaSta LUbSt Boxed Unboxed LB   LUB  !move  Alloc  Waste   Trig    WP  GCs Mem-age
   0:     0     0     0     0     0     0     0     0     0        0     0 41943040    0   0  0.0000
   1:     0     0     0     0     0     0     0     0     0        0     0 41943040    0   0  0.0000
   2:     0     0     0     0     0     0     0     0     0        0     0 41943040    0   0  0.0000
   3: 38805 38652     0     0 49474 15433   389   416     0 2144219760 9031056 1442579856    0   1  1.5255
   4: 127998 127996     0     0 45870 14828   106   143   199 1971682720 25428576  2000000    0   0  0.0000
   5:     0     0     0     0     0     0     0     0     0        0     0  2000000    0   0  0.0000
   6:     0     0     0     0  1178   163     0     0     0 43941888     0  2000000  985   0  0.0000
   Total bytes allocated    = 4159844368
   Dynamic-space-size bytes = 4194304000
GC control variables:
   *GC-INHIBIT* = true
   *GC-PENDING* = in progress
   *STOP-FOR-GC-PENDING* = false
fatal error encountered in SBCL pid 9994(tid 46912556431104):
Heap exhausted, game over.

Welcome to LDB, a low-level debugger for the Lisp runtime environment.
ldb>
;   caught 18636 WARNING conditions


; insns.fasl written
; compilation finished in 0:07:11.329
Evaluation took:
  431.329 seconds of real time
  238.317000 seconds of total run time (234.972000 user, 3.345000 system)
  [ Run times consist of 6.073 seconds GC time, and 232.244 seconds non-GC time. ]
  55.25% CPU
  50,367 forms interpreted
  784,044 lambdas converted
  1,031,842,900,608 processor cycles
  19,402,921,376 bytes consed
#!/usr/bin/env perl
use strict;
use warnings;

# this program converts NASM's `insns.dat` to Common Lisp Object System (CLOS) syntax.

my $firstchar;
my $line_length;
my $are_there_square_brackets;
my $mnemonic_and_operands;
my $mnemonic;
my $operands;
my $code_string;
my $flags;
my $mnemonic_of_current_mnemonic_array;

my $clos_object_name;
my $clos_mnemonic;
my $clos_operands;
my $clos_code_string;
my $clos_flags;

my @object_name_array = ();
my @mnemonic_array = ();
my @operands_array = ();
my @code_string_array = ();
my @flags_array = ();

my @each_mnemonic_only_once_array = ();

my @instruction_variants_array = ();
my @instruction_variants_for_current_instruction_array = ();

open(FILE, 'insns.dat');

$mnemonic_of_current_mnemonic_array = "";

# read one line at once.
while (<FILE>)
{
    $firstchar = substr($_, 0, 1);
    $line_length = length($_);
    $are_there_square_brackets = ($_ =~ /\[.*\]/);
    chomp;
    if (($line_length > 1) && ($firstchar =~ /[^\t ;]/))
    {
        if ($are_there_square_brackets)
        {
            ($mnemonic_and_operands, $code_string, $flags) = split /[\[\]]+/, $_;
            $code_string = "[" . $code_string . "]";
            ($mnemonic, $operands) = split /[\t ]+/, $mnemonic_and_operands;
        }
        else
        {
            ($mnemonic, $operands, $code_string, $flags) = split /[\t ]+/, $_;
        }
        $mnemonic =~ s/[\t ]+/ /g;
        $operands =~ s/[\t ]+/ /g;
        $code_string =~ s/[\t ]+/ /g;
        $flags =~ s/[\t ]+//g;

        # we don't want non-x86-64 instructions here.
        unless ($flags =~ "NOLONG")
        {
            # ok, the content of each field is now filtered,
            # let's convert them to a suitable Common Lisp format.
            $clos_object_name = $mnemonic . "-" . $operands;

            # in Common Lisp object names `|`, `,`, and `:` must be escaped with a backslash `\`,
            # but that would get too complicated.
            # so we'll simply replace them:
            # `|` -> `-`.
            # `,` -> `.`.
            # `:` -> `.`.
            $clos_object_name =~ s/\|/-/g;              
            $clos_object_name =~ s/,/./g;              
            $clos_object_name =~ s/:/./g;              

            $clos_mnemonic    = "\"" . $mnemonic . "\"";
            $clos_operands    = "\"" . $operands . "\"";
            $clos_code_string = "\"" . $code_string . "\"";

            $clos_flags = "\"" . $flags . "\"";        # add first and last double quotes.
            $clos_flags =~ s/,/" "/g;                  # make each flag its own Common Lisp string.
            $clos_flags = "(list " . $clos_flags. ")"; # convert to `list` syntax.

            push @object_name_array, $clos_object_name;
            push @mnemonic_array, $clos_mnemonic;
            push @operands_array, $clos_operands;
            push @code_string_array, $clos_code_string;
            push @flags_array, $clos_flags;

            if ($mnemonic eq $mnemonic_of_current_mnemonic_array)
            {
                # ok, same mnemonic as the previous one,
                # so the current object name goes to the list.
                push @instruction_variants_for_current_instruction_array, $clos_object_name;
            }
            else
            {
                # ok, this is a new mnemonic.
                # so we'll mark this as current mnemonic.
                $mnemonic_of_current_mnemonic_array = $mnemonic;
                push @each_mnemonic_only_once_array, $mnemonic;

                # we first push the old array (unless it's empty), then clear it,
                # and then push the current object name to the cleared array.

                if (@instruction_variants_for_current_instruction_array)
                {
                    # push the variants array, unless it's empty.
                    push @instruction_variants_array, [ @instruction_variants_for_current_instruction_array ];
                }
                @instruction_variants_for_current_instruction_array = ();
                push @instruction_variants_for_current_instruction_array, $clos_object_name;
            }
        }
    }
}

# the last instruction's instruction variants must be pushed too.
if (@instruction_variants_for_current_instruction_array)
{
    # push the variants array, unless it's empty.
    push @instruction_variants_array, [ @instruction_variants_for_current_instruction_array ];
}

close(FILE);

# these objects need be created already during compilation.
printf("(eval-when (:compile-toplevel :load-toplevel :execute)\n");

# print the code to create each instruction + operands combination object.

for (my $i=0; $i <= $#mnemonic_array; $i++)
{
    $clos_object_name = $object_name_array[$i];
    $mnemonic         = $mnemonic_array[$i];
    $operands         = $operands_array[$i];
    $code_string      = $code_string_array[$i];
    $flags            = $flags_array[$i];

    # print the code to create a variant object.
    # each object here is a variant of a single instruction (or a single mnemonic).
    # actually printed as 6 lines to make it easier to read (for us humans, I mean), with an empty line in the end.
    printf("(setf %s (make-instance 'x86-asm-instruction\n:name %s\n:operands %s\n:code-string %s\n:arch-flags %s\n:is-variant t))",
        $clos_object_name,
        $mnemonic,
        $operands,
        $code_string,
        $flags);
    printf("\n\n");
}

# print the code to create each instruction + operands combination object.

# for (my $i=0; $i <= $#each_mnemonic_only_once_array; $i++)
for my $i (0 .. $#instruction_variants_array)
{
    $mnemonic = $each_mnemonic_only_once_array[$i];

    # print the code to create a container object.
    printf("(setf %s (make-instance 'x86-asm-instruction :name \"%s\" :is-container t :variants (list \n", $mnemonic, $mnemonic);
    @instruction_variants_for_current_instruction_array = $instruction_variants_array[$i];

    # for (my $j=0; $j <= $#instruction_variants_for_current_instruction_array; $j++)
    for my $j (0 .. $#{$instruction_variants_array[$i]} )
    {
        printf("%s", $instruction_variants_array[$i][$j]);

        # print 3 closing brackets if this is the last variant.
        if ($j == $#{$instruction_variants_array[$i]})
        {
            printf(")))");
        }
        else
        {
            printf(" ");
        }
    }

    # if this is not the last instruction, print two newlines.
    if ($i < $#instruction_variants_array)
    {
        printf("\n\n");
    }
}

# print the closing bracket to close `eval-when`.
print(")");

exit;