## clean-nextcode-g.pkg
# Compiled by:
# src/lib/compiler/core.sublib# This file implements one of the nextcode transforms.
# For context, see the comments in
#
# src/lib/compiler/back/top/highcode/highcode-form.api# 'clean-nextcode' is called after almost every other
# optimization pass, to tidy up. It implements
# a variety of clean-up stuff including dead code
# elimination, constant propagation, constant folding,
# and inlining of functions only called from a single spot.
#
# For background on the latter optimization, see:
#
# Shrinking Lambda Expressions in Linear Time
# Andrew W Appel, Trevor Jim
# 1993, 26p, J. Functional Programming
# http://akpublic.research.att.com/~trevor/papers/shrinking.ps.gz
# Transformations performed by the contracter:
#
# TRANSFORMATION: Click: compiler::control::CG flag:
# ------------------------------------------------------------------------
# Inlining functions that are used once e beta_contract
# Cascaded inlining of functions q
# The IF-idiom E if_idiom
# Unify BRANCHs z branchfold
# Constant folding:
# SELECTs from known RECORDs d
# Handler operations ijk handlerfold
# SWITCH expressions h switchopt
# MATH expressions FGHIJKLMNOPQX arithopt
# PURE expressions RSTUVWYZ0123456789 arithopt
# BRANCH expressions nopvw comparefold
#
# Dead variable elimination: [down, up] [down, up]
# RECORDs [b, B] [deadvars, deadup]
# SELECTs [c, s] [deadvars, deadup]
# Functions [g, f]
# LOOKERs [m,*] [deadvars, deadup]
# PUREs [m,*] [deadvars, deadup]
# Arguments [D, ] [dropargs, ]
#
# Conversion Primops:
# testu U (n)
# test T (n)
# copy C (n)
# extend X (n)
# trunc R (n)
### "Bringing computers into the
### home won't change either one,
### but may revitalize the corner
### saloon."
###
### -- Alan Perlis
#DO set_control "compiler::trap_int_overflow" "TRUE";
stipulate
package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package hct = highcode_type; # highcode_type is from src/lib/compiler/back/top/highcode/highcode-type.pkg package hut = highcode_uniq_types; # highcode_uniq_types is from src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.pkgherein
api Clean_Nextcode {
#
clean_nextcode
:
{ function: ncf::Function,
table: iht::Hashtable( hut::Uniqtypoid ),
click: String -> Void,
last: Bool,
size: Ref(Int)
}
->
ncf::Function;
};
end;
# Machine_Properties is from src/lib/compiler/back/low/main/main/machine-properties.apistipulate
package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package hcf = highcode_form; # highcode_form is from src/lib/compiler/back/top/highcode/highcode-form.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkg package iht = int_hashtable; # int_hashtable is from src/lib/src/int-hashtable.pkg #
package coc = global_controls::compiler; # global_controls is from src/lib/compiler/toplevel/main/global-controls.pkgherein
# We are invoked from:
#
# src/lib/compiler/back/top/improve-nextcode/run-optional-nextcode-improvers-g.pkg #
generic package clean_nextcode_g (
# ================
#
machine_properties: Machine_Properties # Typically src/lib/compiler/back/low/main/intel32/machine-properties-intel32.pkg )
: (weak) Clean_Nextcode # Clean_Nextcode is from src/lib/compiler/back/top/improve-nextcode/clean-nextcode-g.pkg {
fun inc (ri as REF i) = (ri := i + 1);
fun dec (ri as REF i) = (ri := i - 1);
wtoi = unt::to_int_x;
itow = unt::from_int;
say = global_controls::print::say;
fun bug string
=
error_message::impossible ("Contract: " + string);
exception CONSTANT_FOLD;
fun sublist prior (hd ! tl) => if (prior hd) hd ! (sublist prior tl);
else sublist prior tl;
fi;
#
sublist prior NIL => NIL;
end;
fun map1 f (a, b)
=
(f a, b);
fun app2 (f, NIL, NIL) => ();
app2 (f, a ! al, b ! bl) => { f (a, b); app2 (f, al, bl); };
app2 (f, _, _) => bug "NContract app2 783";
end;
fun share_name (x, ncf::CODETEMP y) => tmp::share_name (x, y);
share_name (x, ncf::LABEL y) => tmp::share_name (x, y);
share_name _ => ();
end;
fun complain (t1, t2, s)
=
{ say (s + " ____ Type conflicting while contractions =====> \n ");
say (hcf::uniqtypoid_to_string t1); say "\n and \n "; say (hcf::uniqtypoid_to_string t2);
say "\n \n";
say "_____________________________________________________ \n";
};
fun checklty s (t1, t2)
=
();
# let fun g (hcf::INT, hcf::INT) = ()
# | g (hcf::INT1, hcf::INT1) = ()
# | g (hcf::BOOL, hcf::BOOL) = ()
# | g (hcf::INT, hcf::BOOL) = ()
# | g (hcf::BOOL, hcf::INT) = ()
# | g (hcf::FLOAT64,hcf::FLOAT64) = ()
# | g (hcf::SRCONT, hcf::SRCONT) = ()
# | g (hcf::BOXED, hcf::BOXED) = ()
# | g (hcf::RBOXED, hcf::RBOXED) = ()
# | g (hcf::INT, hcf::RECORD NIL) = ()
# | g (hcf::RECORD NIL, hcf::INT) = ()
# | g (hcf::BOXED, hcf::RBOXED) = () # this is temporary
# | g (hcf::RBOXED, hcf::BOXED) = () # this is temporary
# | g (hcf::ARROW (t1, t2), hcf::ARROW (t1', t2')) =
# (g (hcf::out t1, hcf::out t1'); g (hcf::out t2, hcf::out t2'))
# | g (hcf::RECORD l1, hcf::RECORD l2) =
# app2 (g, map hcf::out l1, map hcf::out l2)
# | g (hcf::CONT t1, hcf::CONT t2) = g (hcf::out t1, hcf::out t2)
# | g (t1, t2) = complain (hcf::inj t1, hcf::inj t2, "CTR *** " + s)
# in g (hcf::out t1, hcf::out t2)
# end
is_cont
=
hcf::lt_is_fate;
fun equal_upto_alpha (ce1, ce2)
=
equ NIL (ce1, ce2)
where
fun equ pairs
=
sameexp
where
fun same (ncf::CODETEMP a, ncf::CODETEMP b)
=>
{ fun get ((x, y) ! rest)
=>
a == x and b == y or get rest;
get NIL
=>
FALSE;
end;
a == b or get pairs;
};
same (ncf::LABEL a, ncf::LABEL b) => same (ncf::CODETEMP a, ncf::CODETEMP b);
same (ncf::INT i, ncf::INT j) => i == j;
same (ncf::FLOAT64 a, ncf::FLOAT64 b) => a == b;
same (ncf::STRING a, ncf::STRING b) => a == b;
same (a, b) => FALSE;
end;
fun samefields ((a, ap) ! ar, (b, bp) ! br)
=>
ap==bp and same (a, b) and samefields (ar, br);
samefields (NIL, NIL) => TRUE;
samefields _ => FALSE;
end;
fun samewith p
=
equ (p ! pairs);
fun samewith' args
=
equ (paired_lists::fold_backward (\\ ((w, _), (w', _), l) = (w, w') ! l)
pairs args);
fun all2 f (e ! r, e' ! r') => f (e, e') and all2 f (r, r');
all2 f (NIL, NIL) => TRUE;
all2 f _ => FALSE;
end;
recursive my sameexp
=
\\ ( ncf::GET_FIELD_I { i => i, record => v, to_temp => w, next => e, ... },
ncf::GET_FIELD_I { i => i', record => v', to_temp => w', next => e', ... }
)
=>
i==i' and same (v, v') and samewith (w, w') (e, e');
( ncf::DEFINE_RECORD { kind => k, fields => vl, to_temp => w, next => e },
ncf::DEFINE_RECORD { kind => k', fields => vl', to_temp => w', next => e' }
)
=>
(k == k') and samefields (vl, vl')
and samewith (w, w') (e, e');
( ncf::GET_ADDRESS_OF_FIELD_I { i => i, record => v, to_temp => w, next => e },
ncf::GET_ADDRESS_OF_FIELD_I { i => i', record => v', to_temp => w', next => e' }
)
=>
i==i' and same (v, v') and samewith (w, w') (e, e');
( ncf::JUMPTABLE { i => i, xvar => xvar, nexts => nexts },
ncf::JUMPTABLE { i => i', xvar => xvar', nexts => nexts' }
)
=>
same (i, i') and all2 (samewith (xvar, xvar')) (nexts, nexts');
( ncf::TAIL_CALL { fn => f, args => vl },
ncf::TAIL_CALL { fn => f', args => vl' }
)
=>
same (f, f') and all2 same (vl, vl');
( ncf::DEFINE_FUNS { funs => l, next => e },
ncf::DEFINE_FUNS { funs => l', next => e' }
)
=>
FALSE; # Punt!
( ncf::IF_THEN_ELSE { op => op, args => args, xvar => xvar, then_next => then_next, else_next => else_next },
ncf::IF_THEN_ELSE { op => op', args => args', xvar => xvar', then_next => then_next', else_next => else_next' }
)
=>
op==op' and all2 same (args, args')
and samewith (xvar, xvar') (then_next, then_next')
and samewith (xvar, xvar') (else_next, else_next');
( ncf::FETCH_FROM_RAM { op => op, args => args, to_temp => to_temp, next => next, ... },
ncf::FETCH_FROM_RAM { op => op', args => args', to_temp => to_temp', next => next', ... }
)
=>
op==op' and all2 same (args, args') and samewith (to_temp, to_temp')(next, next');
( ncf::STORE_TO_RAM { op => op, args => args, next => next },
ncf::STORE_TO_RAM { op => op', args => args', next => next' }
)
=>
op==op' and all2 same (args, args') and sameexp (next, next');
( ncf::ARITH { op => op, args => args, to_temp => to_temp, next => next, ... },
ncf::ARITH { op => op', args => args', to_temp => to_temp', next => next', ... }
)
=>
op==op' and all2 same (args, args') and samewith (to_temp, to_temp')(next, next');
( ncf::PURE { op => op, args => args, to_temp => to_temp, next => next, ... },
ncf::PURE { op => op', args => args', to_temp => to_temp', next => next', ... }
)
=>
op==op' and all2 same (args, args') and samewith (to_temp, to_temp')(next, next');
( ncf::RAW_C_CALL { kind => k, cfun_name => l, cfun_type => p, args => vl, to_ttemps => wtl, next => e },
ncf::RAW_C_CALL { kind => k', cfun_name => l', cfun_type => p', args => vl', to_ttemps => wtl', next => e' }
)
=>
# We don't need to compare cfun_type info: The cfun_types are
# the same iff the functions and arguments are the same:
#
k == k' and l == l' and
all2 same (vl, vl') and samewith'(wtl, wtl')(e, e');
_ => FALSE;
end;
end;
end;
Info = RECINFO List( (ncf::Value, ncf::Fieldpath) )
| SELINFO (Int, ncf::Value, ncf::Type)
| OFFINFO (Int, ncf::Value)
| WRPINFO (ncf::p::Pure, ncf::Value)
| IF_IDIOM_INFO { body: Ref( Null_Or( (ncf::Codetemp, ncf::Instruction, ncf::Instruction) ) ) }
| MISCINFO ncf::Type
| FNINFO { args: List( ncf::Codetemp ),
body: Ref( Null_Or( ncf::Instruction ) ),
special_use: Ref( Null_Or( Ref( Int ) ) ),
live_args: Ref( Null_Or( List( Bool ) ) )
};
fun clean_nextcode
{
function => (fkind, fvar, fargs, ctyl, cexp),
table,
click,
last, # NOTE: the "last" argument is currently ignored.
size => nextcode_size
}
=
(fkind, fvar, fargs, ctyl, cexp')
where
deadup = *global_controls::compiler::deadup;
cgbeta_contract = *global_controls::compiler::beta_contract;
debug = *global_controls::compiler::debugnextcode; # FALSE
fun debugprint s = if debug global_controls::print::say (s); fi;
fun debugflush () = if debug global_controls::print::flush(); fi;
rep_flag = machine_properties::representations;
type_flag = *coc::checknextcode1 and *coc::checknextcode2 and rep_flag;
# It would be nice to get rid
# of this type stuff one day.
#
stipulate
exception NCONTRACT;
fun value_name (ncf::CODETEMP v) => tmp::name_of_highcode_codetemp v;
value_name (ncf::INT i) => "Int" + int::to_string (i);
value_name (ncf::FLOAT64 r) => "Float" + r;
value_name (ncf::STRING s) => "<" + s + ">";
#
value_name _ => "<others>";
end;
fun arg_lty []
=>
hcf::int_uniqtypoid;
arg_lty [t]
=>
hcf::if_uniqtypoid_is_tuple_type (
t,
\\ xs as (_ ! _) => length (xs) < machine_properties::max_rep_regs
?? hcf::make_tuple_uniqtypoid [t]
:: t;
_ => t;
end,
\\ t = hcf::if_uniqtypoid_is_package (
t,
( \\ xs as (_ ! _)
=>
if (length xs < machine_properties::max_rep_regs)
hcf::make_tuple_uniqtypoid [t];
else
t;
fi;
_ => t;
end
),
\\ t = t
)
);
arg_lty r
=>
hcf::make_package_uniqtypoid r; # This is INCORRECT !!!!!!! XXX BUGGO FIXME
end;
addty
=
if type_flag
#
iht::set table;
else
\\ _ = ();
fi;
herein
# Only used when dropping args in
# reduce (MUTUALLY_RECURSIVE_FNS) case.
#
fun getty v
=
if type_flag
#
(iht::get table v)
except
_ = { global_controls::print::say ("NCONTRACT: Can't find the variable " +
(int::to_string v) + " in the table ***** \n");
raise exception NCONTRACT;
};
else
hcf::truevoid_uniqtypoid;
fi;
fun grabty u
=
{ fun g (ncf::CODETEMP v) => getty v;
g (ncf::LABEL v) => getty v;
g (ncf::INT _) => hcf::int_uniqtypoid;
g (ncf::FLOAT64 _) => hcf::float64_uniqtypoid;
g (ncf::STRING _) => hcf::truevoid_uniqtypoid;
g _ => hcf::truevoid_uniqtypoid;
end;
type_flag ?? g u
:: hcf::truevoid_uniqtypoid;
};
fun newty (f, t)
=
if type_flag
#
iht::drop table f;
addty (f, t);
fi;
fun make_var (t)
=
v
where
v = tmp::issue_highcode_codetemp();
addty (v, t);
end;
fun ltc_fun (x, y)
=
(hcf::uniqtypoid_is_type x and hcf::uniqtypoid_is_type y)
?? hcf::make_lambdacode_arrow_uniqtypoid (x, y)
:: hcf::make_lambdacode_generic_package_uniqtypoid (x, y);
fun make_fn_lty (_, _, NIL)
=>
bug "make_fn_lty in nflatten";
make_fn_lty (k, cntt ! _, x ! r)
=>
hcf::ltw_is_fate
(
x,
\\ [t2] => (k, ltc_fun (arg_lty r, t2));
_ => bug "unexpected make_fn_lty";
end,
\\ [t2] => (k, ltc_fun (arg_lty r, hcf::make_type_uniqtypoid t2));
_ => bug "unexpected make_fn_lty";
end,
\\ x = (k, ltc_fun (arg_lty r, x))
);
make_fn_lty (k, _, r)
=>
(k, hcf::make_uniqtypoid_fate([arg_lty r]));
end;
# Only used in newname:
#
fun same_lty (x, u)
=
{ s = (tmp::name_of_highcode_codetemp x) + (" *and* " + value_name u);
if type_flag
#
checklty s (getty x, grabty u);
fi;
};
end; # stipulate
stipulate
exception USAGE_MAP;
herein
my m: iht::Hashtable { info: Info, used: Ref( Int ), called: Ref( Int ) }
= iht::make_hashtable { size_hint => 128, not_found_exception => USAGE_MAP };
get = \\ i = iht::get m i
except
USAGE_MAP = bug ("USAGE_MAP on " + int::to_string i);
enter = iht::set m;
fun rmv i
=
iht::drop m i;
end;
fun use (ncf::CODETEMP v) => inc ((get v).used);
use (ncf::LABEL v) => inc ((get v).used);
use _ => ();
end;
fun use_less (ncf::CODETEMP v) => if deadup dec ((get v).used); fi;
use_less (ncf::LABEL v) => if deadup dec ((get v).used); fi;
use_less _ => ();
end;
fun used_once v
=
*(.used (get v)) == 1;
fun used v
=
*(.used (get v)) > 0;
fun call (ncf::CODETEMP v)
=>
{ (get v) -> { called, used, ... };
inc called;
inc used;
};
call (ncf::LABEL v) => call (ncf::CODETEMP v);
call _ => ();
end;
fun call_less (ncf::CODETEMP v)
=>
if deadup
#
(get v) -> { called, used, ... };
dec called;
dec used;
fi;
call_less (ncf::LABEL v) => call_less (ncf::CODETEMP v);
call_less _ => ();
end;
fun call_and_clobber (ncf::CODETEMP v)
=>
{ (get v) -> { called, used, info };
inc called;
inc used;
case info
#
FNINFO { body, ... } => body := NULL;
_ => ();
esac;
};
call_and_clobber (ncf::LABEL v) => call (ncf::CODETEMP v);
call_and_clobber _ => ();
end;
fun enter_rec (w, vl) = enter (w,{ info=>RECINFO vl, called=>REF 0, used=>REF 0 } );
fun enter_misc (w, ct) = enter (w,{ info=>MISCINFO ct, called=>REF 0, used=>REF 0 } );
misc_bog = MISCINFO ncf::bogus_pointer_type;
fun enter_misc0 w
=
enter (w,{ info=>misc_bog, called=>REF 0, used=>REF 0 } );
fun enter_wrp (w, p, u)
=
enter (w,{ info=>WRPINFO (p, u), called=>REF 0, used=>REF 0 } );
fun enter_fn (_, f, vl, cl, cexp)
=
{ enter
(
f,
{ called => REF 0,
used => REF 0,
info => FNINFO { args => vl,
body => REF (cgbeta_contract ?? THE cexp :: NULL),
special_use => REF NULL,
live_args => REF NULL
}
}
);
app2 (enter_misc, vl, cl);
};
# *********************************************************************
# checkFunction: used by pass1 (MUTUALLY_RECURSIVE_FNS ...) to decide
# (1) whether a function will be inlined for the if idiom;
# (2) whether a function will drop some arguments.
# ********************************************************************
fun check_function (_, f, vl, _, _)
=
case (get f)
#
{ called=>REF 2, used=>REF 2,
info=>FNINFO { special_use=>REF (THE (REF 1)),
body as REF (THE (ncf::IF_THEN_ELSE { xvar, then_next, else_next, ... })),
...
},
...
}
=>
if (not *coc::if_idiom)
#
body := NULL;
else
# NOTE: remapping f
#
enter
( f,
{ info => IF_IDIOM_INFO { body => REF (THE (xvar, then_next, else_next)) },
called => REF 2,
used => REF 2
}
);
fi;
{ called=>REF c, used=>REF u, info=>FNINFO { live_args, ... }}
=>
if ( u == c # escaping function
and *coc::dropargs
)
live_args := THE (map used vl);
fi;
_ => ();
esac;
# ************************************************************************
# pass1: Gather usage information on the variables in a nextcode expression,
# and make a few decisions about whether to inline functions:
# (1) If Idiom
# (2) NO_INLINE_INTO
# ************************************************************************
recursive my pass1
=
\\ cexp = p1 FALSE cexp
also
p1 =
\\ no_inline
=
g1
where
recursive my g1
=
\\ ncf::DEFINE_RECORD { fields, to_temp, next, ... }
=>
{ enter_rec (to_temp, fields);
apply (use o #1) fields;
g1 next;
};
ncf::GET_FIELD_I { i, record, to_temp, type, next }
=>
{ enter (to_temp, { info=>SELINFO (i, record, type), called=>REF 0, used=>REF 0 } );
use record;
g1 next;
};
ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next }
=>
{ enter (to_temp, { info=>OFFINFO (i, record), called=>REF 0, used=>REF 0 } );
use record;
g1 next;
};
ncf::TAIL_CALL { fn, args }
=>
{ if no_inline call_and_clobber fn;
else call fn;
fi;
apply use args;
};
ncf::DEFINE_FUNS { funs, next }
=>
{ apply enter_fn funs;
apply
\\ (ncf::NO_INLINE_INTO, _, _, _, body) => p1 (not last) body;
(_, _, _, _, body) => g1 body;
end
funs;
g1 next;
apply check_function funs;
};
ncf::JUMPTABLE { i, xvar, nexts }
=>
{ use i;
enter_misc0 xvar;
apply g1 nexts;
};
ncf::IF_THEN_ELSE { op => _,
args,
xvar,
then_next as ncf::TAIL_CALL { fn => ncf::CODETEMP f1, args => [ncf::INT 1] },
else_next as ncf::TAIL_CALL { fn => ncf::CODETEMP f2, args => [ncf::INT 0] }
}
=>
{ case (get f1)
#
{ info => FNINFO { special_use,
args => [w1],
body => REF (THE (ncf::IF_THEN_ELSE { op => ncf::p::COMPARE { op=>ncf::p::NEQ, ... },
args => [ ncf::INT 0,
ncf::CODETEMP w2
],
...
}
) ),
...
},
...
}
=>
# Handle IF IDIOM
if (f1==f2 and w1==w2)
my { used, ... } = get w1;
special_use := THE used;
fi;
_ => ();
esac;
apply use args;
enter_misc (xvar, ncf::bogus_pointer_type);
g1 then_next;
g1 else_next;
};
ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
=>
{ apply use args;
enter_misc0 xvar;
g1 then_next;
g1 else_next;
};
ncf::STORE_TO_RAM { args, next, ... } => { apply use args; g1 next; };
ncf::FETCH_FROM_RAM { args, to_temp, next, ... } => { apply use args; enter_misc0 to_temp; g1 next; };
ncf::ARITH { args, to_temp, next, ... } => { apply use args; enter_misc0 to_temp; g1 next; };
ncf::PURE { op as ncf::p::IWRAP, args =>[u], to_temp, next, ... } => { use u; enter_wrp (to_temp, op, u); g1 next; };
ncf::PURE { op as ncf::p::IUNWRAP, args =>[u], to_temp, next, ... } => { use u; enter_wrp (to_temp, op, u); g1 next; };
ncf::PURE { op as ncf::p::WRAP_INT1, args =>[u], to_temp, next, ... } => { use u; enter_wrp (to_temp, op, u); g1 next; };
ncf::PURE { op as ncf::p::UNWRAP_INT1, args =>[u], to_temp, next, ... } => { use u; enter_wrp (to_temp, op, u); g1 next; };
ncf::PURE { op as ncf::p::WRAP_FLOAT64, args =>[u], to_temp, next, ... } => { use u; enter_wrp (to_temp, op, u); g1 next; };
ncf::PURE { op as ncf::p::UNWRAP_FLOAT64, args =>[u], to_temp, next, ... } => { use u; enter_wrp (to_temp, op, u); g1 next; };
ncf::PURE { args, to_temp, next, ... }
=>
{ apply use args;
enter_misc0 to_temp;
g1 next;
};
ncf::RAW_C_CALL { args, to_ttemps, next, ... }
=>
{ apply use args;
apply (enter_misc0 o #1) to_ttemps;
g1 next;
};
end; # fn
end; # p1
stipulate
exception BETA;
my m2: iht::Hashtable( ncf::Value )
= iht::make_hashtable { size_hint => 32, not_found_exception => BETA };
mapm2 = iht::get m2;
herein
fun ren (v0 as ncf::CODETEMP v) => (ren (mapm2 v) except BETA = v0);
ren (v0 as ncf::LABEL v) => (ren (mapm2 v) except BETA = v0);
ren x => x;
end;
fun newname (vw as (v, w))
=
{ (get v) -> { used => REF u,
called => REF c,
...
};
fun f (ncf::CODETEMP w')
=>
{ (get w') -> { used, called, ... };
#
used := *used + u;
called := *called + c;
};
f (ncf::LABEL w') => f (ncf::CODETEMP w');
f _ => ();
end;
if deadup f (ren w); fi;
rmv v;
same_lty vw;
share_name vw;
iht::set m2 vw;
};
end;
fun newnames (v ! vl, w ! wl) => { newname (v, w); newnames (vl, wl); };
newnames _ => ();
end;
#####################################################################
# Drop_body: used when dropping a function to adjust the
# usage counts of the free variables of the function.
# This should match up closely with pass1 above.
#####################################################################
stipulate
use_less = use_less o ren;
call_less = call_less o ren;
herein
fun drop_body (ncf::TAIL_CALL { fn, args }) => { call_less fn; apply use_less args; };
#
drop_body (ncf::GET_FIELD_I { record, next, ... }) => { use_less record; drop_body next; };
drop_body (ncf::GET_ADDRESS_OF_FIELD_I { record, next, ... }) => { use_less record; drop_body next; };
#
drop_body (ncf::JUMPTABLE { i, nexts, ... }) => { use_less i; apply drop_body nexts; };
#
drop_body (ncf::DEFINE_FUNS { funs, next }) => { apply (drop_body o #5) funs; drop_body next; };
drop_body (ncf::DEFINE_RECORD { fields, next, ... }) => { apply (use_less o #1) fields; drop_body next; };
drop_body (ncf::IF_THEN_ELSE { args, then_next, else_next, ... }) => { apply use_less args; drop_body then_next; drop_body else_next; };
#
drop_body (ncf::STORE_TO_RAM { args, next, ... }) => { apply use_less args; drop_body next;};
drop_body (ncf::FETCH_FROM_RAM { args, next, ... }) => { apply use_less args; drop_body next;};
#
drop_body (ncf::ARITH { args, next, ... }) => { apply use_less args; drop_body next; };
drop_body (ncf::PURE { args, next, ... }) => { apply use_less args; drop_body next; };
drop_body (ncf::RAW_C_CALL { args, next, ... }) => { apply use_less args; drop_body next; };
end;
end;
fun setter (ncf::p::RW_VECTOR_SET, [_, _, ncf::INT _]) => ncf::p::SET_VECSLOT_TO_TAGGED_INT_VALUE;
setter (ncf::p::RW_VECTOR_SET, [_, _, ncf::FLOAT64 _]) => ncf::p::SET_VECSLOT_TO_BOXED_VALUE;
setter (ncf::p::RW_VECTOR_SET, [_, _, ncf::STRING _]) => ncf::p::SET_VECSLOT_TO_BOXED_VALUE;
setter (ncf::p::RW_VECTOR_SET, [_, _, ncf::CODETEMP v])
=>
case ((get v).info)
#
FNINFO _ => ncf::p::SET_VECSLOT_TO_BOXED_VALUE;
RECINFO _ => ncf::p::SET_VECSLOT_TO_BOXED_VALUE;
OFFINFO _ => ncf::p::SET_VECSLOT_TO_BOXED_VALUE;
_ => ncf::p::RW_VECTOR_SET;
esac;
setter (ncf::p::SET_REFCELL, [_, ncf::INT _]) => ncf::p::SET_REFCELL_TO_TAGGED_INT_VALUE;
setter (i, _) => i;
end;
fun same_lvar (highcode_variable, ncf::CODETEMP lv) => lv == highcode_variable;
same_lvar _ => FALSE;
end;
fun cvt_pre_condition (n: Int, n2, x, v2)
=
n == n2 and used_once (x) and same_lvar (x, ren v2);
fun cvt_pre_condition_inf (x, v2)
=
used_once (x) and same_lvar (x, ren v2);
recursive my reduce
=
\\ cexp = g NULL cexp
also
g =
\\ handler
=
g'
where
recursive my g'
=
\\ ncf::DEFINE_RECORD { kind => k, fields => vl, to_temp => w, next => e }
=>
{ (get w) -> { used, ... };
#
vl' = map (map1 ren) vl;
if (*used==0 and *coc::deadvars)
#
click "b";
apply (use_less o #1) vl';
g' e;
else
fun chunklen (ncf::CODETEMP z)
=>
case (.info (get z))
#
SELINFO(_, _, ncf::typ::POINTER (ncf::RPT k)) => k;
SELINFO(_, _, ncf::typ::POINTER (ncf::FPT k)) => k;
MISCINFO (ncf::typ::POINTER (ncf::RPT k)) => k;
MISCINFO (ncf::typ::POINTER (ncf::FPT k)) => k;
RECINFO l => length l;
_ => -1;
esac;
chunklen _ => -1;
end;
fun samevar (ncf::CODETEMP x, ncf::CODETEMP y) => x == y;
samevar _ => FALSE;
end;
fun check1 ((ncf::CODETEMP z) ! r, k, a)
=>
case (get z)
#
{ info=>SELINFO (i, b, _), ... }
=>
if (i==k and samevar (ren b, a)) check1 (r, k+1, a);
else NULL;
fi;
_ => NULL;
esac;
check1(_ ! r, k, _)
=>
NULL;
check1([], k, a)
=>
chunklen a == k
?? THE a
:: NULL;
end;
fun check ((ncf::CODETEMP z) ! r)
=>
case (get z)
#
{ info=>SELINFO (0, a, _), ... }
=>
check1 (r, 1, ren a);
_ => NULL;
esac;
check _ => NULL;
end;
vl'' = map #1 vl';
case (check (vl''))
#
NULL =>
{ e' = g' e;
if (*used==0 and deadup)
#
click "B";
apply use_less vl'';
e';
else
ncf::DEFINE_RECORD { kind => k, fields => vl', to_temp => w, next => e' };
fi;
};
THE z =>
{ newname (w, z);
click "B"; # ** ? ** XXX BUGGO FIXME
apply use_less vl'';
g' e;
};
esac;
fi;
};
ncf::GET_FIELD_I { i, record, to_temp, type, next }
=>
{ (get to_temp) -> { used, ... };
record' = ren record;
if (*used==0 and *coc::deadvars)
#
click "c"; # Could rmv to_temp here
use_less record';
g' next;
else
z = case record'
#
ncf::CODETEMP v''
=>
case (get v'')
{ info=>RECINFO vl, ... }
=>
( { z = #1 (list::nth (vl, i));
z' = ren z;
case z'
ncf::FLOAT64 _ => NULL;
_ => THE z';
esac;
}
except
INDEX_OUT_OF_BOUNDS = NULL
);
_ => NULL;
esac;
_ => NULL;
esac;
z = if *coc::selectopt z;
else NULL;
fi;
case z
#
NULL => { next' = g' next;
if (*used==0 and deadup)
#
click "s";
use_less record';
next';
else
ncf::GET_FIELD_I { i, record => record', to_temp, type, next => next' };
fi;
};
THE z' => { newname (to_temp, z');
click "d"; # Could rmv to_temp here
use_less record';
g' next;
};
esac;
fi;
};
ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next }
=>
ncf::GET_ADDRESS_OF_FIELD_I { i, record => ren record, to_temp, next => g' next };
ncf::TAIL_CALL { fn, args }
=>
{ args = map ren args;
fn = ren fn;
fun newvl NULL
=>
args;
newvl (THE live)
=>
{ fun z (a ! al, FALSE ! bl) => z (al, bl);
z (a ! al, TRUE ! bl) => a ! z (al, bl);
z _ => NIL;
end;
# This code may be obsolete.
# See the comment in the
# MUTUALLY_RECURSIVE_FNS
# case below.
case (z (args, live))
#
NIL => [ncf::INT 0];
[u] => hcf::ltw_is_fate (
grabty u,
\\ _ = [u, ncf::INT 0],
\\ _ = [u, ncf::INT 0],
\\ _ = [u]
);
vl'' => vl'';
esac;
};
end;
fun trybeta fv
=
{ my { used=>REF u, called=>REF c, info }
=
get fv;
case info
#
FNINFO { args => args', body, live_args, ... }
=>
if (c!=1 or u!=1)
#
ncf::TAIL_CALL { fn, args => newvl *live_args };
else
case body
#
REF (THE b)
=>
{ newnames (args', args);
call_less fn;
apply use_less args;
body:=NULL;
g' b;
};
_ => ncf::TAIL_CALL { fn, args => newvl *live_args };
esac;
fi;
_ => ncf::TAIL_CALL { fn, args };
esac;
};
case fn
#
ncf::CODETEMP fv => trybeta fv;
ncf::LABEL fv => trybeta fv;
_ => ncf::TAIL_CALL { fn, args };
esac;
};
ncf::DEFINE_FUNS { funs, next }
=>
{
funs = map getinfo funs;
funs = sublist keep funs;
next = g' next;
funs = sublist keep2 funs;
funs = map reduce_body funs;
case (sublist keep3 funs)
#
NIL => next;
funs => ncf::DEFINE_FUNS { funs => map #1 funs, next };
esac;
}
where
fun getinfo (x as (fk, f, vl, cl, b))
=
{ (get f) -> { used, called, info, ... };
case info
#
FNINFO { live_args=>REF (THE live), ... }
=>
{ fun z (a ! al, FALSE ! bl) => z (al, bl);
z (a ! al, TRUE ! bl) => a ! z (al, bl);
z _ => NIL;
end;
vl' = z (vl, live);
cl' = z (cl, live);
drop = fold_backward (\\ (a, b) = a ?? b :: b+1)
0
live;
fun dropclicks (n)
=
if (n > 0)
#
click "D";
dropclicks (n - 1);
fi;
# The code below may be obsolete. I think that
# we used to distinguish between user functions
# and fates in the closure phase by
# the number of arguments, and also we might
# not have been able to handle functions with
# no arguments. Possibly we can now remove
# these special cases. XXX BUGGO FIXME
tt' = map getty vl';
my (vl'', cl'', tt'')
=
case tt'
#
NIL =>
{ x = make_var (hcf::int_uniqtypoid);
dropclicks (drop - 1);
enter_misc0 x;
([x],[ncf::typ::INT],[hcf::int_uniqtypoid]);
};
[x] =>
if (is_cont x)
#
x = make_var (hcf::int_uniqtypoid);
dropclicks (drop - 1);
enter_misc0 x;
(vl' @ [x], cl' @ [ncf::typ::INT],
tt' @ [hcf::int_uniqtypoid]);
else
dropclicks drop;
(vl', cl', tt');
fi;
_ =>
{ dropclicks (drop);
(vl', cl', tt');
};
esac;
my (fk', lt)
=
make_fn_lty (fk, cl'', tt'');
newty (f, lt);
((fk', f, vl'', cl'', b), used, called, info);
};
_ => (x, used, called, info);
esac;
};
fun keep (_, used, called, info)
=
case (*called, *used, info)
(_, 0, FNINFO { body as REF (THE b), ... } )
=>
{ click "g";
body:=NULL;
drop_body b;
FALSE;
};
(_, 0, FNINFO { body=>REF NULL, ... } )
=>
{ click "g";
FALSE;
};
(1, 1, FNINFO { body=>REF (THE _), ... } )
=>
# NOTE: This is an optimistic click.
# The call could disappear before we
# get there; then the body would
# not be cleared out, dangerous. XXX BUGGO FIXME
{ click "e";
FALSE;
};
(_, _, IF_IDIOM_INFO { body=>REF b, ... } )
=>
{ click "E";
FALSE;
};
_ => TRUE;
esac;
fun keep2 (_, used, _, info)
=
case (*used, info)
(0, FNINFO { body as REF (THE b), ... } )
=>
# All occurrences were lost:
#
{ click "f";
body:=NULL;
drop_body b;
FALSE;
};
(0, FNINFO { body=>REF NULL, ... } )
=>
# We performed a cascaded inlining:
#
{ click "q";
FALSE;
};
(_, FNINFO { body, ... } )
=>
{ body := NULL;
TRUE;
};
_ => TRUE;
esac;
fun keep3 ((_, _, _, _, b), used, _, info)
=
case (*used, info)
(0, FNINFO _)
=>
# All occurrences were lost:
#
{ click "f";
drop_body b;
FALSE;
};
_ => TRUE;
esac;
fun reduce_body ((fk, f, vl, cl, body), used, called, info)
=
((fk, f, vl, cl, reduce body), used, called, info);
end;
ncf::JUMPTABLE { i, xvar, nexts }
=>
case (ren i)
#
i as ncf::INT k # We're switching on a constant, so drop all code branches but the relevant one.
=>
if (not *coc::switchopt)
#
ncf::JUMPTABLE { i, xvar, nexts => map g' nexts };
else
fun f (e ! el, j)
=>
{ if (j != k) drop_body e; fi;
f (el, j+1);
};
f (NIL, _) => ();
end;
click "h";
f (nexts, 0);
newname (xvar, ncf::INT 0);
g' (list::nth (nexts, k));
fi;
i => ncf::JUMPTABLE { i, xvar, nexts => map g' nexts };
esac;
ncf::FETCH_FROM_RAM { op => ncf::p::GET_EXCEPTION_HANDLER_REGISTER, to_temp, type, next, ... }
=>
if *coc::handlerfold
#
case handler
#
NULL
=>
if (used to_temp)
#
ncf::FETCH_FROM_RAM { op => ncf::p::GET_EXCEPTION_HANDLER_REGISTER,
args => [],
to_temp,
type,
next => g (THE (ncf::CODETEMP to_temp)) next
};
else
click "i";
g' next;
fi;
THE to_temp'
=>
{ click "j";
newname (to_temp, to_temp');
g' next;
};
esac;
else
ncf::FETCH_FROM_RAM { op => ncf::p::GET_EXCEPTION_HANDLER_REGISTER,
args => [],
to_temp,
type,
next => g (THE (ncf::CODETEMP to_temp)) next
};
fi;
ncf::STORE_TO_RAM { op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER, args => [v], next }
=>
{ v' = ren v;
next = g (THE v') next;
fun same_variable (ncf::CODETEMP x, ncf::CODETEMP y) => x == y;
same_variable _ => FALSE;
end;
if (not *coc::handlerfold)
#
ncf::STORE_TO_RAM { op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER, args => [v'], next };
else
case handler
#
THE v''
=>
if (same_variable (v', v''))
#
click "k";
use_less v'';
next;
else
ncf::STORE_TO_RAM { op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER, args => [v'], next };
fi;
_ => ncf::STORE_TO_RAM { op => ncf::p::SET_EXCEPTION_HANDLER_REGISTER, args => [v'], next };
esac;
fi;
};
# ncf::STORE_TO_RAM { op, args, next } => ncf::STORE_TO_RAM { op, args => map ren args, next => g' next }
ncf::STORE_TO_RAM { op, args, next }
=>
{ args = map ren args;
ncf::STORE_TO_RAM { op => setter (op, args),
args,
next => g' next
};
};
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next }
=>
{ args = map ren args;
(get to_temp) -> { used, ... };
if (*used==0 and *coc::deadvars)
#
click "m";
apply use_less args;
g' next;
else
next = g' next;
if (*used==0 and deadup)
#
click "*";
apply use_less args;
next;
else
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next };
fi;
fi;
};
ncf::ARITH { op => ncf::p::SHRINK_INT (p, n),
args => [v],
to_temp => x,
type => t,
next => e as ncf::PURE { op => ncf::p::COPY (n2, m),
args => [v2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
if (cvt_pre_condition (n, n2, x, v2) and n == m) click "T (1)"; ncf::ARITH { op => ncf::p::SHRINK_INT (p, m), args => [ren v], to_temp => x2, type => t2, next => g' e2 };
else ncf::ARITH { op => ncf::p::SHRINK_INT (p, n), args => [ren v], to_temp => x, type => t, next => g' e };
fi;
ncf::ARITH { op => ncf::p::SHRINK_INTEGER n,
args => [v, f],
to_temp => x,
type => t,
next => e as ncf::PURE { op => ncf::p::COPY (n2, m),
args => [v2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
if (cvt_pre_condition (n, n2, x, v2) and n == m) click "T (1)"; ncf::ARITH { op => ncf::p::SHRINK_INTEGER m, args => [ren v, ren f], to_temp => x2, type => t2, next => g' e2 };
else ncf::ARITH { op => ncf::p::SHRINK_INTEGER n, args => [ren v, ren f], to_temp => x, type => t, next => g' e };
fi;
ncf::ARITH { op => ncf::p::SHRINK_INT (p, n),
args => [v],
to_temp => x,
type => t,
next => e as ncf::ARITH { op => ncf::p::SHRINK_INT (n2, m),
args => [v2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
if (cvt_pre_condition (n, n2, x, v2)) click "T (2)"; ncf::ARITH { op => ncf::p::SHRINK_INT (p, m), args => [ren v], to_temp => x2, type => t2, next => g' e2 };
else ncf::ARITH { op => ncf::p::SHRINK_INT (p, n), args => [ren v], to_temp => x, type => t, next => g' e };
fi;
ncf::ARITH { op => ncf::p::SHRINK_INTEGER n,
args => [v, f],
to_temp => x,
type => t,
next => e as ncf::ARITH { op => ncf::p::SHRINK_INT (n2, m),
args => [v2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
if (cvt_pre_condition (n, n2, x, v2) ) click "T (2)"; ncf::ARITH { op => ncf::p::SHRINK_INTEGER m, args => [ren v, ren f], to_temp => x2, type => t2, next => g' e2 };
else ncf::ARITH { op => ncf::p::SHRINK_INTEGER n, args => [ren v, ren f], to_temp => x, type => t, next => g' e };
fi;
ncf::ARITH { op => ncf::p::SHRINK_UNT (p, n),
args => [v],
to_temp => x,
type => t,
next => e as ncf::PURE { op => ncf::p::COPY (n2, m),
args => [v2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
if (cvt_pre_condition (n, n2, x, v2) and n == m ) click "U (1)"; ncf::ARITH { op => ncf::p::SHRINK_UNT (p, m), args => [ren v], to_temp => x2, type => t2, next => g' e2 };
else ncf::ARITH { op => ncf::p::SHRINK_UNT (p, n), args => [ren v], to_temp => x, type => t, next => g' e };
fi;
ncf::ARITH { op => ncf::p::SHRINK_UNT (p, n),
args => [v],
to_temp => x,
type => t,
next => e as ncf::ARITH { op => ncf::p::SHRINK_UNT (n2, m),
args => [v2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
if (cvt_pre_condition (n, n2, x, v2)) click "U (2)"; ncf::ARITH { op => ncf::p::SHRINK_UNT (p, m), args => [ren v], to_temp => x2, type => t2, next => g' e2 };
else ncf::ARITH { op => ncf::p::SHRINK_UNT (p, n), args => [ren v], to_temp => x, type => t, next => g' e };
fi;
ncf::ARITH { op, args, to_temp, type, next }
=>
{ args = map ren args;
if *coc::arithopt
#
newname (to_temp, arith (op, args));
apply use_less args;
g' next;
else
raise exception CONSTANT_FOLD;
fi
except
CONSTANT_FOLD => ncf::ARITH { op, args, to_temp, type, next => g' next };
OVERFLOW => ncf::ARITH { op, args, to_temp, type, next => g' next };
end;
};
ncf::PURE { op => ncf::p::CHOP (p, n),
args => [v],
to_temp => x,
type => t,
next => e as ncf::PURE { op => pure,
args => [v2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
{ fun skip ()
=
ncf::PURE { op => ncf::p::CHOP (p, n),
args => [ren v],
to_temp => x,
type => t,
next => g' e
};
fun check_clicked (tok, n2, m, pure_op)
=
if (cvt_pre_condition (n, n2, x, v2))
#
click tok;
ncf::PURE { op => pure_op (p, m),
args => [ren v],
to_temp => x2,
type => t2,
next => g' e2
};
else
skip ();
fi;
case pure
#
ncf::p::CHOP (n2, m)
=>
check_clicked("R (1)", n2, m, ncf::p::CHOP);
ncf::p::COPY (n2, m)
=>
if (n2 == m) check_clicked("R (2)", n2, m, ncf::p::CHOP);
else skip ();
fi;
_ => skip();
esac;
};
ncf::PURE { op => ncf::p::CHOP_INTEGER n,
args => [v, f],
to_temp => x,
type => t,
next => e as ncf::PURE { op => pure,
args => [v2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
{ fun skip ()
=
ncf::PURE { op => ncf::p::CHOP_INTEGER n,
args => [ren v, ren f],
to_temp => x,
type => t,
next => g' e
};
fun check_clicked (tok, n2, m)
=
if (cvt_pre_condition (n, n2, x, v2))
#
click tok;
ncf::PURE { op => ncf::p::CHOP_INTEGER m,
args => [ren v, ren f],
to_temp => x2,
type => t2,
next => g' e2
};
else
skip();
fi;
case pure
#
ncf::p::CHOP (n2, m)
=>
check_clicked("R (1)", n2, m);
ncf::p::COPY (n2, m)
=>
if (n2 == m) check_clicked ("R (2)", n2, m);
else skip ();
fi;
_ => skip ();
esac;
};
ncf::PURE { op => ncf::p::STRETCH (p, n),
args => [v],
to_temp => x,
type => t,
next => e as ncf::PURE { op => ncf::p::STRETCH_TO_INTEGER n2,
args => [v2, f],
to_temp => x2,
type => t2,
next => e2
}
}
=>
if (cvt_pre_condition (n, n2, x, v2))
#
click "X (1')";
ncf::PURE { op => ncf::p::STRETCH_TO_INTEGER p, args => [ren v, ren f], to_temp => x2, type => t2, next => g' e2 };
else
ncf::PURE { op => ncf::p::STRETCH (p, n), args => [ren v], to_temp => x, type => t, next => g' e };
fi;
ncf::PURE { op => ncf::p::STRETCH (p, n),
args => [v],
to_temp => x,
type => t,
next => e as ncf::PURE { op => pure,
args => [v2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
{ fun skip ()
=
ncf::PURE { op => ncf::p::STRETCH (p, n),
args => [ren v],
to_temp => x,
type => t,
next => g' e
};
fun check_clicked (tok, n2, pure_op)
=
if (cvt_pre_condition (n, n2, x, v2))
#
click tok;
ncf::PURE { op => pure_op,
args => [ren v],
to_temp => x2,
type => t2,
next => g' e2
};
else
skip ();
fi;
case pure
#
ncf::p::STRETCH (n2, m)
=>
check_clicked("X (1)", n2, ncf::p::STRETCH (p, m));
ncf::p::COPY (n2, m)
=>
if (n2 == m) check_clicked("X (2)", n2, ncf::p::STRETCH (p, m));
else skip ();
fi;
ncf::p::CHOP (n2, m)
=>
m >= p ?? check_clicked("X (3)", n2, ncf::p::STRETCH (p, m))
:: check_clicked("X (4)", n2, ncf::p::CHOP (p, m));
_ => skip();
esac;
};
ncf::PURE { op => ncf::p::STRETCH_TO_INTEGER p,
args => [v, f],
to_temp => x,
type => t,
next => e as ncf::PURE { op => ncf::p::CHOP_INTEGER m,
args => [v2, f2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
{ fun check_clicked (tok, pure_op)
=
if (cvt_pre_condition_inf (x, v2))
#
click tok;
use_less f; use_less f2;
ncf::PURE { op => pure_op, args => [ren v], to_temp => x2, type => t2, next => g' e2 };
else
ncf::PURE { op => ncf::p::STRETCH_TO_INTEGER p, args => [ren v, ren f], to_temp => x, type => t, next => g' e };
fi;
m >= p ?? check_clicked("X (3')", ncf::p::STRETCH (p, m))
:: check_clicked("X (4')", ncf::p::CHOP (p, m));
};
ncf::PURE { op => ncf::p::STRETCH (p, n),
args => [v],
to_temp => x,
type => t,
next => e as ncf::ARITH { op => a,
args => [v2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
{ v' = [ren v];
fun skip ()
=
ncf::PURE { op => ncf::p::STRETCH (p, n),
args => v',
to_temp => x,
type => t,
next => g' e
};
fun check_clicked (tok, n2, m, arith_op)
=
if (cvt_pre_condition (n, n2, x, v2))
#
if (m >= p) click tok; ncf::PURE { op => ncf::p::STRETCH (p, m), args => v', to_temp => x2, type => t2, next => g' e2 };
else ncf::ARITH { op => arith_op (p, m), args => v', to_temp => x2, type => t2, next => g' e2 };
fi;
else
skip();
fi;
case a
#
ncf::p::SHRINK_INT (n2, m) => check_clicked("X (5)", n2, m, ncf::p::SHRINK_INT);
ncf::p::SHRINK_UNT (n2, m) => check_clicked("X (6)", n2, m, ncf::p::SHRINK_UNT);
_ => skip();
esac;
};
ncf::PURE { op => ncf::p::STRETCH_TO_INTEGER p,
args => [v, f],
to_temp => x,
type => t,
next => e as ncf::ARITH { op => ncf::p::SHRINK_INTEGER m,
args => [v2, f2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
if (cvt_pre_condition_inf (x, v2))
#
if (m >= p)
#
click "X9";
use_less f;
use_less f2;
ncf::PURE { op => ncf::p::STRETCH (p, m), args => [ren v], to_temp => x2, type => t2, next => g' e2 };
else
ncf::ARITH { op => ncf::p::SHRINK_INT (p, m), args => [ren v], to_temp => x2, type => t2, next => g' e2 };
fi;
else
ncf::PURE { op => ncf::p::STRETCH_TO_INTEGER p, args => [ren v, ren f], to_temp => x, type => t, next => g' e };
fi;
ncf::PURE { op => ncf::p::COPY (p, n),
args => [v],
to_temp => x,
type => t,
next => e as ncf::PURE { op => ncf::p::COPY_TO_INTEGER n2,
args => [v2, f2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
if (cvt_pre_condition (n, n2, x, v2))
#
click "C (2)";
ncf::PURE { op => ncf::p::COPY_TO_INTEGER p, args => [ren v, ren f2], to_temp => x2, type => t2, next => g' e2 };
else
ncf::PURE { op => ncf::p::COPY (p, n), args => [ren v], to_temp => x, type => t, next => g' e };
fi;
ncf::PURE { op => ncf::p::COPY (p, n),
args => [v],
to_temp => x,
type => t,
next => e as ncf::PURE { op => ncf::p::STRETCH_TO_INTEGER n2,
args => [v2, f2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
{ fun skip ()
=
ncf::PURE { op => ncf::p::COPY (p, n),
args => [ren v],
to_temp => x,
type => t,
next => g' e
};
fun check_clicked (tok, pure_op)
=
if (cvt_pre_condition (n, n2, x, v2))
#
click tok;
ncf::PURE { op => pure_op,
args => [ren v, ren f2],
to_temp => x2,
type => t2,
next => g' e2
};
else
skip ();
fi;
if (n > p)
#
check_clicked("C (2')", ncf::p::COPY_TO_INTEGER p);
else
if (n == p) check_clicked("C (2')", ncf::p::STRETCH_TO_INTEGER p);
else skip ();
fi;
fi;
};
ncf::PURE { op => ncf::p::COPY (p, n),
args => [v],
to_temp => x,
type => t,
next => e as ncf::PURE { op => pure,
args => [v2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
{ v' = [ren v];
fun skip ()
=
ncf::PURE { op => ncf::p::COPY (p, n),
args => v',
to_temp => x,
type => t,
next => g' e
};
fun check_clicked (tok, n2, pure_op)
=
if (cvt_pre_condition (n, n2, x, v2))
#
click tok;
ncf::PURE { op => pure_op,
args => v',
to_temp => x2,
type => t2,
next => g' e2
};
else
skip();
fi;
case pure
#
ncf::p::COPY (n2, m)
=>
check_clicked("C (1)", n2, ncf::p::COPY (p, m));
ncf::p::STRETCH (n2, m)
=>
if (n > p) check_clicked("C (2)", n2, ncf::p::COPY (p, m));
elif (n == p) check_clicked("C (2)", n2, ncf::p::STRETCH (p, m));
else skip();
fi;
ncf::p::CHOP (n2, m)
=>
if (m >= p) check_clicked("C (3)", n2, ncf::p::COPY (p, m));
elif (m < p) check_clicked("C (4)", n2, ncf::p::CHOP (p, m));
else skip();
fi;
_ => skip();
esac;
};
ncf::PURE { op => ncf::p::COPY_TO_INTEGER p,
args => [v, f],
to_temp => x,
type => t,
next => e as ncf::PURE { op => ncf::p::CHOP_INTEGER m,
args => [v2, f2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
{ fun skip ()
=
ncf::PURE { op => ncf::p::COPY_TO_INTEGER p,
args => [ren v, ren f],
to_temp => x,
type => t,
next => g' e
};
fun check_clicked (tok, pure_op)
=
if (cvt_pre_condition_inf (x, v2) )
#
click tok;
use_less f;
use_less f2;
ncf::PURE { op => pure_op,
args => [ren v],
to_temp => x2,
type => t2,
next => g' e2
};
else
skip ();
fi;
if (m >= p) check_clicked ("C (3)", ncf::p::COPY (p, m));
elif (m < p) check_clicked ("C (4)", ncf::p::CHOP (p, m));
else skip ();
fi;
};
ncf::PURE { op => ncf::p::COPY (p, n),
args => [v],
to_temp => x,
type => t,
next => e as ncf::ARITH { op => a,
args => [v2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
{
v' = [ren v];
fun skip ()
=
ncf::PURE { op => ncf::p::COPY (p, n),
args => v',
to_temp => x,
type => t,
next => g' e
};
fun check_clicked (tok, n2, ilk, arith_op)
=
if (cvt_pre_condition (n, n2, x, v2) )
click tok; ilk { op => arith_op, args => v', to_temp => x2, type => t2, next => g' e2 };
else
skip();
fi;
case a
ncf::p::SHRINK_INT (n2, m)
=>
m >= p ?? check_clicked("C5", n2, ncf::PURE, ncf::p::COPY (p, m))
:: check_clicked("C6", n2, ncf::ARITH, ncf::p::SHRINK_INT (p, m));
ncf::p::SHRINK_UNT (n2, m)
=>
m > p ?? check_clicked("C7", n2, ncf::PURE, ncf::p::COPY (p, m))
:: check_clicked("C8", n2, ncf::ARITH, ncf::p::SHRINK_UNT (p, m));
_ => skip();
esac;
};
ncf::PURE { op => ncf::p::COPY_TO_INTEGER p,
args => [v, f],
to_temp => x,
type => t,
next => e as ncf::ARITH { op => ncf::p::SHRINK_INTEGER m,
args => [v2, f2],
to_temp => x2,
type => t2,
next => e2
}
}
=>
{
fun check_clicked (tok, ilk, op)
=
if (cvt_pre_condition_inf (x, v2) )
#
click tok;
#
use_less f;
use_less f2;
#
ilk { op,
args => [ren v],
to_temp => x2,
type => t2,
next => g' e2
};
else
ncf::PURE { op => ncf::p::COPY_TO_INTEGER p,
args => [ren v, ren f],
to_temp => x,
type => t,
next => g' e
};
fi;
m >= p ?? check_clicked ("C5", ncf::PURE, ncf::p::COPY (p, m))
:: check_clicked ("C6", ncf::ARITH, ncf::p::SHRINK_INT (p, m));
};
ncf::PURE { op, args, to_temp, type, next }
=>
{ args = map ren args;
(get to_temp) -> { used, ... };
if (*used==0 and *coc::deadvars)
#
click "m";
apply use_less args;
g' next;
else
if (*coc::arithopt)
#
newname (to_temp, pure (op, args));
g' next;
else
raise exception CONSTANT_FOLD;
fi
except
CONSTANT_FOLD
=
{ next = g' next;
if (*used==0 and deadup)
#
apply use_less args;
click "*";
next;
else
ncf::PURE { op, args, to_temp, type, next };
fi;
};
fi;
};
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
=> ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args => map ren args, to_ttemps, next => g' next }; # Leave raw C calls alone.
ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
=>
{ args = map ren args;
# Maximum number of speculatively
# executed conditional moves:
#
max_condmove_hoist = 3;
# This function creates conditional moves
# from statements of the form:
#
# ncf::IF_THEN_ELSE { op, args, xvar, then_next => ncf::TAIL_CALL { fn, args=>[x1] },
# else_next => ncf::TAIL_CALL { fn, args=>[x2] }
# }
#
fun conditional_move ()
=
{ # Hoist conditional moves up from branches
# This will make them run speculatively.
# We limit this number to max_condmove_hoist so
# that we don't speculatively execute everything.
#
fun hoist (e, 0)
=>
(\\ k = k, e);
hoist (ncf::PURE { op as ncf::p::CONDITIONAL_LOAD _, args, to_temp, type, next }, n)
=>
{ (hoist (next, n - 1)) -> (k, next);
#
fun new_k next
=
ncf::PURE { op, args, to_temp, type, next => k next };
(new_k, next);
};
hoist (e, _)
=>
(\\ k = k, e);
end;
my (k1, then_next) = hoist (g' then_next, max_condmove_hoist);
my (k2, else_next) = hoist (g' else_next, max_condmove_hoist);
fun default () # The default does nothing
=
ncf::IF_THEN_ELSE { op, args, xvar, then_next => k1 then_next,
else_next => k2 else_next };
# Determine the type of
# conditional move:
#
fun find_type (f, x, y)
=
{ fun get_type (x, again)
=
case x
#
ncf::STRING _ => THE ncf::bogus_pointer_type;
ncf::LABEL _ => THE ncf::bogus_pointer_type;
ncf::FLOAT64 _ => THE ncf::typ::FLOAT64;
ncf::INT1 _ => THE ncf::typ::INT1;
ncf::INT _ => THE ncf::bogus_pointer_type;
#
_ => again ();
esac;
fun find_type ()
=
get_type (x, \\ _ = get_type (y, \\ _ = NULL));
case (.info (get f))
#
FNINFO { args => [f_arg], ... }
=>
case ((get f_arg).info)
#
MISCINFO t => THE t; # Found type.
_ => find_type ();
esac;
_ => find_type();
esac;
};
case (op, then_next, else_next)
#
((ncf::p::STRING_EQL | ncf::p::STRING_NEQ), _, _)
=>
default (); # String compares are complex, so we punt on them
( _,
ncf::TAIL_CALL { fn => ncf::CODETEMP f, args => [x] },
ncf::TAIL_CALL { fn => ncf::CODETEMP f', args => [y] }
)
=>
if (f == f')
#
case (find_type (f, x, y))
#
THE t
=>
{ r = tmp::issue_highcode_codetemp ();
say "COND MOVE\n";
k1 (
k2 (
ncf::PURE
{ op => ncf::p::CONDITIONAL_LOAD op,
args => args @ [x, y],
to_temp => r,
type => t,
next => ncf::TAIL_CALL { fn => ncf::CODETEMP f,
args => [ncf::CODETEMP r]
}
}
)
);
};
_ =>
{ say "COND MOVE failed\n";
default();
};
esac;
else
default();
fi;
_ => default();
esac;
};
fun no_conditional_move ()
=
ncf::IF_THEN_ELSE { op, args, xvar, then_next => g' then_next, else_next => g' else_next };
fun h ()
=
( if (*coc::branchfold and equal_upto_alpha (then_next, else_next))
#
click "z";
apply use_less args;
newname (xvar, ncf::INT 0);
drop_body else_next;
g' then_next;
#
elif (*coc::comparefold)
#
if (branch (op, args))
#
newname (xvar, ncf::INT 0);
apply use_less args;
drop_body else_next;
g' then_next;
else
newname (xvar, ncf::INT 0);
apply use_less args;
drop_body then_next;
g' else_next;
fi;
else
raise exception CONSTANT_FOLD;
fi
)
except
CONSTANT_FOLD = no_conditional_move ();
fun get_if_idiom f
=
{ f' = ren f;
case f'
#
ncf::CODETEMP v
=>
case (get v)
#
{ info=>IF_IDIOM_INFO { body }, ... } => THE body;
_ => NULL;
esac;
_ => NULL;
esac;
};
case (then_next, else_next)
#
( ncf::TAIL_CALL { fn => ncf::CODETEMP f, args => [ncf::INT 1] },
ncf::TAIL_CALL { fn => ncf::CODETEMP f', args => [ncf::INT 0] }
)
=>
case (f==f', get_if_idiom (ncf::CODETEMP f))
#
(TRUE, THE (body as REF (THE (c', a, b))))
=> # Handle IF IDIOM.
{ newname (c', ncf::CODETEMP xvar);
body := NULL;
g' (ncf::IF_THEN_ELSE { op, args, xvar, then_next => a, else_next => b }); # NOTE: could use vl' here instead of vl.
};
_ => h();
esac;
_ => h();
esac;
};
end; # fun handler
end
also
branch
=
\\ (ncf::p::IS_UNBOXED, vl ) => not (branch (ncf::p::IS_BOXED, vl));
(ncf::p::IS_BOXED, [ncf::INT _] ) => { click "n"; FALSE;};
(ncf::p::IS_BOXED, [ncf::STRING s]) => { click "o"; TRUE;};
(ncf::p::IS_BOXED, [ncf::CODETEMP v])
=>
case (get v)
#
{ info=>RECINFO _, ... } => { click "p"; TRUE; };
_ => raise exception CONSTANT_FOLD;
esac;
(ncf::p::COMPARE { op=>ncf::p::LT, kind_and_size }, [ncf::CODETEMP v, ncf::CODETEMP w])
=>
if (v == w)
#
click "v";
FALSE;
else
raise exception CONSTANT_FOLD;
fi;
(ncf::p::COMPARE { op=>ncf::p::LT, kind_and_size=>ncf::p::INT 31 }, [ncf::INT i, ncf::INT j])
=>
{ click "w";
i < j;
};
(ncf::p::COMPARE { op=>ncf::p::GT, kind_and_size }, [w, v])
=>
branch (ncf::p::COMPARE { op=>ncf::p::LT, kind_and_size },[v, w]);
(ncf::p::COMPARE { op=>ncf::p::LE, kind_and_size }, [w, v])
=>
branch (ncf::p::COMPARE { op=>ncf::p::GE, kind_and_size },[v, w]);
(ncf::p::COMPARE { op=>ncf::p::GE, kind_and_size }, vl)
=>
not (branch (ncf::p::COMPARE { op=>ncf::p::LT, kind_and_size }, vl));
(ncf::p::COMPARE { op=>ncf::p::LT, kind_and_size=>ncf::p::UNT 31 }, [ncf::INT i, ncf::INT j])
=>
{ click "w";
if (j < 0 )
i >= 0 or i < j;
else
i >= 0 and i < j;
fi;
};
(ncf::p::COMPARE { op=>ncf::p::EQL, kind_and_size }, [ncf::CODETEMP v, ncf::CODETEMP w])
=>
case kind_and_size
#
ncf::p::FLOAT _ => raise exception CONSTANT_FOLD; # In case of NaN's.
_ => if (v==w ) click "v"; TRUE;
else raise exception CONSTANT_FOLD;
fi;
esac;
(ncf::p::COMPARE { op=>ncf::p::EQL, ... }, [ncf::INT i, ncf::INT j])
=>
{ click "w";
i == j;
};
(ncf::p::COMPARE { op=>ncf::p::NEQ, kind_and_size }, vl)
=>
not (branch (ncf::p::COMPARE { op=>ncf::p::EQL, kind_and_size }, vl));
(ncf::p::POINTER_EQL, [ncf::INT i, ncf::INT j])
=>
{ click "w";
i == j;
};
(ncf::p::POINTER_NEQ, [v, w])
=>
not (branch (ncf::p::POINTER_EQL,[w, v]));
_ =>
raise exception CONSTANT_FOLD;
end
also
arith
=
\\ (ncf::p::ARITH { op=>ncf::p::MULTIPLY, ... }, [ncf::INT 1, v]) => { click "F"; v;};
(ncf::p::ARITH { op=>ncf::p::MULTIPLY, ... }, [v, ncf::INT 1]) => { click "G"; v;};
(ncf::p::ARITH { op=>ncf::p::MULTIPLY, ... }, [ncf::INT 0, _]) => { click "H"; ncf::INT 0;};
(ncf::p::ARITH { op=>ncf::p::MULTIPLY, ... }, [_, ncf::INT 0]) => { click "I"; ncf::INT 0;};
(ncf::p::ARITH { op=>ncf::p::MULTIPLY, kind_and_size=>ncf::p::INT 31 }, [ncf::INT i, ncf::INT j])
=>
{ x = i*j;
x+x+2; # XXX BUGGO FIXME What is this supposed to do? Should it be 'x = x+2;' ? Is this an overflow test? Notice these are pervasive in this section so typo is not likely.
click "J";
ncf::INT x;
};
(ncf::p::ARITH { op=>ncf::p::DIVIDE, ... }, [v, ncf::INT 1]) => { click "K"; v;};
(ncf::p::ARITH { op=>ncf::p::DIVIDE, ... }, [ncf::INT i, ncf::INT 0]) => raise exception CONSTANT_FOLD;
(ncf::p::ARITH { op=>ncf::p::DIVIDE, kind_and_size=>ncf::p::INT 31 }, [ncf::INT i, ncf::INT j])
=>
{ x = int::quot (i, j); x+x; click "L"; ncf::INT x; };
(ncf::p::ARITH { op=>ncf::p::DIV, ... }, [v, ncf::INT 1]) => { click "K"; v;};
(ncf::p::ARITH { op=>ncf::p::DIV, ... }, [ncf::INT i, ncf::INT 0]) => raise exception CONSTANT_FOLD;
(ncf::p::ARITH { op=>ncf::p::DIV, kind_and_size=>ncf::p::INT 31 }, [ncf::INT i, ncf::INT j])
=>
{ x = int::(/) (i, j); x+x; click "L"; ncf::INT x; };
# XXX BUGGO FIXME: should we do anything for mod or rem here?
(ncf::p::ARITH { op=>ncf::p::ADD, ... }, [ncf::INT 0, v]) => { click "M"; v;};
(ncf::p::ARITH { op=>ncf::p::ADD, ... }, [v, ncf::INT 0]) => { click "N"; v;};
(ncf::p::ARITH { op=>ncf::p::ADD, kind_and_size=>ncf::p::INT 31 }, [ncf::INT i, ncf::INT j])
=>
{ x = i+j; x+x+2; click "O"; ncf::INT x; };
(ncf::p::ARITH { op=>ncf::p::SUBTRACT, ... }, [v, ncf::INT 0]) => { click "P"; v;};
(ncf::p::ARITH { op=>ncf::p::SUBTRACT, kind_and_size=>ncf::p::INT 31 }, [ncf::INT i, ncf::INT j]) =>
{ x = i-j; x+x+2; click "Q"; ncf::INT x; };
(ncf::p::ARITH { op=>ncf::p::NEGATE, kind_and_size=>ncf::p::INT 31, ... }, [ncf::INT i]) =>
{ x = -i; x+x+2; click "X"; ncf::INT x; };
_ => raise exception CONSTANT_FOLD;
end
also
pure
=
\\ (ncf::p::PURE_ARITH { op=>ncf::p::RSHIFT, kind_and_size=>ncf::p::INT 31 }, [ncf::INT i, ncf::INT j])
=>
{ click "R";
ncf::INT (wtoi (unt::(>>>)(itow i, itow j)));
};
(ncf::p::PURE_ARITH { op=>ncf::p::RSHIFT, kind_and_size=>ncf::p::INT 31 }, [ncf::INT 0, _])
=>
{ click "S"; ncf::INT 0;};
(ncf::p::PURE_ARITH { op=>ncf::p::RSHIFT, kind_and_size=>ncf::p::INT 31 }, [v, ncf::INT 0])
=>
{ click "T"; v;};
(ncf::p::VECTOR_LENGTH_IN_SLOTS, [ncf::STRING s])
=>
{ click "V"; ncf::INT (size s);};
# (ncf::p::ORDOF, [STRING s, ncf::INT i])
# =>
# { click "W"; ncf::INT (ro_int8_vec_get (s, i))};
(ncf::p::PURE_ARITH { op=>ncf::p::LSHIFT, kind_and_size=>ncf::p::INT 31 }, [ncf::INT i, ncf::INT j])
=>
( { x = wtoi (unt::(<<) (itow i, itow j));
x+x;
click "Y";
ncf::INT x;
}
except
OVERFLOW = raise exception CONSTANT_FOLD
);
(ncf::p::PURE_ARITH { op=>ncf::p::LSHIFT, kind_and_size=>ncf::p::INT 31 }, [ncf::INT 0, _])
=>
{ click "Z"; ncf::INT 0;};
(ncf::p::PURE_ARITH { op=>ncf::p::LSHIFT, kind_and_size=>ncf::p::INT 31 }, [v, ncf::INT 0])
=>
{ click "1"; v;};
(ncf::p::PURE_ARITH { op=>ncf::p::BITWISE_OR, kind_and_size=>ncf::p::INT 31 }, [ncf::INT i, ncf::INT j])
=>
{ click "2"; ncf::INT (wtoi (unt::bitwise_or (itow i, itow j)));};
(ncf::p::PURE_ARITH { op=>ncf::p::BITWISE_OR, kind_and_size=>ncf::p::INT 31 }, [ncf::INT 0, v])
=>
{ click "3"; v;};
(ncf::p::PURE_ARITH { op=>ncf::p::BITWISE_OR, kind_and_size=>ncf::p::INT 31 }, [v, ncf::INT 0])
=>
{ click "4"; v;};
(ncf::p::PURE_ARITH { op=>ncf::p::BITWISE_XOR, kind_and_size=>ncf::p::INT 31 }, [ncf::INT i, ncf::INT j])
=>
{ click "5"; ncf::INT (wtoi (unt::bitwise_xor (itow i, itow j)));};
(ncf::p::PURE_ARITH { op=>ncf::p::BITWISE_XOR, kind_and_size=>ncf::p::INT 31 }, [ncf::INT 0, v])
=>
{ click "6"; v;};
(ncf::p::PURE_ARITH { op=>ncf::p::BITWISE_XOR, kind_and_size=>ncf::p::INT 31 }, [v, ncf::INT 0])
=>
{ click "7"; v;};
(ncf::p::PURE_ARITH { op=>ncf::p::BITWISE_NOT, kind_and_size=>ncf::p::INT 31 }, [ncf::INT i])
=>
{ click "8"; ncf::INT (wtoi (unt::bitwise_not (itow i)));};
(ncf::p::PURE_ARITH { op=>ncf::p::BITWISE_AND, kind_and_size=>ncf::p::INT 31 }, [ncf::INT i, ncf::INT j])
=>
{ click "9"; ncf::INT (wtoi (unt::bitwise_and (itow i, itow j)));};
(ncf::p::PURE_ARITH { op=>ncf::p::BITWISE_AND, kind_and_size=>ncf::p::INT 31 }, [ncf::INT 0, _])
=>
{ click "0"; ncf::INT 0;};
(ncf::p::PURE_ARITH { op=>ncf::p::BITWISE_AND, kind_and_size=>ncf::p::INT 31 }, [_, ncf::INT 0])
=>
{ click "T"; ncf::INT 0;};
(ncf::p::CONVERT_FLOAT { from=>ncf::p::INT 31, to=>ncf::p::FLOAT 64 }, [ncf::INT i])
=>
(ncf::FLOAT64 (int::to_string i + ".0")); # Isn't this cool?
(ncf::p::UNWRAP_FLOAT64, [x as ncf::CODETEMP v])
=>
case (get v)
#
{ info=>WRPINFO (ncf::p::WRAP_FLOAT64, u), ... }
=>
{ click "U";
use_less x;
u;
};
_ => raise exception CONSTANT_FOLD;
esac;
(ncf::p::WRAP_FLOAT64, [x as ncf::CODETEMP v])
=>
case (get v)
{ info=>WRPINFO (ncf::p::UNWRAP_FLOAT64, u), ... }
=>
{ click "U"; use_less x; u;};
_ =>
raise exception CONSTANT_FOLD;
esac;
(ncf::p::IUNWRAP, [x as ncf::CODETEMP v])
=>
case (get v)
#
{ info=>WRPINFO (ncf::p::IWRAP, u), ... }
=>
{ click "U"; use_less x; u;};
_ => raise exception CONSTANT_FOLD;
esac;
(ncf::p::IWRAP, [x as ncf::CODETEMP v])
=>
case (get (v))
#
{ info=>WRPINFO (ncf::p::IUNWRAP, u), ... }
=>
{ click "U"; use_less x; u;};
_ => raise exception CONSTANT_FOLD;
esac;
(ncf::p::UNWRAP_INT1, [x as ncf::CODETEMP v])
=>
case (get v)
#
{ info=>WRPINFO (ncf::p::WRAP_INT1, u), ... }
=>
{ click "U"; use_less x; u;};
_ => raise exception CONSTANT_FOLD;
esac;
(ncf::p::WRAP_INT1, [x as ncf::CODETEMP v])
=>
case (get v)
#
{ info => WRPINFO (ncf::p::UNWRAP_INT1, u), ... }
=>
{ click "U"; use_less x; u;};
_ => raise exception CONSTANT_FOLD;
esac;
_ =>
raise exception CONSTANT_FOLD;
end;
debugprint "Contract: ";
debugflush ();
enter_misc0 fvar;
apply enter_misc0 fargs;
pass1 cexp;
nextcode_size := iht::vals_count m;
cexp' = reduce cexp;
debugprint "\n";
if (debug)
debugprint "After contract: \n";
prettyprint_nextcode::print_nextcode_expression cexp';
fi;
end;
}; # generic package contract_g
end; # stipulate