aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--interpreter/Elymas.pm258
-rw-r--r--interpreter/ElymasGlobal.pm87
-rwxr-xr-xinterpreter/elymas2
3 files changed, 296 insertions, 51 deletions
diff --git a/interpreter/Elymas.pm b/interpreter/Elymas.pm
index 8d702f5..4027e7f 100644
--- a/interpreter/Elymas.pm
+++ b/interpreter/Elymas.pm
@@ -6,14 +6,26 @@ use warnings;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(
- popInt popString popArray $quoted @globalCallStack
+ popInt popString popArray $quoted @globalCallStack $globalScope $globalData
interpretCode compileCode execute executeString executeFile resolve canCastTo typeEqual
+ register
);
use Data::Dumper;
+use Devel::Leak;
+use Devel::Cycle;
+use Devel::FindRef;
+our @allObjs;
+use PadWalker qw(closed_over set_closed_over peek_sub peek_my peek_our);
+
+use Scalar::Util qw(weaken);
+
our $quoted = 0;
our @globalCallStack;
+our $globalScope;
+our $globalData = [];
+our @globalGCRoots = (\@globalCallStack, \$globalScope, $globalData);
sub popInt {
my ($data) = @_;
@@ -58,8 +70,11 @@ sub interpretCode {
if($@) {
#print "Code: " . Dumper($tokens);
#print "Scope: " . Dumper($scope);
- print "Stack: " . Dumper($data);
- print "Token: " . Dumper($t);
+ {
+ local $@;
+ print "Stack: " . Dumper($data);
+ print "Token: " . $t->[0] . Dumper($t);
+ }
die;
}
}
@@ -73,7 +88,7 @@ sub compileCode {
my $hasStackOps = 0;
my $skip = 0;
- $ret .= "my \$i = 0; my \$name; my \$meaning; my \$rscope; eval {\n";
+ $ret .= "my \$i = 0; my \$meaning; my \$rscope; eval {\n";
foreach my $i (0 .. $#$code) {
if($skip) {
@@ -164,14 +179,17 @@ EOPERL
$ret .= $popCode and $popPending = 0 if $popPending;
if($hasStackOps) {
- $ret = "my \$f; my \@buffer; \n" . $ret;
+ $ret = "my \$f; my \@buffer; register(\\\@buffer); \n" . $ret;
}
$ret .= <<'EOPERL';
};
if($@) {
- print "Stack: " . Dumper($data);
- print "Token: " . Dumper($code[$i]);
+ {
+ local $@;
+ print "Stack: " . Dumper($data);
+ print "Token: " . $code[$i]->[0] . Dumper($code[$i]);
+ }
die;
}
EOPERL
@@ -338,21 +356,26 @@ sub doLoopStep {
sub execute {
my ($f, $data, $scope) = @_;
+ if(not grep { $data != $_ } @globalGCRoots) {
+ die "executed-upon data not in GC root list";
+ }
+
if(ref($f->[1]) ne 'ARRAY') {
push @$data, $f;
return;
}
if($f->[1]->[0] eq 'array') {
- my $ff = $f;
- $f = [sub {
- my ($data) = @_;
+ execute(register([register(sub {
+ my ($data) = @_;
- my $i = pop @$data or die "Stack underflow";
- die "array index must be int" unless $i->[1] eq 'int';
+ my $i = pop @$data or die "Stack underflow";
+ die "array index must be int" unless $i->[1] eq 'int';
- push @$data, $ff->[0]->[$i->[0] % @{$ff->[0]}];
- }, ['func', 'array-to-func-cast', ['int'], [$ff->[1]->[1]]]];
+ push @$data, $f->[0]->[$i->[0] % @{$f->[0]}];
+ }), ['func', 'array-to-func-cast', ['int'], [$f->[1]->[1]]]]),
+ $data, $scope);
+ return;
} elsif($f->[1]->[0] ne 'func') {
die "complex type unsuitable for execution";
}
@@ -523,12 +546,15 @@ sub execute {
foreach my $i (@$stage) {
my @s = ($v, $argCopy[$i]);
my $func = pop @s or die "Stack underflow in abstraction";
+ push @globalGCRoots, \@s;
execute($func, \@s, $scope);
+ pop @globalGCRoots;
$argCopy[$i] = $s[0];
}
&$unravel($data, \@argCopy, \@stageCallCopy, \@argTypeCopy, \@loopCopy);
};
+ register($abstraction);
push @$data, [$abstraction, ['func', 'autoabstraction of ' . $f->[1]->[1], [grep { $_ } @argTypeCopy], undef]];
# FIXME the undef can be determined
@@ -542,7 +568,9 @@ sub execute {
foreach my $j (@$stage) {
my @s = ($i, $argCopy2[$j]);
my $func = pop @s or die "Stack underflow in abstraction";
+ push @globalGCRoots, \@s;
execute($func, \@s, $scope);
+ pop @globalGCRoots;
$argCopy2[$j] = $s[0];
}
@@ -565,8 +593,9 @@ sub execute {
push @$data, @argCopy;
}
};
-
+ register($unravel);
&$unravel($data, \@concreteArgs, \@stageCalls, \@argTypes, \@loops);
+ weaken($unravel);
}
}
@@ -588,18 +617,32 @@ sub applyResolvedName {
if(not defined $meaning) {
if($quoted) {
- push @$data, [sub {
+ my $quotedSub = sub {
my ($data, $scope) = @_;
my $meaning = resolve($$scope, $data, $t->[0]);
applyResolvedName($t, $meaning, $data, $scope, 0);
- }, ['func', 'quoted late-resolve of ' . $t->[0]], $t->[0]];
+ };
+ push @$data, register([register($quotedSub), ['func', 'quoted late-resolve of ' . $t->[0]], $t->[0]]);
+ weaken($quotedSub);
} else {
die "could not resolve '$t->[0]'";
}
} elsif($meaning->[2] eq 'passive') {
if($quoted) {
- push @$data, [sub { push @{$_[0]}, [$meaning->[0], $meaning->[1]] }, ['func', 'quoted-constant of ' . $t->[0]], $t->[0]];
+ my $subLive = 1;
+ my $sub; $sub = sub {
+ unless($subLive) {
+ warn Devel::FindRef::track($sub, 10);
+ warn Dumper($sub);
+ die "tried to execute GCed sub (quoted passive constant)";
+ }
+
+ my ($data) = @_;
+ push @$data, [$meaning->[0], $meaning->[1]];
+ };
+ push @$data, register([register($sub), ['func', 'quoted-constant of ' . $t->[0]], $t->[0]]);
+ weaken($sub);
} else {
push @$data, [$meaning->[0], $meaning->[1]];
}
@@ -633,23 +676,186 @@ sub interpretTokens {
if($@) {
#print "Code: " . Dumper($tokens);
#print "Scope: " . Dumper($scope);
- print "Stack: " . Dumper($data);
- print "Token: " . Dumper($t);
+ {
+ local $@;
+ print "Stack: " . Dumper($data);
+ print "Token: " . $t->[0] . Dumper($t);
+ }
die;
}
}
}
+sub garbageCollect {
+ my $reachableObjs = {};
+
+ foreach my $root (@globalGCRoots) {
+ markObjs($reachableObjs, $root, "");
+ }
+ my $level;
+ #warn "Marked objects: " . scalar keys %$reachableObjs;
+ eval {
+ for($level = 1; ; ++$level) {
+ #warn "Level $level";
+
+ # peek_my returns identical hash-ref each time, need to traverse
+ # without seen-check
+ my $locals = peek_my($level);
+ markObjsInHash($reachableObjs, $locals, "S:");
+ }
+ };
+ if($@ !~ /Not nested deeply enough/) {
+ die "Unexpected level traversal error: " . $@;
+ }
+ #warn "Levels traversed: $level";
+ #warn "Marked objects (2): " . join "\n", keys %$reachableObjs;
+
+ my @cleanedObjs;
+
+ foreach my $i (0 .. $#allObjs) {
+ my $obj = $allObjs[$i];
+
+ if(not exists $reachableObjs->{$obj}) {
+ next unless ref($obj);
+
+ if(ref($obj) eq 'CODE') {
+ my ($closed_over, undef) = closed_over($obj);
+ my $killHash = {};
+
+ foreach my $key (keys %$closed_over) {
+ if($key =~ /^@/) {
+ $killHash->{$key} = [];
+ } elsif($key =~ /^%/) {
+ $killHash->{$key} = {};
+ #} elsif($key eq '$obj') {
+ # skip DEBUG FIXME
+ } elsif($key =~ /^\$/) {
+ $killHash->{$key} = \undef;
+ } else {
+ die "Cannot construct gc kill template for closed var: " . $key;
+ }
+ }
+
+ set_closed_over($obj, $killHash);
+ } elsif(ref($obj) eq 'ARRAY') {
+ @$obj = ();
+ } elsif(ref($obj) eq 'REF') {
+ $$obj = undef;
+ } else {
+ die "Garbage collect sweep cannot handle object reference: $obj";
+ }
+
+ push @cleanedObjs, $allObjs[$i];
+ $allObjs[$i] = undef;
+ }
+ }
+
+ %$reachableObjs = ();
+
+ print "Before GC: " . scalar @allObjs . "\n";
+ @allObjs = grep { defined } @allObjs;
+ print "After GC: " . scalar @allObjs . "\n";
+
+# foreach my $obj (@cleanedObjs) {
+# print Devel::FindRef::track($obj);
+# }
+}
+
+sub markObjsInHash {
+ my ($reachableObjs, $hash, $indent) = @_;
+
+ #warn $indent . "Unseen Hash-Walking: $obj";
+ foreach my $k (keys %$hash) {
+ #warn $indent . "-> $k: $obj->{$k}";
+ markObjs($reachableObjs, $hash->{$k}, $indent . " ");
+ }
+}
+
+sub markObjs {
+ my ($reachableObjs, $obj, $indent) = @_;
+
+ return unless defined $obj and ref($obj);
+ return if exists $reachableObjs->{$obj};
+
+ $reachableObjs->{$obj} = 1;
+
+ if(ref($obj) eq 'ARRAY') {
+ #warn $indent . "Array-Walking: $obj, " . scalar @$obj . " elements";
+ foreach my $i (0 .. $#$obj) {
+ #warn $indent . "-> [$i]: $obj->[$i]";
+ markObjs($reachableObjs, $obj->[$i], $indent . " ");
+ }
+ } elsif(ref($obj) eq 'HASH') {
+ #warn $indent . "Hash-Walking: $obj";
+ foreach my $k (keys %$obj) {
+ #warn $indent . "-> $k: $obj->{$k}";
+ markObjs($reachableObjs, $obj->{$k}, $indent . " ");
+ }
+ } elsif(ref($obj) eq 'REF') {
+ #warn $indent . "Ref-Walking: $obj";
+ markObjs($reachableObjs, $$obj, $indent . " ");
+ } elsif(ref($obj) eq 'SCALAR') {
+ # nothing to follow here
+ } elsif(ref($obj) eq 'GLOB') {
+ #warn $indent . "Glob-Walking: $obj";
+ markObjs($reachableObjs, *$obj{'SCALAR'}, $indent . " ");
+ markObjs($reachableObjs, *$obj{'ARRAY'}, $indent . " ");
+ markObjs($reachableObjs, *$obj{'HASH'}, $indent . " ");
+ markObjs($reachableObjs, *$obj{'CODE'}, $indent . " ");
+ markObjs($reachableObjs, *$obj{'IO'}, $indent . " ");
+ markObjs($reachableObjs, *$obj{'GLOB'}, $indent . " ");
+ markObjs($reachableObjs, *$obj{'FORMAT'}, $indent . " ");
+ } elsif(ref($obj) eq 'IO::File') {
+ # don't handle these
+ } elsif(ref($obj) eq 'CODE') {
+ #warn $indent . "Code-Walking: $obj";
+ my ($closed_over, $closed_over_2) = closed_over($obj);
+ markObjsInHash($reachableObjs, $closed_over, $indent . " ");
+ markObjsInHash($reachableObjs, $closed_over_2, $indent . " ");
+
+ my $peek_sub = peek_sub($obj);
+ markObjsInHash($reachableObjs, $peek_sub, $indent . " ");
+ } else {
+ die "GC cannot handle ref type: " . ref($obj);
+ }
+}
+
+my $lastAllObjSize = 0;
+
+sub register {
+ my ($obj) = @_;
+
+ # if(@allObjs > $lastAllObjSize + 100000) {
+ # garbageCollect();
+ # $lastAllObjSize = @allObjs;
+ # }
+
+ # push @allObjs, $obj;
+
+ return $obj;
+}
+
sub executeFile {
my ($file, $data, $scope) = @_;
- open my $code, '<', $file or die "cannot open $file: $!";
- while(my $line = <$code>) {
- chomp $line;
+ my $leakHandle;
+ Devel::Leak::NoteSV($leakHandle);
+
+ {
+ open my $code, '<', $file or die "cannot open $file: $!";
+ while(my $line = <$code>) {
+ chomp $line;
- executeString($line, $data, $scope);
+ executeString($line, $data, $scope);
+ }
+ close $code;
}
- close $code;
+
+ #garbageCollect();
+
+ #Devel::Leak::CheckSV($leakHandle);
+ #Devel::Cycle::find_cycle($scope);
+ #Devel::Cycle::find_cycle(\@allObjs);
}
sub executeString {
@@ -688,6 +894,8 @@ sub tokenize {
$str .= '\\';
} elsif($1 eq 'n') {
$str .= "\n";
+ } elsif($1 eq '0') {
+ $str .= "\0";
} elsif($1 eq '"') {
$str .= "\"";
} else {
diff --git a/interpreter/ElymasGlobal.pm b/interpreter/ElymasGlobal.pm
index 42b8bee..7427b03 100644
--- a/interpreter/ElymasGlobal.pm
+++ b/interpreter/ElymasGlobal.pm
@@ -7,8 +7,10 @@ use Elymas;
use ElymasSys;
use Data::Dumper;
+use Devel::FindRef;
+use Scalar::Util qw(weaken);
-our $global = {
+$globalScope = {
'/' => [sub { }, ['func', '/'], 'active'],
'|' => [sub {
my ($data, $scope) = @_;
@@ -42,6 +44,8 @@ our $global = {
--$quoted;
my @code;
+ register(\@code);
+
while(1) {
my $t = pop @$data or die "Stack underflow";
last if($t->[1] eq 'tok' and $t->[0] eq '{');
@@ -71,32 +75,58 @@ our $global = {
# }
if($quoted) {
- my $sub = <<'EOPERL' .
+ my $subLive = 1;
+ my $sub;
+ my $subCode = <<'EOPERL' .
sub {
+ unless($subLive) {
+ warn Devel::FindRef::track($sub, 10);
+ warn Dumper($sub);
+ warn Dumper(\@code);
+ die "tried to execute GCed sub";
+ }
my ($data, $refScope) = @_;
my $scope = $$refScope;
my $s = sub {
+ unless($subLive) {
+ warn Devel::FindRef::track($sub, 10);
+ warn Dumper($sub);
+ warn Dumper(\@code);
+ die "tried to execute GCed sub";
+ }
my ($data) = @_;
- my $lscope = \{ ' parent' => $scope };
+ my $lscope = register(\{ ' parent' => $scope });
EOPERL
compileCode(\@code) . <<'EOPERL';
};
- push @$data, [$s, ['func', 'compiled sub (1)']];
+ push @$data, register([register($s), ['func', 'compiled sub (1)']]);
+ weaken($s);
}
EOPERL
- $sub = eval($sub);
- push @$data, [$sub, ['func', 'func-quoted'], \@code];
+ $sub = eval($subCode);
+ my $pushData = register([register($sub), ['func', 'func-quoted'], \@code]);
+ push @$data, $pushData;
+ weaken($sub);
} else {
- my $sub = <<'EOPERL' .
+ my $subLive = 1;
+ my $sub;
+ my $subCode = <<'EOPERL' .
sub {
+ unless($subLive) {
+ warn Devel::FindRef::track($sub, 10);
+ warn Dumper($sub);
+ warn Dumper(\@code);
+ die "tried to execute GCed sub";
+ }
my ($data) = @_;
- my $lscope = \{ ' parent' => $scope };
+ my $lscope = register(\{ ' parent' => $scope });
EOPERL
compileCode(\@code) . <<'EOPERL';
};
EOPERL
- $sub = eval($sub);
- push @$data, [$sub, ['func', 'compiled sub (2)']];
+ $sub = eval($subCode);
+ push @$data, register([register($sub), ['func', 'compiled sub (2)']]);
+ weaken($sub);
}
}, ['func', '}'], 'quote'],
"}'" => [sub {
@@ -106,6 +136,8 @@ EOPERL
--$quoted;
my @code;
+ register(\@code);
+
while(1) {
my $t = pop @$data or die "Stack underflow";
last if($t->[1] eq 'tok' and $t->[0] eq '{');
@@ -143,11 +175,13 @@ EOPERL
EOPERL
compileCode(\@code) . <<'EOPERL';
};
- push @$data, [$s, ['func', 'compiled sub (1)']];
+ push @$data, register([register($s), ['func', 'compiled sub (1)']]);
+ weaken($s);
}
EOPERL
$sub = eval($sub);
- push @$data, [$sub, ['func', 'func-quoted'], \@code];
+ push @$data, register([register($sub), ['func', 'func-quoted'], \@code]);
+ weaken($sub);
} else {
my $sub = <<'EOPERL' .
sub {
@@ -158,7 +192,8 @@ EOPERL
};
EOPERL
$sub = eval($sub);
- push @$data, [$sub, ['func', 'compiled sub (2)']];
+ push @$data, register([register($sub), ['func', 'compiled sub (2)']]);
+ weaken($sub);
}
}, ['func', "}'"], 'quote'],
'quoted' => [sub {
@@ -212,12 +247,12 @@ EOPERL
my $g = pop @$data or die "Stack underflow";
my $f = pop @$data or die "Stack underflow";
- push @$data, [sub {
+ push @$data, register([register(sub {
my ($data, $scope) = @_;
execute($f, $data, $scope);
execute($g, $data, $scope);
- }, ['func', 'f g ;']];
+ }), ['func', 'f g ;']]);
}, ['func', ';'], 'active'],
'[' => [sub {
my ($data, $scope) = @_;
@@ -227,6 +262,8 @@ EOPERL
my ($data, $scope) = @_;
my @content;
+ register(\@content);
+
my $type = undef;
while(1) {
my $t = pop @$data or die "Stack underflow";
@@ -249,7 +286,7 @@ EOPERL
unshift @content, $t;
};
- push @$data, [\@content, ['array', '[]', [['range', 0, $#content]], [$type]]];
+ push @$data, register([\@content, ['array', '[]', [['range', 0, $#content]], [$type]]]);
}, ['func', ']'], 'active'],
'<' => [sub {
my ($data, $scope) = @_;
@@ -295,7 +332,7 @@ EOPERL
my $name = pop @$data or die "Stack underflow";
my $func = pop @$data or die "Stack underflow";
- $$scope->{$name->[0]} = [@$func, 'active'];
+ $$scope->{$name->[0]} = [$func->[0], $func->[1], 'active'];
}, ['func', 'deff'], 'active'],
'defv' => [sub {
my ($data, $scope) = @_;
@@ -303,7 +340,7 @@ EOPERL
my $name = pop @$data or die "Stack underflow";
my $func = pop @$data or die "Stack underflow";
- $$scope->{$name->[0]} = [@$func, 'passive'];
+ $$scope->{$name->[0]} = [$func->[0], $func->[1], 'passive'];
}, ['func', 'defv'], 'active'],
'defq' => [sub {
my ($data, $scope) = @_;
@@ -311,7 +348,7 @@ EOPERL
my $name = pop @$data or die "Stack underflow";
my $func = pop @$data or die "Stack underflow";
- $$scope->{$name->[0]} = [@$func, 'quote'];
+ $$scope->{$name->[0]} = [$func->[0], $func->[1], 'quote'];
}, ['func', 'defq'], 'active'],
'=' => [sub {
my ($data, $scope) = @_;
@@ -321,7 +358,7 @@ EOPERL
my $meaning = resolve($$scope, $data, $name->[0]);
if(not $meaning) {
- $$scope->{$name->[0]} = [@$func, 'passive'];
+ $$scope->{$name->[0]} = [$func->[0], $func->[1], 'passive'];
} else {
$meaning->[0] = $func->[0];
$meaning->[1] = $func->[1];
@@ -637,7 +674,7 @@ EOPERL
sub installGlobal1IntFunction {
my ($name, $code) = @_;
- $global->{$name} = [sub {
+ $globalScope->{$name} = [sub {
my ($data, $scope) = @_;
my $a = popInt($data);
@@ -670,9 +707,9 @@ EOPERL
$sub = eval($sub);
- $global->{$name} = [$sub, ['func', $name, ['int', 'int'], ['int']], 'active'];
+ $globalScope->{$name} = [$sub, ['func', $name, ['int', 'int'], ['int']], 'active'];
-# $global->{$name} = [sub {
+# $globalScope->{$name} = [sub {
# my ($data, $scope) = @_;
#
# my $b = pop @$data;
@@ -690,7 +727,7 @@ EOPERL
sub installGlobal2StrFunction {
my ($name, $code) = @_;
- $global->{$name} = [sub {
+ $globalScope->{$name} = [sub {
my ($data, $scope) = @_;
my $b = pop @$data;
@@ -895,7 +932,7 @@ sub takeTimings {
}
}
-# takeTimings($global);
+# takeTimings($globalScope);
END {
foreach my $key (sort { $timings{$a} <=> $timings{$b} } keys %timings) {
diff --git a/interpreter/elymas b/interpreter/elymas
index 2a81286..7c8d2c7 100755
--- a/interpreter/elymas
+++ b/interpreter/elymas
@@ -15,4 +15,4 @@ use Data::Dumper;
use Elymas;
use ElymasGlobal;
-executeFile($ARGV[0], [], \$ElymasGlobal::global);
+executeFile($ARGV[0], $globalData, \$globalScope);
generated by cgit v1.2.3 (git 2.25.1) at 2026-01-16 05:44:27 +0000