## make-nextcode-literals-bytecode-vector.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### "There is no such thing as group
### originality or group creativity."
###
### -- Edwin Land
stipulate
package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkgherein
api Make_Nextcode_Literals_Bytecode_Vector {
#
Literal_Expression;
split_off_nextcode_literals
:
ncf::Function -> (ncf::Function, Literal_Expression);
make_nextcode_literals_bytecode_vector
:
Literal_Expression -> vector_of_one_byte_unts::Vector;
};
end;
stipulate
package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package hv = 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 w8v = vector_of_one_byte_unts; # vector_of_one_byte_unts is from src/lib/std/src/vector-of-one-byte-unts.pkg package intset {
Intset = Ref( int_red_black_set::Set );
fun new () = REF int_red_black_set::empty;
fun add set i = set := int_red_black_set::add(*set, i);
fun mem set i = int_red_black_set::member(*set, i);
# fun rmv set i = set := int_red_black_set::drop(*set, i);
};
herein
package make_nextcode_literals_bytecode_vector
: (weak) Make_Nextcode_Literals_Bytecode_Vector # Make_Nextcode_Literals_Bytecode_Vector is from src/lib/compiler/back/top/main/make-nextcode-literals-bytecode-vector.pkg {
fun bug msg
=
err::impossible ("Literals: " + msg);
ident = \\ x = x;
fun make_var _
=
hv::issue_highcode_codetemp ();
# **************************************************************************
# A MINI-LITERAL LANGUAGE *
# **************************************************************************
Literal_Value
= LI_INT Unt
| LI_STRING String
| LI_VAR ncf::Codetemp
;
Block_Kind
= LI_RECORD # Record of tagged Mythryl values.
| LI_VECTOR # Vector of tagged Mythryl values.
;
Literal_Expression
= LI_TOP List( Literal_Value )
| LI_BLOCK (Block_Kind, List( Literal_Value ), ncf::Codetemp, Literal_Expression)
| LI_F64BLOCK ( List( String ), ncf::Codetemp, Literal_Expression)
| LI_I32BLOCK ( List( one_word_unt::Unt ), ncf::Codetemp, Literal_Expression)
;
fun rk2bk ncf::rk::VECTOR => LI_VECTOR;
rk2bk ncf::rk::RECORD => LI_RECORD;
#
rk2bk _ => bug "rk2bk: unexpected block kind";
end;
fun value_to_liternal (ncf::CODETEMP v) => LI_VAR v;
value_to_liternal (ncf::INT i) => LI_INT (unt::from_int i);
value_to_liternal (ncf::STRING s) => LI_STRING s;
#
value_to_liternal _ => bug "unexpected case in value_to_liternal";
end;
# **************************************************************************
# TRANSLATING THE LITERAL EXP TO BYTES *
# **************************************************************************
# Literals are encoded as instructions for a bytecoded "literal machine,"
# implemented in
#
# src/c/heapcleaner/make-package-literals-via-bytecode-interpreter.c
#
# Consequently the bytecode definitions here MUST be kept in sync with the
# bytecode definitions there!
#
# The supported instructions are:
#
# INT (i) -- Push the tagged_int literal i on the stack.
#
# RAW32[i1, ..., in] -- Form a 32-bit raw data record from the
# i1..in and push a pointer to it.
#
# RAW64[r1, ..., rn] -- Form a 64-bit raw data record from the
# r1..rn and push a pointer to it.
#
# STR[c1, ..., cn] -- Form a string from the characters c1..cn
# and push it on the stack.
#
# LIT (k) -- Push the contents of the stack element
# that is k slots from the top of the stack.
#
# VECTOR (n) -- Pop n elements from the stack, make a vector
# from them and push a pointer to the vector.
#
# RECORD (n) -- Pop n elements from the stack, make a record
# from them and push a pointer.
#
# RETURN -- Return the top-of-stack literal.
fun w32to_bytes' (w, l)
=
one_byte_unt::from_large_unt (one_word_unt::(>>) (w, 0u24))
! one_byte_unt::from_large_unt (one_word_unt::(>>) (w, 0u16))
! one_byte_unt::from_large_unt (one_word_unt::(>>) (w, 0u08))
! one_byte_unt::from_large_unt w
! l;
fun w32to_bytes w = w32to_bytes' (w, []);
fun w31to_bytes w = w32to_bytes (tagged_unt::to_large_unt_x w);
fun int_to_bytes i = w32to_bytes (one_word_unt::from_int i);
fun int_to_bytes' (i, l) = w32to_bytes'(one_word_unt::from_int i, l);
fun string_to_bytes s
=
map byte::char_to_byte (explode s);
### "A Thaum is the basic unit of magical strength.
### It has been universally established as the amount
### of magic needed to create one small white pigeon
### or three normal-sized billiard balls."
###
### -- Terry Pratchett
put_magic = w8v::from_list [ 0ux19, 0ux98, 0ux10, 0ux22 ]; # V1_MAGIC in src/c/heapcleaner/make-package-literals-via-bytecode-interpreter.c
fun put_depth n = w8v::from_list (int_to_bytes n);
fun put_int i = w8v::from_list (0ux01 ! w31to_bytes i); # MAKE_TAGGED_VAL in src/c/heapcleaner/make-package-literals-via-bytecode-interpreter.c
fun put_raw32 [i] => w8v::from_list (0ux02 ! w32to_bytes i); # MAKE_FOUR_BYTE_VAL in src/c/heapcleaner/make-package-literals-via-bytecode-interpreter.c
put_raw32 l =>
w8v::from_list (0ux03 ! (int_to_bytes'(length l, list::fold_backward w32to_bytes' [] l))); # MAKE_FOUR_BYTE_VALS_VECTOR in src/c/heapcleaner/make-package-literals-via-bytecode-interpreter.c
end;
fun put_raw64 [r] => w8v::from_list (0ux04 ! string_to_bytes r); # MAKE_EIGHT_BYTE_VAL in src/c/heapcleaner/make-package-literals-via-bytecode-interpreter.c
put_raw64 l => w8v::cat(
w8v::from_list (0ux05 ! int_to_bytes (length l)) ! map byte::string_to_bytes l); # MAKE_EIGHT_BYTE_VALS_VECTOR in src/c/heapcleaner/make-package-literals-via-bytecode-interpreter.c
end;
fun put_string s
=
w8v::cat [
w8v::from_list (0ux06 ! int_to_bytes (size s)), # MAKE_ASCII_STRING in src/c/heapcleaner/make-package-literals-via-bytecode-interpreter.c
byte::string_to_bytes s
];
fun put_lit k = w8v::from_list (0ux07 ! int_to_bytes k); # GET_ITH_LITERAL in src/c/heapcleaner/make-package-literals-via-bytecode-interpreter.c
fun put_vector n = w8v::from_list (0ux08 ! int_to_bytes n); # MAKE_VECTOR in src/c/heapcleaner/make-package-literals-via-bytecode-interpreter.c
fun put_record n = w8v::from_list (0ux09 ! int_to_bytes n); # MAKE_RECORD in src/c/heapcleaner/make-package-literals-via-bytecode-interpreter.c
put_return = w8v::from_list [0uxff]; # RETURN_LAST_LITERAL in src/c/heapcleaner/make-package-literals-via-bytecode-interpreter.c
# This is where we generate the literals bytecode
# program which will eventually be interpreted by
#
# src/c/heapcleaner/make-package-literals-via-bytecode-interpreter.c
#
fun make_nextcode_literals_bytecode_vector (LI_TOP [])
=>
w8v::from_list [];
make_nextcode_literals_bytecode_vector lit_expression
=>
{ max_depth = depth (lit_expression, 0, 1);
code = put_magic
! put_depth max_depth
! list::reverse (put_lit_expression([], lit_expression, []));
w8v::cat code;
}
where
fun depth (LI_TOP ls, d, max_depth)
=>
int::max (max_depth, d+length ls);
depth (LI_BLOCK(_, ls, _, rest), d, max_depth)
=>
depth (rest, d+1, int::max (max_depth, d+length ls));
depth (LI_F64BLOCK (ls, _, rest), d, max_depth)
=>
depth (rest, d+1, int::max (max_depth, d+length ls));
depth (LI_I32BLOCK (ls, _, rest), d, max_depth)
=>
depth (rest, d+1, int::max (max_depth, d+length ls));
end;
fun put_lit_expression (dictionary, expression, code)
=
case expression
#
(LI_TOP ls) => put_return ! emitablock (LI_RECORD, ls, code);
#
(LI_BLOCK (bk, ls, v, rest)) => put_lit_expression (v ! dictionary, rest, emitablock (bk, ls, code));
(LI_F64BLOCK (ls, v, rest)) => put_lit_expression (v ! dictionary, rest, put_f64block (ls, code));
(LI_I32BLOCK (ls, v, rest)) => put_lit_expression (v ! dictionary, rest, put_i32block (ls, code));
esac
where
fun put_lit_vals ([], _, code)
=>
code;
put_lit_vals (lit ! r, d, code)
=>
{
instruction
=
case lit
(LI_INT i) => put_int i;
(LI_STRING s) => put_string s;
(LI_VAR v)
=>
put_lit (f (dictionary, d))
where
fun f ([], _) => bug "unbound ncf::Codetemp";
f (v' ! r, d) => if (v == v') d; else f (r, d+1);fi;
end;
end;
esac;
put_lit_vals (r, d+1, instruction ! code);
};
end;
fun emitablock (LI_RECORD, ls, code)
=>
put_record (length ls) ! put_lit_vals (ls, 0, code);
emitablock (LI_VECTOR, ls, code)
=>
put_vector (length ls) ! put_lit_vals (ls, 0, code);
end;
fun put_f64block (ls, code)
=
put_raw64 (map ieee_float_constants::realconst ls) ! code;
fun put_i32block (ls, code)
=
put_raw32 ls ! code;
end; # fun put_lit_expression
end;
end;
############################################################################
# Lifting literals on highcode
############################################################################
# fun liftlits body = bug "highcode version currently not implemented yet"
#
# fun split_off_nextcode_literals (FK_FCT, f, [(v, t)], body) =
# if lt::uniqtypoid_is_package t then
# let my (nbody, lit, llt) = liftlits body
# nt = lt::make_package_uniqtypoid ((lt::unpack_package_uniqtypoid t)@[llt])
# in ((FK_FCT, f, [(v, nt)], body), lit)
# end
# else bug "unexpected highcode header in split_off_nextcode_literals (case 1)"
# | split_off_nextcode_literals _ = bug "unexpected highcode header in split_off_nextcode_literals (case 2)"
############################################################################
# Lifting literal on nextcode
############################################################################
Info
= ZZ_STRING String
| ZZ_FLOAT String
| ZZ_RECORD (ncf::Record_Kind, List( ncf::Value ))
;
exception LITERAL_INFO;
Rlit = RLIT (String, Unt);
fun to_rlit s
=
RLIT (s, hash_string::hash_string s);
fun from_rlit (RLIT (s, _))
=
s;
fun rlitcmp (RLIT (s1, i1), RLIT (s2, i2))
=
if (i1 < i2) LESS;
elif (i1 > i2) GREATER;
else string::compare (s1, s2);
fi;
package rlit_dictionary
=
red_black_map_g (
Key = Rlit;
compare = rlitcmp;
);
# Lifting all literals from a nextcode program:
#
fun liftlits (body, root, offset)
=
{ # The list of record, string, or float constants
#
my m: iht::Hashtable(Info) = iht::make_hashtable { size_hint => 32, not_found_exception => LITERAL_INFO };
my freevars: Ref( List( ncf::Codetemp ) ) = REF [];
fun addv x = (freevars := (x ! *freevars));
# Check if a ncf::Codetemp is used by the main program
#
my refset: intset::Intset = intset::new();
my used: ncf::Codetemp -> Void = intset::add refset;
my is_used: ncf::Codetemp -> Bool = intset::mem refset;
# memoize the information on which corresponds to what
fun enter (v, i)
=
{ iht::set m (v, i);
addv v;
};
fun const (ncf::CODETEMP v) => ({ iht::get m v; TRUE;} except _ = FALSE);
const (ncf::INT _ | ncf::INT1 _ | ncf::FLOAT64 _ | ncf::STRING _) => TRUE;
const _ => bug "unexpected case in const";
end;
fun cstlit (ncf::CODETEMP v) => ({ iht::get m v; TRUE;} except _ = FALSE);
cstlit (ncf::FLOAT64 _ | ncf::STRING _) => TRUE;
cstlit _ => FALSE;
end;
# Register a string literal:
#
stipulate
my strs: Ref( List( String ) ) = REF [];
my strs_n: Ref( Int ) = REF 0;
sdict = REF (rlit_dictionary::empty);
srtv = make_var();
srtval = ncf::CODETEMP srtv;
herein
fun typechecked_package_string s
=
{ v = make_var(); # Should hash to remove duplicates XXX BUGGO FIXME
sd = *sdict;
rlit = to_rlit s;
n =
case (rlit_dictionary::get (sd, rlit))
#
THE k => k;
#
_ => { (strs := (s ! *strs));
k = *strs_n;
(strs_n := (k+1));
(sdict := (rlit_dictionary::set (sd, rlit, k)));
k;
};
esac;
( ncf::CODETEMP v,
\\ next = ncf::GET_FIELD_I { i => n,
record => srtval,
to_temp => v,
type => ncf::bogus_pointer_type,
next
}
);
};
# old definition of typechecked_package_string
#
# let sd = *sdict
# rlit = toRlit s
# in (case RlitDict::peek (sd, rlit)
# of THE v => (ncf::CODETEMP v, ident)
# | _ => let v = make_var()
# (enter (v, ZZ_STRING s); used v)
# (sdict := RlitDict::set (sd, rlit, v))
# in (ncf::CODETEMP v, ident)
# end)
# end
fun apply_package ()
=
{ fun g (a ! r, z) => g (r, (ncf::STRING a) ! z);
g ([], z) => z; # Reverse to get correct order.
end;
all_strs = *strs;
case *strs
[] => ();
xs => { enter (srtv, ZZ_RECORD (ncf::rk::RECORD, g (xs,[])));
used srtv;
};
esac;
};
end; # stipulate
# * a special treatment of float constants
stipulate
my floats: Ref( List( String ) ) = REF [];
my floats_n: Ref( Int ) = REF 0;
rdict = REF (rlit_dictionary::empty);
rrtv = make_var();
rrtval = ncf::CODETEMP rrtv;
herein
fun typechecked_package_float s
=
{ v = make_var(); # Should hash to remove duplicates XXX BUGGO FIXME
rd = *rdict;
rlit = to_rlit s;
n = case (rlit_dictionary::get (rd, rlit))
THE k => k;
_ => { floats := (s ! *floats);
k = *floats_n;
floats_n := (k+1);
rdict := (rlit_dictionary::set (rd, rlit, k));
k;
};
esac;
( ncf::CODETEMP v,
\\ next = ncf::GET_FIELD_I { i => n,
record => rrtval,
to_temp => v,
type => ncf::typ::FLOAT64,
next
}
);
};
fun apply_float ()
=
{ fun g (a ! r, z) => g (r, (ncf::FLOAT64 a) ! z);
g ( [], z) => z; # reverse to reflecting the correct order
end;
all_floats = *floats;
case *floats
[] => ();
xs => { enter (rrtv, ZZ_RECORD (ncf::rk::FLOAT64_BLOCK, g (xs,[])));
used rrtv;
};
esac;
};
end; # stipulate of special treatment of float constants
# Translation on the nextcode values:
#
fun lpsv u
=
case u
#
ncf::FLOAT64 s => typechecked_package_float s;
ncf::STRING s => typechecked_package_string s;
#
ncf::CODETEMP v => { used v; (u, ident);};
_ => (u, ident);
esac;
fun lpvs vs
=
fold_backward g ([], ident) vs
where
fun g (u, (xs, hh))
=
{ my (nu, nh) = lpsv u;
(nu ! xs, nh o hh);
};
end;
# If all fields of a record are "constant", then we lift it:
#
fun field' ul
=
h (ul, [], FALSE)
where
fun h ((x, ncf::SLOT 0) ! r, z, rsflag)
=>
if (const x ) h (r, x ! z, rsflag or (cstlit x)); else NULL;fi;
h ([], z, rsflag) => if rsflag THE (reverse z); else NULL;fi;
h _ => bug "unexpected case in field";
end;
end;
# Register a constant record:
#
fun record (kind, ul, to_temp)
=
case (field' ul)
THE xl
=>
{ enter (to_temp, ZZ_RECORD (kind, xl));
ident;
};
NULL =>
{ fun g ((u, p as ncf::SLOT 0), (r, hh))
=>
{ my (nu, nh) = lpsv u;
((nu, p) ! r, nh o hh);
};
g _ => bug "unexpected non-zero ncf::SLOT in record";
end;
(fold_backward g ([], ident) ul) -> (fields, header);
\\ next = header (ncf::DEFINE_RECORD { kind, fields, to_temp, next });
};
esac;
# Register a wrapped float literal:
#
fun wrapfloat (u, to_temp, type)
=
if (const u)
#
enter (to_temp, ZZ_RECORD (ncf::rk::FLOAT64_BLOCK, [u]));
ident;
else
(lpsv u) -> (nu, hh);
#
\\ next = hh (ncf::PURE { op => ncf::p::WRAP_FLOAT64,
args => [nu],
to_temp,
type,
next
}
);
fi;
# Fetch literal information:
#
fun get_info ()
=
{ apply_float (); # Register all Floats as a record.
apply_package (); # Register all Strings as a record.
allvars = *freevars;
exports = list::filter is_used allvars;
toplit
=
g (exports, [])
where
fun g ([], z)
=>
LI_TOP z;
g (x ! r, z)
=>
case (iht::get m x)
#
ZZ_STRING s => g (r, (LI_STRING s) ! z);
_ => g (r, (LI_VAR x) ! z);
esac;
end;
end;
fun make_literal (v, lit)
=
{ fun un_float (ncf::FLOAT64 s) => s;
un_float _ => bug "unFLOAT";
end;
fun un_int1 (ncf::INT1 w) => w;
un_int1 _ => bug "unINT1";
end;
case (iht::get m v)
#
(ZZ_FLOAT _) # Float is wrapped.
=>
bug "currently we don't expect ZZ_FLOAT in make_literal";
# LI_F64BLOCK([s], v, lit)
(ZZ_STRING s)
=>
bug "currently we don't expect ZZ_STRING in make_literal";
# Lit --- or we could inline string:
#
(ZZ_RECORD (ncf::rk::FLOAT64_BLOCK, values))
=>
LI_F64BLOCK (map un_float values, v, lit);
(ZZ_RECORD (ncf::rk::INT1_BLOCK, values))
=>
LI_I32BLOCK (map un_int1 values, v, lit);
(ZZ_RECORD (rk, values))
=>
LI_BLOCK (rk2bk rk, map value_to_liternal values, v, lit);
esac;
};
# Build up the literal package:
#
lit = fold_forward make_literal toplit allvars;
n = length exports;
header
=
if (n == 0)
#
ident;
else
rv = make_var();
rval = ncf::CODETEMP rv;
rhdr = \\ next = ncf::GET_FIELD_I { i => offset,
record => root,
to_temp => rv,
type => ncf::typ::POINTER (ncf::RPT n),
next
};
fun make_header (v, (i, hh))
=
{ nh = case (iht::get m v)
#
(ZZ_RECORD (rk, vs))
=>
{ n = length vs;
type = case rk
#
ncf::rk::FLOAT64_BLOCK => ncf::typ::POINTER (ncf::FPT n);
ncf::rk::VECTOR => ncf::bogus_pointer_type;
_ => ncf::typ::POINTER (ncf::RPT n);
esac;
\\ next = ncf::GET_FIELD_I { i, record => rval, to_temp => v, type, next };
};
(ZZ_FLOAT _) => bug "ZZ_FLOAT in make_header";
# (\\ next =
# (ncf::GET_FIELD_I { i => i, record => rval, to_temp => w, type => ncf::typ::POINTER (FPT 1), next =>
# ncf::GET_FIELD_I { i => 0, record => ncf::CODETEMP w, to_temp => v, type => FLTT, next } } ) )
(ZZ_STRING s) => bug "ZZ_STRING in make_header";
# (\\ next =
# ncf::GET_FIELD_I { i, record => rval, to_temp => v, type => ncf::bogus_pointer_type, next } )
esac;
(i+1, hh o nh);
};
#2 (fold_backward make_header (0, rhdr) exports);
fi;
(lit, header);
}; # fun get_info
fun lpfn (fk, f, vl, cl, e) # "lpfn" may be "loop_fn"...?
=
(fk, f, vl, cl, loop e)
also
fun loop ce
=
case ce
#
ncf::DEFINE_RECORD { kind, fields, to_temp, next }
=> record ( kind, fields, to_temp) (loop next);
ncf::GET_FIELD_I { i, record, to_temp, type, next }
=>
{ (lpsv record) -> (record, hh);
#
hh (ncf::GET_FIELD_I { i, record, to_temp, type, next => loop next });
};
ncf::GET_ADDRESS_OF_FIELD_I _ => bug "unexpected ncf::GET_ADDRESS_OF_FIELD_I in loop";
ncf::TAIL_CALL { fn, args }
=>
{ (lpsv fn) -> (fn, h1);
(lpvs args) -> (args, h2);
#
h1 (h2 (ncf::TAIL_CALL { fn, args }));
};
ncf::DEFINE_FUNS { funs, next }
=>
ncf::DEFINE_FUNS { funs => map lpfn funs,
next => loop next
};
ncf::JUMPTABLE { i, xvar, nexts }
=>
{ (lpsv i) -> (i, hh);
hh (ncf::JUMPTABLE { i, xvar, nexts => map loop nexts });
};
ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
=>
{ (lpvs args) -> (args, hh);
#
hh (ncf::IF_THEN_ELSE { op, args, xvar, then_next => loop then_next, else_next => loop else_next });
};
ncf::STORE_TO_RAM { op, args, next }
=>
{ (lpvs args) -> (args, hh);
#
hh (ncf::STORE_TO_RAM { op, args, next => loop next });
};
ncf::FETCH_FROM_RAM { op, args, to_temp, type, next }
=>
{ (lpvs args) -> (args, hh);
#
hh (ncf::FETCH_FROM_RAM { op, args, to_temp, type, next => loop next });
};
ncf::ARITH { op, args, to_temp, type, next }
=>
{ (lpvs args) -> (args, hh);
#
hh (ncf::ARITH { op, args, to_temp, type, next => loop next });
};
ncf::PURE { op => ncf::p::WRAP_FLOAT64,
args => [arg],
to_temp,
type,
next
}
=>
wrapfloat (arg, to_temp, type) (loop next);
ncf::PURE { op, args, to_temp, type, next }
=>
{ (lpvs args) -> (args, hh);
#
hh (ncf::PURE { op, args, to_temp, type, next => loop next });
};
ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
=>
{ (lpvs args) -> (args, hh);
#
hh (ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next => loop next });
};
esac;
newbody = loop body;
my (lit, header) = get_info ();
(header newbody, lit);
};
# Main function:
#
fun split_off_nextcode_literals (fk, f, vl as [_, x], [cntt, t as ncf::typ::POINTER (ncf::RPT n)], body)
=>
{ nt = ncf::typ::POINTER (ncf::RPT (n+1));
#
(liftlits (body, ncf::CODETEMP x, n))
->
(nbody, lit);
((fk, f, vl, [cntt, nt], nbody), lit);
};
split_off_nextcode_literals _
=>
bug "unexpected nextcode header in split_off_nextcode_literals";
end;
}; # package make_nextcode_literals_bytecode_vector
end;