Fixed #2657

src/Perl6/Metamodel/ClassHOW.nqp

@@ -22,10 +22,10 @@ class Perl6::Metamodel::ClassHOW
     does Perl6::Metamodel::REPRComposeProtocol
     does Perl6::Metamodel::InvocationProtocol
     does Perl6::Metamodel::Finalization
+    does Perl6::Metamodel::Concretization
 {
     has @!roles;
     has @!role_typecheck_list;
-    has @!concretizations;
     has @!fallbacks;
     has $!composed;
 
@@ -98,7 +98,7 @@ class Perl6::Metamodel::ClassHOW
                 @!role_typecheck_list[+@!role_typecheck_list] := $r;
                 my $ins := $r.HOW.specialize($r, $obj);
                 @ins_roles.push($ins);
-                nqp::push(@!concretizations, [$r, $ins]);
+                self.add_concretization($obj, $r, $ins);
             }
             self.compute_mro($obj); # to the best of our knowledge, because the role applier wants it.
             @stubs := RoleToClassApplier.apply($obj, @ins_roles);
@@ -249,15 +249,6 @@ class Perl6::Metamodel::ClassHOW
         $!composed ?? @!role_typecheck_list !! self.roles_to_compose($obj)
     }
 
-    method concretization($obj, $ptype) {
-        for @!concretizations {
-            if nqp::decont($_[0]) =:= nqp::decont($ptype) {
-                return $_[1];
-            }
-        }
-        nqp::die("No concretization found for " ~ $ptype.HOW.name($ptype));
-    }
-
     method is_composed($obj) {
         $!composed
     }

src/Perl6/Metamodel/ConcreteRoleHOW.nqp

@@ -8,6 +8,7 @@ class Perl6::Metamodel::ConcreteRoleHOW
     does Perl6::Metamodel::RoleContainer
     does Perl6::Metamodel::MultipleInheritance
     does Perl6::Metamodel::ArrayType
+    does Perl6::Metamodel::Concretization
 {
     # Any collisions to resolve.
     has @!collisions;

src/Perl6/Metamodel/Concretization.nqp

@@ -0,0 +1,37 @@
+# Support for mapping of non-specialized roles into their concretized state.
+role Perl6::Metamodel::Concretization {
+    has @!concretizations;
+
+    method add_concretization($obj, $role, $concrete) {
+        @!concretizations[+@!concretizations] := [$role, $concrete];
+    }
+
+    method concretization_lookup($obj, $ptype, :$local, :$transitive) {
+        my @result;
+        if nqp::istype($obj, $ptype) {
+            for @!concretizations {
+                if nqp::decont($_[0]) =:= nqp::decont($ptype) {
+                    return [1, $_[1]];
+                }
+                # Do preliminary type check for concrete role to avoid extra calls.
+                if $transitive && nqp::istype($_[1], $ptype) {
+                    @result := $_[1].HOW.concretization_lookup($_[1], $ptype, :$local, :transitive(1));
+                    return @result if @result[0];
+                }
+            }
+            unless $local {
+                for self.parents($obj, :local(1)) {
+                    @result := $_.HOW.concretization_lookup($_, $ptype, :local(0), :$transitive);
+                    return @result if @result[0];
+                }
+            }
+        }
+        [0]
+    }
+
+    method concretization($obj, $ptype, :$local = 0, :$transitive = 1) {
+        my @result := self.concretization_lookup($obj, $ptype, :$local, :$transitive);
+        nqp::die("No concretization found for " ~ $ptype.HOW.name($ptype)) unless @result[0];
+        @result[1]
+    }
+}

src/Perl6/Metamodel/MROBasedMethodDispatch.nqp

@@ -26,8 +26,8 @@ role Perl6::Metamodel::MROBasedMethodDispatch {
 
     method find_method_qualified($obj, $qtype, $name) {
         if $qtype.HOW.archetypes.parametric && nqp::can(self, 'concretization') {
-            # Resolve it via the concrete form of this parametric.
-            my $conc := self.concretization($obj, $qtype);
+            # Resolve it via the concrete form of this parametric. Look deep for a candidate.
+            my $conc := self.concretization($obj, $qtype, :local(0), :transitive(1));
             nqp::hllize($conc.HOW.method_table($conc)){$name}
         }
         else {

src/Perl6/Metamodel/ParametricRoleHOW.nqp

@@ -192,12 +192,14 @@ class Perl6::Metamodel::ParametricRoleHOW
         # Roles done by this role need fully specializing also; all
         # they'll be missing is the target class (e.g. our first arg).
         for self.roles_to_compose($obj) {
-            my $r := $_;
+            my $ins := my $r := $_;
             if $_.HOW.archetypes.generic {
-                $r := $r.HOW.instantiate_generic($r, $type_env);
-                $conc.HOW.add_to_role_typecheck_list($conc, $r);
+                $ins := $ins.HOW.instantiate_generic($ins, $type_env);
+                $conc.HOW.add_to_role_typecheck_list($conc, $ins);
             }
-            $conc.HOW.add_role($conc, $r.HOW.specialize($r, @pos_args[0]));
+            $ins := $ins.HOW.specialize($ins, @pos_args[0]);
+            $conc.HOW.add_role($conc, $ins);
+            $conc.HOW.add_concretization($conc, $r, $ins);
         }
 
         # Pass along any parents that have been added, resolving them in

tools/build/common_bootstrap_sources

@@ -31,6 +31,7 @@ src/Perl6/Metamodel/InvocationProtocol.nqp
 src/Perl6/Metamodel/RolePunning.nqp
 src/Perl6/Metamodel/ArrayType.nqp
 src/Perl6/Metamodel/RoleToRoleApplier.nqp
+src/Perl6/Metamodel/Concretization.nqp
 src/Perl6/Metamodel/ConcreteRoleHOW.nqp
 src/Perl6/Metamodel/CurriedRoleHOW.nqp
 src/Perl6/Metamodel/ParametricRoleHOW.nqp