Skip to content

Commit

Permalink
Streamline Metamodel::ConcreteRoleHOW
Browse files Browse the repository at this point in the history 
- give Collision its own new using positionals, and use native attributes
  where possible
- make several methods that change non-scalar attributes threadsafe
- only compose once in the lifetime of the object
- make sure the typecache only contains unique types, which should help
  in memory usages, and runtime for failing nqp::istype checks

Also left some debugging code in there (but commented out), because iti
produced some really weird results.
  • Loading branch information
@lizmat
lizmat committed Mar 25, 2024
1 parent bafa92a commit 72c491f
Showing 1 changed file with 149 additions and 67 deletions.
216 changes: 149 additions & 67 deletions src/Perl6/Metamodel/ConcreteRoleHOW.nqp
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
#- Metamodel::ConcreteRoleHOW --------------------------------------------------
class Perl6::Metamodel::ConcreteRoleHOW
does Perl6::Metamodel::Naming
does Perl6::Metamodel::BUILDALL
Expand All @@ -23,52 +24,96 @@ class Perl6::Metamodel::ConcreteRoleHOW
# Full flat list of done roles.
has @!role_typecheck_list;

my $archetypes := Perl6::Metamodel::Archetypes.new( :nominal(1), :composable(1) );
my $archetypes := Perl6::Metamodel::Archetypes.new(
:nominal, :composable
);
method archetypes($XXX?) { $archetypes }

my class Collision {
has $!name;
has @!roles;
has $!private;
has $!multi;
method name() { $!name }
method roles() { @!roles }
has str $!name;
has @!roles;
has int $!private;
has $!multi;

method new(str $name, @roles, $private, $multi) {
my $obj := nqp::create(self);

nqp::bindattr_s($obj, Collision, '$!name', $name);
nqp::bindattr( $obj, Collision, '@!roles', @roles);
nqp::bindattr_i($obj, Collision, '$!private', 1) if $private;
nqp::bindattr( $obj, Collision, '$!multi', $multi);

$obj
}

method name() { $!name }
method roles() { @!roles }
method private() { $!private }
method multi() { $!multi }
method multi() { $!multi }
}

method new_type(:@roles, :$repr, *%_) {
my $HOW := self.new(:roles(@roles));
my $target := nqp::settypehll(nqp::newtype($HOW, 'Uninstantiable'), 'Raku');

$HOW.set_identity($target, %_);
$target
my $HOW := self.new(:@roles);
my $type := nqp::newtype($HOW, 'Uninstantiable');
nqp::settypehll($type, 'Raku');
$HOW.set_identity($type, %_);
$type
}

method add_collision($XXX, $colliding_name, @role_names, :$private = 0, :$multi) {
nqp::push(@!collisions, Collision.new(
:name($colliding_name), :roles(@role_names), :$private, :$multi
));
method add_collision($XXX, $name, @role_names, :$private, :$multi) {
self.protect({
my @collisions := @!collisions;
nqp::push(@!collisions, Collision.new(
$name, @role_names, $private, $multi
));
@!collisions := @collisions;
});
}

method compose($target) {
$target := nqp::decont($target);

Perl6::Metamodel::Configuration.role_to_role_applier_type.apply($target, self.roles_to_compose);
for self.roles_to_compose {
nqp::push(@!role_typecheck_list, $_);
for $_.HOW.role_typecheck_list($_) {
nqp::push(@!role_typecheck_list, $_);
}
}
for @!roles {
nqp::push(@!role_typecheck_list, $_);
for $_.HOW.role_typecheck_list($_) {
nqp::push(@!role_typecheck_list, $_);
unless self.is_composed {
$target := nqp::decont($target);
my @roles_to_compose := self.roles_to_compose;

Perl6::Metamodel::Configuration.role_to_role_applier_type.apply(
$target, @roles_to_compose
);

my @role_typecheck_list := nqp::clone(@!role_typecheck_list);
sub add_to_typecheck_list(@roles) {
my int $m := nqp::elems(@roles);
my int $i;
while $i < $m {
my $role := nqp::atpos(@roles, $i);
nqp::push(@role_typecheck_list, $role);
nqp::splice(
@role_typecheck_list,
$role.HOW.role_typecheck_list($role),
nqp::elems(@role_typecheck_list),
0
);
++$i;
}
}

add_to_typecheck_list(@roles_to_compose);
add_to_typecheck_list(@!roles);
@!role_typecheck_list := @role_typecheck_list;

# This debugging code produces some really weird results when building the
# setting. So leaving this in here for further investigation at a later time.
# The weirdness is really expressed by duplicating iterations, with different
# values, and skipping ierations. Even though they all appear to be running
# in the same thread.
#nqp::say("composing role " ~ $target.HOW.name($target) ~ " typechecks " ~ nqp::elems(@role_typecheck_list));
#my int $i;
#for @role_typecheck_list {
# nqp::say(nqp::threadid(nqp::currentthread) ~ " " ~ $i++ ~ " " ~ nqp::objectid($_));
#}

self.publish_type_cache($target);
self.set_composed;
}
self.publish_type_cache($target);
self.set_composed;
$target
}

Expand All @@ -82,72 +127,109 @@ class Perl6::Metamodel::ConcreteRoleHOW
}

method add_to_role_typecheck_list($XXX, $type) {
nqp::push(@!role_typecheck_list, $type);
self.protect({
my @role_typecheck_list := nqp::clone(@!role_typecheck_list);
nqp::push(@role_typecheck_list, $type);
@!role_typecheck_list := @role_typecheck_list;
});
}

method role_typecheck_list($XXX?) { @!role_typecheck_list }

method type_check($target, $checkee) {
$checkee := nqp::decont($checkee);
if $checkee =:= $target.WHAT {
return 1;
}
for @!role_typecheck_list {
if nqp::decont($_) =:= $checkee {
return 1;

# Helper sub to check checkee against a list of types
sub check_checkee_against(@types) {
my int $m := nqp::elems(@types);
my int $i;
while $i < $m {
nqp::eqaddr($checkee, nqp::decont(nqp::atpos(@types, $i)))
?? (return 1)
!! ++$i;
}
0
}
0

nqp::eqaddr($checkee,$target.WHAT)
|| check_checkee_against(@!role_typecheck_list)
}

method publish_type_cache($target) {
my @types := [$target.WHAT];
for @!role_typecheck_list { @types.push($_) }
my @role_typecheck_list := @!role_typecheck_list;
my @types := nqp::list($target.WHAT);
my %seen;

# While debugging another issue, it became clear that the typecheck
# list did not contain just unique values. This in itself is not
# a problem for matching types, but it forces unnecessary extra checks
# during runtime if the type does *not* match, and it uses more
# memory. So make sure we only have unique values in this types
# typecheck cache.
my int $m := nqp::elems(@role_typecheck_list);
my int $i;
while $i < $m {
my $type := nqp::atpos(@role_typecheck_list, $i);
my int $id := nqp::objectid($type);
unless nqp::existskey(%seen, $id) {
nqp::push(@types, $type);
nqp::bindkey(%seen, $id, 1);
}
++$i;
}
nqp::settypecache($target, @types)
}

method mro($target, :$roles, :$concretizations, :$unhidden) {
[$target]
nqp::list($target)
}

method find_method_qualified($target, $qtype, $name) {
$target := nqp::decont($target);
$qtype := nqp::decont($qtype);
$qtype := nqp::decont($qtype);

if $qtype.HOW.archetypes.parametric {
my $found-role := nqp::null();
for self.concretizations($target, :transitive) {
my $candidate := $_;
my $role := $_.HOW.roles($_, :!transitive, :!mro)[0];
if nqp::can($role.HOW, 'group') {
$role := $role.HOW.group($role);
}
if $qtype =:= $role {
# XXX Better be replaced with Exception throwing. The mechanizm could be provided via
# Perl6::Metamodel::Configuration where a property could be set pointing to a Raku object.
# It could be something like:
# Perl6::Metamodel::Configuration.throw("nqp::die message", ['X', 'Method', 'Ambiguous'], |%exception-params);
nqp::die("Ambiguous concretization lookup for " ~ $qtype.HOW.name($qtype))
unless nqp::isnull($found-role);
$found-role := $candidate;
my $found := nqp::null;
my @concretizations := self.concretizations($target, :transitive);

my int $m := nqp::elems(@concretizations);
my int $i;
while $i < $m {
my $candidate := nqp::atpos(@concretizations, $i);
my $role := nqp::atpos(
$candidate.HOW.roles($candidate, :!transitive, :!mro), 0
);
$role := $role.HOW.group($role)
if nqp::can($role.HOW, 'group');

if nqp::eqaddr($qtype, $role) {
nqp::isnull($found)
?? ($found := $candidate)
!! nqp::die(
"Ambiguous concretization lookup for "
~ $qtype.HOW.name($qtype)
);
}
++$i;
}
nqp::isnull($found-role)
?? nqp::null()
!! $found-role.HOW.method_table($found-role){$name}
|| $found-role.HOW.submethod_table($found-role){$name}
|| nqp::null()
nqp::isnull($found)
?? nqp::null
!! nqp::atkey($found.HOW.method_table($found), $name)
|| nqp::atkey($found.HOW.submethod_table($found), $name)
}

# Non-parametric, so just locate it from the already concrete type.
elsif nqp::istype($target, $qtype) {
# Non-parametric, so just locate it from the already concrete type.
nqp::findmethod($qtype, $name)
}

else {
nqp::null()
nqp::null
}
}

method is-implementation-detail($target) {
@!roles[0].is-implementation-detail($target)
nqp::atpos(@!roles, 0).is-implementation-detail($target)
}
}

Expand Down

0 comments on commit 72c491f

Please sign in to comment.