Skip to content

Commit

Permalink
Merge pull request #5493 from vrurg/complete-generic-instantiation-4
Browse files Browse the repository at this point in the history 
Complete generic instantiation 4
  • Loading branch information
@vrurg
vrurg committed Dec 16, 2023
2 parents 497899e + 18d626b commit 69d6168
Show file tree
Hide file tree
Showing 15 changed files with 272 additions and 174 deletions.
154 changes: 87 additions & 67 deletions src/Perl6/Actions.nqp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3383,19 +3383,6 @@ class Perl6::Actions is HLL::Actions does STDActions {

# Handle parametricism for roles.
if $*PKGDECL eq 'role' {
if nqp::isconcrete($*GENERICS) {
my $lexpad := $block[0];
my $gen_iter := nqp::iterator($*GENERICS);
while $gen_iter {
my $decl := nqp::shift($gen_iter);
$lexpad.push(
QAST::Stmt.new(
QAST::Op.new(
:op<bind>,
QAST::Var.new( :name(nqp::iterkey_s($decl)), :scope<lexical>, :decl<var> ),
QAST::WVal.new( :value(nqp::iterval($decl)) ))));
}
}
# Set up signature. Needs to have $?CLASS as an implicit
# parameter, since any mention of it is generic.
my %sig_info := $<signature> ?? $<signature>.ast !! hash(parameters => []);
Expand All @@ -3404,21 +3391,40 @@ class Perl6::Actions is HLL::Actions does STDActions {
is_multi_invocant => 1,
type_captures => nqp::list_s('$?CLASS', '::?CLASS')
));

my $type-env-var;
if nqp::elems(my @ins-list := $*GENERICS-PAD.ann('instantiation-lexicals')) {
$world.add_object_if_no_sc(@ins-list);
$type-env-var := QAST::Node.unique('__typeenv_');
$block[1].unshift(
QAST::Op.new( :op<bind>,
QAST::Var.new( :name($type-env-var), :scope<local>, :decl<var> ),
QAST::Op.new( :op<callmethod>, :name<resolve_instantiations>,
QAST::Op.new( :op<how>,
QAST::Var.new( :name<::?ROLE>, :scope<lexical> ) ),
QAST::Var.new( :name<::?ROLE>, :scope<lexical> ),
QAST::Op.new( :op<curlexpad> ),
QAST::WVal.new( :value(@ins-list) )
)));
}

my $sig := $world.create_signature_and_params($<signature>, %sig_info, $block, 'Mu');
add_signature_binding_code($block, $sig, @params);
$block.blocktype('declaration_static');

# Role bodies run at BEGIN time, so need fixup.
begin_time_lexical_fixup($block);

# As its last act, it should grab the current lexpad so that
# we have the type environment, and also return the parametric
# role we're in (because if we land it through a multi-dispatch,
# we won't know).
# As its last act, it should return our type environment context, and also return the parametric role we're
# in (because if we land it through a multi-dispatch, we won't know).
# The type environment context would eithe be what Perl6::Metamodel::ParametericRoleHOW
# 'resolve_instantiations' method returned or lexpad of role's body closure.
$block[1].push(QAST::Op.new(
:op('list'),
QAST::WVal.new( :value($package) ),
QAST::Op.new( :op('curlexpad') )));
$type-env-var
?? QAST::Var.new( :name($type-env-var), :scope<local> )
!! QAST::Op.new( :op('curlexpad') )));

# Finish code object and add it as the role's body block.
my $code := $*CODE_OBJECT;
Expand Down Expand Up @@ -3476,13 +3482,7 @@ class Perl6::Actions is HLL::Actions does STDActions {

my $archetypes := $package.HOW.archetypes($package);
if $archetypes.generic && $archetypes.nominal && !$archetypes.parametric {
if nqp::isconcrete(my $generics := $*GENERICS) {
nqp::bindkey($generics, ins_lexical($package), $package);
}
else {
# This warning should be suppressible
$/.worry("Generic class '" ~ $package.HOW.name($package) ~ "' declared outside of generic scope");
}
$world.install_instantiation_lexical($package);
}

make $pkg-ast;
Expand Down Expand Up @@ -3984,22 +3984,15 @@ class Perl6::Actions is HLL::Actions does STDActions {
package => $world.find_single_symbol('$?CLASS'));
if %cont_info<build_ast> {
my $build-ast := %cont_info<build_ast>;
my $build-thunk;
my $bblock := $world.context.create_block($/);
$bblock.blocktype('declaration_static');
$bblock.annotate('outer', $world.cur_lexpad());
my $build-thunk := $*W.create_thunk($/, $build-ast, $bblock, :mark-wanted);
if $build-ast.ann('is-generic') {
# If the initializer is a generic type it would need to be resolved into its final value. To do
# so the codeobject must keep the closure to have access to role's arguments.
my $bblock := $world.push_lexpad($/);
$bblock.blocktype('declaration_static');
$bblock[0].push(QAST::Stmt.new($build-ast));
$world.pop_lexpad();
$build-thunk := $world.create_code_obj_and_add_child($bblock, 'Code');
$world.cur_lexpad()[0].push(
block_closure(
reference_to_code_object($build-thunk, $bblock)));
}
else {
$build-thunk := $*W.create_thunk($/, $build-ast, :mark-wanted);
}
%config<container_initializer> := $build-thunk;
}
my $attr := $world.pkg_add_attribute($/, $package, $metaattr,
Expand Down Expand Up @@ -6697,36 +6690,71 @@ class Perl6::Actions is HLL::Actions does STDActions {
$past := QAST::Op.new( :op('who'), $past );
}

if $<colonpairs> && $<colonpairs>.ast<D> {
unless nqp::istype($past, QAST::WVal) {
$/.panic("Type too complex to form a definite type");
my sub find-generic-lexical($ins_lexical) {
unless nqp::isconcrete(my $generics-pad := $*GENERICS-PAD) {
$/.panic("Type is marked generic but can't be resolved without a generic context");
}
my $type := $world.create_definite_type($world.resolve_mo($/, 'definite'), $past.value, 1); # XXX add constants
$past := QAST::WVal.new( :value($type) );
if nqp::isnull(my $generic-type := try { $*W.find_single_symbol($ins_lexical) }) {
$/.panic("Type is marked generic but no resolution found for it")
}
$generic-type
}
elsif $<colonpairs> && $<colonpairs>.ast<U> {
unless nqp::istype($past, QAST::WVal) {
$/.panic("Type too complex to form a definite type");

my sub generic-definite-type($generic-type, $lexical_name, $definite) {
my $generics-pad := $*GENERICS-PAD;
my $definite-type :=
$world.create_definite_type($world.resolve_mo($/, 'definite'), $generic-type, $definite);
my $definite-lexical := $world.install_instantiation_lexical($definite-type);
my $past := QAST::Var.new( :name($definite-lexical), :scope<lexical> );
$past.annotate_self('generic-lexical', 1);
}

if (my $colonpairs := $<colonpairs>) && ($colonpairs.ast<D> || $colonpairs.ast<U>) {
my $definite := nqp::istrue($colonpairs.ast<D>);
my $kind := $definite ?? 'definite' !! 'undefined';
if nqp::istype($past, QAST::WVal) {
my $type := $world.create_definite_type($world.resolve_mo($/, 'definite'), $past.value, $definite);
$past := QAST::WVal.new( :value($type) );
}
else {
if $past.ann('generic-lexical') {
$past := generic-definite-type(find-generic-lexical($past.name), $past.name, $definite);
}
elsif $past.ann('pure-generic-lexical') {
# Pure generics are lexicals on their own.
my $generic-type := $past.compile_time_value();
$past := generic-definite-type($generic-type, $generic-type.HOW.name($generic-type), $definite);
}
else {
$/.panic("Type too complex to form a definite type");
}
}
my $type := $world.create_definite_type($world.resolve_mo($/, 'definite'), $past.value, 0);
$past := QAST::WVal.new( :value($type) );
}

# If needed, try to form a coercion type.
unless nqp::isnull(my $accept := $world.can_has_coercerz: $/) {
my $value;
if nqp::istype($past, QAST::WVal) {
$value := $past.value;
}
elsif $past.has_compile_time_value {
$value := $past.compile_time_value;
if $past.ann('generic-lexical') || $past.ann('pure-generic-lexical') {
# $past is expected to be a QAST::Var
my $coerce-type := $world.create_coercion_type($/, find-generic-lexical($past.name), $accept);
my $coerce-lexical := $world.install_instantiation_lexical($coerce-type);
$past := QAST::Var.new( :name($coerce-lexical), :scope<lexical> );
$past.annotate('generic-lexical', 1);
}
else {
$/.panic("Target type too complex to form a coercion type");
}
my $value;
if nqp::istype($past, QAST::WVal) {
$value := $past.value;
}
elsif $past.has_compile_time_value {
$value := $past.compile_time_value;
}
else {
$/.panic("Target type too complex to form a coercion type");
}

my $type := $world.create_coercion_type($/, $value, $accept);
$past := QAST::WVal.new( :value($type) );
my $type := $world.create_coercion_type($/, $value, $accept);
$past := QAST::WVal.new( :value($type) );
}
}
}

Expand Down Expand Up @@ -10923,10 +10951,6 @@ Did you mean a call like '"
)
}

sub ins_lexical($type) {
'!INS_OF_' ~ $type.HOW.name($type)
}

# Works out how to look up a type. If it's not generic and is in an SC, we
# statically resolve it. Otherwise, we punt to a runtime lexical lookup.
sub instantiated_type(@name, $/) {
Expand All @@ -10943,18 +10967,14 @@ Did you mean a call like '"
my $is_generic := $archetypes && $archetypes.generic;
my $past;
if nqp::isconcrete($archetypes) && $is_generic && $archetypes.nominal && !$archetypes.parametric {
my $ins_lexical := ins_lexical($type);
my $ins_lexical := $world.install_instantiation_lexical($type);
$past := QAST::Var.new( :name($ins_lexical), :scope<lexical> );
if nqp::isconcrete($*GENERICS) {
nqp::bindkey($*GENERICS, $ins_lexical, $type);
}
else {
$/.worry("Generic class '" ~ $type.HOW.name($type) ~ "' is referenced outside of a role");
}
$past.annotate('generic-lexical', 1);
}
elsif $is_generic || nqp::isnull(nqp::getobjsc($type)) || istype($type.HOW,$/.how('package')) {
$past := $world.symbol_lookup(@name, $/);
$past.set_compile_time_value($type);
$past.annotate('pure-generic-lexical',1);
}
else {
$past := QAST::WVal.new( :value($type) );
Expand Down
15 changes: 11 additions & 4 deletions src/Perl6/Grammar.nqp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -800,7 +800,7 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
:my $*CAN_LOWER_TOPIC := 1; # true if we optimize the $_ lexical away
:my $*MAY_USE_RETURN := 0; # true if the current routine may use return
:my $*WANT_RAKUAST := 0; # if `use experimental :rakuast` is in effect
:my $*GENERICS; # would be set by roles and by routines with type captures
:my $*GENERICS-PAD; # would be set by roles and by routines with type captures
# Various interesting scopes we'd like to keep to hand.
:my $*GLOBALish;
Expand Down Expand Up @@ -1948,7 +1948,9 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
:my $*DOC := $*DECLARATOR_DOCS;
:my $*POD_BLOCK;
:my $*BORG := {};
:my $*GENERICS := nqp::getlexreldyn(nqp::ctxcaller(nqp::ctx()), '$*GENERICS'); # shadow away any outer
# Propagade $*GENERICS-PAD from the caller scope to preserve the context. At the same time if this package
# is a role then $*GENERICS-PAD will be overriden to create a new context.
:my $*GENERICS-PAD := nqp::getlexreldyn(nqp::ctxcaller(nqp::ctx()), '$*GENERICS-PAD');
{ $*DECLARATOR_DOCS := '' }
<.attach_leading_docs>
Expand Down Expand Up @@ -1983,6 +1985,8 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
?? $*GLOBALish
!! $*OUTERPACKAGE;
my $curpad := $*W.cur_lexpad();
# Unless we're augmenting...
if $*SCOPE ne 'augment' {
if $longname {
Expand Down Expand Up @@ -2023,6 +2027,11 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
$fullname := $longname.fully_qualified_with($target_package);
}
# Setup generic context.
if $*PKGDECL eq 'role' {
($*GENERICS-PAD := $curpad).annotate('instantiation-lexicals', []);
}
# If it exists already, then it's either uncomposed (in which
# case we just stubbed it), a role (in which case multiple
# variants are OK) or else an illegal redecl.
Expand Down Expand Up @@ -2065,7 +2074,6 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
# then install it in that.
else {
# If the group doesn't exist, create it.
$*GENERICS := nqp::hash();
my $group;
if $exists {
$group := $package;
Expand Down Expand Up @@ -2124,7 +2132,6 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
}
# Install $?PACKAGE, $?MODULE, $?ROLE, $?CLASS, and :: variants as needed.
my $curpad := $*W.cur_lexpad();
unless $curpad.symbol('$?PACKAGE') {
$*W.install_lexical_symbol($curpad, '$?PACKAGE', $package);
$*W.install_lexical_symbol($curpad, '::?PACKAGE', $package);
Expand Down
42 changes: 24 additions & 18 deletions src/Perl6/Metamodel/ClassHOW.nqp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -378,8 +378,9 @@ class Perl6::Metamodel::ClassHOW
}

method instantiate_generic($obj, $type_environment) {
return $obj if nqp::isnull(my $type-env-type := Perl6::Metamodel::Configuration.type_env_from($type_environment));
$type-env-type.cache($obj, { $obj.INSTANTIATE-GENERIC($type-env-type) });
my $type-env := Perl6::Metamodel::Configuration.type_env_from($type_environment);
return $obj if nqp::isnull($type-env);
$type-env.cache($obj, { $obj.INSTANTIATE-GENERIC($type-env) });
}

#?if moar
Expand Down Expand Up @@ -416,7 +417,12 @@ class Perl6::Metamodel::ClassHOW
if nqp::isconcrete($obj) && $can-is-generic {
# If invocant of .HOW.archetypes is a concrete object implementing 'is-generic' method then method outcome
# is the ultimate result. But we won't cache it in type's HOW $!archetypes.
$atype := $obj.is-generic ?? $archetypes-g !! $archetypes-ng;
nqp::dispatch('boot-syscall', 'dispatcher-delegate', 'boot-code-constant',
nqp::dispatch('boot-syscall', 'dispatcher-insert-arg-literal-obj',
nqp::dispatch('boot-syscall', 'dispatcher-drop-arg',
nqp::dispatch('boot-syscall', 'dispatcher-drop-arg', $capture, 1),
0),
0, { $obj.is-generic ?? $archetypes-g !! $archetypes-ng }));
}
else {
my $track-archetypes-attr :=
Expand All @@ -425,23 +431,23 @@ class Perl6::Metamodel::ClassHOW
nqp::dispatch('boot-syscall', 'dispatcher-guard-literal', $track-archetypes-attr);

$atype := nqp::getattr($how, Perl6::Metamodel::ClassHOW, '$!archetypes');
}

unless nqp::isconcrete($atype) {
# * If we still don't have an archetypes object then it means HOW doesn't know its archetypes yet. Therefore
# whatever we determine here is type's ultimate archetypes.
# * Also, since we've taken care of a concrete object case then here 'is-generic' is invoked on the type
# itself, not an instance of it.
$atype := $can-is-generic && $obj.is-generic ?? $archetypes-g !! $archetypes-ng;
nqp::scwbdisable();
nqp::getattr($how, Perl6::Metamodel::ClassHOW, '$!archt-lock').protect({
nqp::bindattr($how, Perl6::Metamodel::ClassHOW, '$!archetypes', $atype);
});
nqp::scwbenable();
}
unless nqp::isconcrete($atype) {
# * If we still don't have an archetypes object then it means HOW doesn't know its archetypes yet. Therefore
# whatever we determine here is type's ultimate archetypes.
# * Also, since we've taken care of a concrete object case then here 'is-generic' is invoked on the type
# itself, not an instance of it.
$atype := $can-is-generic && $obj.is-generic ?? $archetypes-g !! $archetypes-ng;
nqp::scwbdisable();
nqp::getattr($how, Perl6::Metamodel::ClassHOW, '$!archt-lock').protect({
nqp::bindattr($how, Perl6::Metamodel::ClassHOW, '$!archetypes', $atype);
});
nqp::scwbenable();
}

nqp::dispatch('boot-syscall', 'dispatcher-delegate', 'boot-constant',
nqp::dispatch('boot-syscall', 'dispatcher-insert-arg-literal-obj', $capture, 0, $atype));
nqp::dispatch('boot-syscall', 'dispatcher-delegate', 'boot-constant',
nqp::dispatch('boot-syscall', 'dispatcher-insert-arg-literal-obj', $capture, 0, $atype));
}
});
#?endif
}
Expand Down
Loading

0 comments on commit 69d6168

Please sign in to comment.