## unrebind.pkg
# Compiled by:
# src/lib/compiler/core.sublib############################################################################
#
# "Alpha conversion": the closure converter introduces duplicate namings
# at function arguments (the free variables of known functions) and at
# SELECT's and OFFSET's from closures. This function restores unique
# namings, and also eliminates OFFSET's of 0 (which are introduced as
# a side effect of trying to improve lazy display). It assumes that a
# FIX has no free variables.
#
############################################################################
### "Never try and teach a pig to sing:
### it's a waste of time,
### and it annoys the pig."
###
### -- Robert A. Heinlein
### Time Enough for Love
stipulate
package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkgherein
api Un_Rebind {
#
unrebind: ncf::Function -> ncf::Function;
};
end;
stipulate
package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkgherein
package un_rebind
: (weak) Un_Rebind # Un_Rebind is from src/lib/compiler/back/top/closures/unrebind.pkg {
fun bug s
=
error_message::impossible ("UnRebind: " + s);
fun unrebind (fk, v, args, cl, ce)
=
{ fun rename rebind (ncf::CODETEMP v)
=>
f rebind
where
fun f NIL
=>
ncf::CODETEMP v;
f ((w: Int, v') ! t)
=>
v == w ?? v'
:: f t;
end;
end;
rename _ x
=>
x;
end;
fun f (kind, l, args, cl, b)
=
{ my (args', rebind')
=
fold_backward
( \\ (v, (args', rebind'))
=
{ v' = tmp::clone_highcode_codetemp v;
( v' ! args',
(v, ncf::CODETEMP v') ! rebind'
);
}
)
(NIL, NIL)
args;
( kind,
l,
args',
cl,
g rebind' b
);
}
also
fun g (rebind: List( (ncf::Codetemp, ncf::Value) ) )
=
h
where
rename = rename rebind;
recursive my h
=
\\ ncf::DEFINE_RECORD { kind, fields, to_temp, next }
=>
{ to_temp' = tmp::clone_highcode_codetemp to_temp;
ncf::DEFINE_RECORD
{
kind,
fields => map (\\ (v, p) = (rename v, p)) fields,
to_temp => to_temp',
next => g ((to_temp, ncf::CODETEMP to_temp') ! rebind) next
};
};
ncf::GET_ADDRESS_OF_FIELD_I { i => 0, record, to_temp, next } => g ((to_temp, rename record) ! rebind) next;
ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next } => bug "unexpected non-zero FIELD_POINTER";
# let w' = tmp::clone_highcode_codetemp w
# in ncf::GET_ADDRESS_OF_FIELD_I (i, rename v, w', g ((w, ncf::CODETEMP w') ! rebind) e)
# end
ncf::GET_FIELD_I { i, record, to_temp, type, next }
=>
{ to_temp' = tmp::clone_highcode_codetemp to_temp;
ncf::GET_FIELD_I
{
i,
record => rename record,
to_temp => to_temp',
type,
next => g ((to_temp, ncf::CODETEMP to_temp') ! rebind) next
};
};
ncf::TAIL_CALL { fn, args } => ncf::TAIL_CALL { fn => rename fn, args => map rename args };
ncf::DEFINE_FUNS { funs, next } => ncf::DEFINE_FUNS { funs => map f funs, next => h next };
ncf::JUMPTABLE { i, xvar, nexts } => ncf::JUMPTABLE { i => rename i, xvar, nexts => map h nexts };
ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
=> ncf::IF_THEN_ELSE { op, args => map rename args, xvar, then_next => h then_next, else_next => h else_next };
ncf::STORE_TO_RAM { op, args, next } => ncf::STORE_TO_RAM { op, args => map rename args, next => h next };
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next } => ncf::FETCH_FROM_RAM { op, args => map rename args, to_temp, type, next => h next };
ncf::ARITH { op, args, to_temp, type, next } => ncf::ARITH { op, args => map rename args, to_temp, type, next => h next };
ncf::PURE { op, args, to_temp, type, next } => ncf::PURE { op, args => map rename args, to_temp, type, next => h next };
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
=>
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args => map rename args, to_ttemps, next => h next };
end;
end; # fun g
(fk, v, args, cl, g NIL ce);
}; # fun unrebind
}; # package un_rebind
end; # stipulate