diff --git a/minproto.leg b/minproto.leg index 7dea560..520ab14 100644 --- a/minproto.leg +++ b/minproto.leg @@ -1,6 +1,6 @@ # minproto.leg -- minimal prototype langauge for semantic experiments # -# last edited: 2024-06-02 17:15:37 by piumarta on m1mbp +# last edited: 2024-06-13 14:47:05 by piumarta on zora %{ ; @@ -19,7 +19,7 @@ #endif #ifndef PRIMCLOSURE // Lambda and Closure are primitive types, not subtypes of Object -# define PRIMCLOSURE 0 // (approx. 6% performance decrease, because every Object_get() is slower) +# define PRIMCLOSURE 1 // (approx. 6% performance decrease, because every Object_get() is slower) #endif #ifndef DELOPT // delegate is a member of Object structure, not a normal property @@ -42,6 +42,10 @@ # define FOLDCONST 1 #endif +#ifndef PROFILE // include profiling support +# define PROFILE 0 +#endif + #include #include #include @@ -72,6 +76,7 @@ void fatal(char *fmt, ...); int opt_O = 0; int opt_d = 0; +int opt_p = 0; int opt_v = 0; union object; @@ -108,9 +113,9 @@ oop printOn(oop buf, oop obj, int indent); #endif #if PRIMCLOSURE -#define doProtos(_) _(Object) _(RefLocal) _(GetLocal) _(SetLocal) _(RefGlobal) _(GetGlobal) _(SetGlobal) _(RefVar) _(GetVar) _(SetVar) _(RefProp) _(GetProp) _(SetProp) _(RefArray) _(GetArray) _(SetArray) _(Call) _(Invoke) _(Super) _(Continue) _(Break) _(Return) _(TryCatch) _(TryEnsure)_(Raise)_(Binop) _(Unyop) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal) +#define doProtos(_) _(Object) _(RefLocal) _(GetLocal) _(SetLocal) _(RefGlobal) _(GetGlobal) _(SetGlobal) _(RefVar) _(GetVar) _(SetVar) _(RefProp) _(GetProp) _(SetProp) _(RefArray) _(GetArray) _(SetArray) _(GetSlice) _(Call) _(Invoke) _(Super) _(Continue) _(Break) _(Return) _(TryCatch) _(TryEnsure)_(Raise)_(Binop) _(Unyop) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal) #else -#define doProtos(_) _(Object) _(RefLocal) _(GetLocal) _(SetLocal) _(RefGlobal) _(GetGlobal) _(SetGlobal) _(RefVar) _(GetVar) _(SetVar) _(RefProp) _(GetProp) _(SetProp) _(RefArray) _(GetArray) _(SetArray) _(Call) _(Invoke) _(Super) _(Continue) _(Break) _(Return) _(TryCatch) _(TryEnsure) _(Raise) _(Binop) _(Unyop) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal) _(Lambda) _(Closure) +#define doProtos(_) _(Object) _(RefLocal) _(GetLocal) _(SetLocal) _(RefGlobal) _(GetGlobal) _(SetGlobal) _(RefVar) _(GetVar) _(SetVar) _(RefProp) _(GetProp) _(SetProp) _(RefArray) _(GetArray) _(SetArray) _(GetSlice) _(Call) _(Invoke) _(Super) _(Continue) _(Break) _(Return) _(TryCatch) _(TryEnsure) _(Raise) _(Binop) _(Unyop) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal) _(Lambda) _(Closure) #endif #define declareProto(NAME) oop p##NAME = 0; @@ -128,13 +133,13 @@ enum typecode { doTypes(makeProto); #undef makeProto -#define doProperties(_) _(name) _(eval) _(delegate) _(codeon) _(function) _(message) _(kind) _(owner) +#define doProperties(_) _(name) _(eval) _(delegate) _(codeon) _(function) _(message) _(kind) _(owner) _(profile) #define declareProp(NAME) oop prop_##NAME = 0; doProperties(declareProp); #undef declareProp -#define doSymbols(_) _(t) _(name) _(expr) _(function) _(arguments) _(object) _(index) _(key) _(value) _(self) _(method) _(parameters) _(body) _(lambda) _(environment) _(operation) _(full) _(condition) _(consequent) _(alternate) _(expression) _(identifier) _(initialise) _(update) _(first) _(last) _(fixed) _(keyvals) _(__namespaces__) _(O) _(d) _(v) _(statement) _(handler) _(kind) _(message) _(operand1) _(operand2) +#define doSymbols(_) _(t) _(name) _(expr) _(function) _(arguments) _(object) _(index) _(key) _(value) _(self) _(method) _(parameters) _(body) _(lambda) _(environment) _(operation) _(full) _(condition) _(consequent) _(alternate) _(expression) _(identifier) _(initialise) _(update) _(first) _(last) _(fixed) _(keyvals) _(__namespaces__) _(O) _(d) _(p) _(v) _(statement) _(handler) _(kind) _(message) _(operand1) _(operand2) _(profile) _(parent) _(count) _(stamp) _(time) _(start) _(stop) #define declareSym(NAME) oop sym_##NAME = 0; doSymbols(declareSym); @@ -188,9 +193,13 @@ struct Symbol { enum type type; char *name; oop value; enum typecode typec #else // !TYPECODES struct Symbol { enum type type; char *name; oop value; }; #endif +#if PROFILE +struct Primitive { enum type type; oop name; prim_t function; void *cookie; oop profile; int index; }; +#else struct Primitive { enum type type; oop name; prim_t function; void *cookie; int index; }; +#endif #if PRIMCLOSURE -struct Lambda { enum type type; oop parameters, body; }; +struct Lambda { enum type type; oop parameters, body, parent, name; }; struct Closure { enum type type; oop fixed, function, environment; }; #endif struct Object { enum type type; int isize, icap, psize; @@ -532,6 +541,28 @@ oop String_push(oop obj, oop val) // val is String OR Integer return val; } +void getSliceRange(oop obj, oop ostart, oop ostop, int len, int *pstart, int *pstop) +{ + int start = (nil == ostart) ? 0 : integerValue(ostart, "[:]"); + int stop = (nil == ostop ) ? len : integerValue(ostop, "[:]"); + if (start < 0) start += len; + if (start < 0 || start >= len) rangeError("[:]", "start index out of bounds", obj, start); + if (stop < 0) stop += len; + if (stop < 0 || stop > len) rangeError("[:]", "end index out of bounds", obj, stop); + *pstart = start; + *pstop = stop; +} + +void print(oop obj, int indent); + +oop String_slice(oop obj, oop ostart, oop ostop) +{ + int len = _get(obj, String,length), start, stop; + getSliceRange(obj, ostart, ostop, len, &start, &stop); + if (start >= stop) return newStringLen(0, 0); + return newStringLen(_get(obj, String,value) + start, stop - start); +} + oop newSymbol(char *name) { oop obj = make(Symbol); @@ -561,6 +592,20 @@ int stringLength(oop obj, char *who) return 0; } +oop intern(char *name); + +oop Symbol_slice(oop obj, oop ostart, oop ostop) +{ + char *name = _get(obj, Symbol,name); + int len = strlen(name), start, stop; + getSliceRange(obj, ostart, ostop, len, &start, &stop); + if (start >= stop) return intern(""); // ?!? + char buf[stop - start + 1]; + strncpy(buf, name + start, stop - start); + buf[stop - start] = 0; + return intern(buf); +} + oop Object_put(oop obj, oop key, oop val); oop Object_push(oop obj, oop val); @@ -572,6 +617,9 @@ oop newPrimitive(prim_t function, oop name) _set(obj, Primitive,name, name); _set(obj, Primitive,function, function); _set(obj, Primitive,cookie, 0); +# if PROFILE + _set(obj, Primitive,profile, nil); +# endif _set(obj, Primitive,index, _get(primitives, Object,isize)); Object_put(primitives, obj, newInteger(_get(primitives, Object,isize))); Object_push(primitives, obj); @@ -580,11 +628,16 @@ oop newPrimitive(prim_t function, oop name) #if PRIMCLOSURE -oop newLambda(oop parameters, oop body) +oop newLambda(oop parameters, oop body, oop parent, oop name) { oop obj = make(Lambda); _set(obj, Lambda,parameters, parameters); _set(obj, Lambda,body, body); +# if PROFILE + _set(obj, Lambda,profile, 0); +# endif + _set(obj, Lambda,parent, parent); + _set(obj, Lambda,name, name); return obj; } @@ -716,6 +769,8 @@ oop *Object_ref(oop obj, oop key) case Lambda: if (key == sym_parameters) return &_get(obj, Lambda,parameters); if (key == sym_body ) return &_get(obj, Lambda,body ); + if (key == sym_parent ) return &_get(obj, Lambda,parent ); + if (key == sym_name ) return &_get(obj, Lambda,name ); o = pLambda; break; case Closure: @@ -757,6 +812,8 @@ oop Object_getOwner(oop obj, oop key, oop *ownerp) case Lambda: if (key == sym_parameters) return _get(obj, Lambda,parameters); if (key == sym_body ) return _get(obj, Lambda,body ); + if (key == sym_parent ) return _get(obj, Lambda,parent ); + if (key == sym_name ) return _get(obj, Lambda,name ); o = pLambda; break; case Closure: @@ -798,6 +855,8 @@ oop Object_get(oop obj, oop key) case Lambda: if (key == sym_parameters) return _get(obj, Lambda,parameters); if (key == sym_body ) return _get(obj, Lambda,body ); + if (key == sym_parent ) return _get(obj, Lambda,parent ); + if (key == sym_name ) return _get(obj, Lambda,name ); o = pLambda; break; case Closure: @@ -884,6 +943,8 @@ oop Object_put(oop obj, oop key, oop val) case Lambda: if (key == sym_parameters ) { _set(obj, Lambda,parameters, val); return val; } if (key == sym_body ) { _set(obj, Lambda,body, val); return val; } + if (key == sym_parent ) { _set(obj, Lambda,parent, val); return val; } + if (key == sym_name ) { _set(obj, Lambda,name, val); return val; } break; case Closure: if (key == sym_fixed ) { _set(obj, Closure,fixed, val); return val; } @@ -942,6 +1003,15 @@ oop newObjectWith(int isize, oop *indexed, int psize, struct property *propertie return obj; } +oop Object_slice(oop obj, oop ostart, oop ostop) +{ + oop *indexed = _get(obj, Object,indexed); + int len = _get(obj, Object,isize), start, stop; + getSliceRange(obj, ostart, ostop, len, &start, &stop); + oop result = new(_getDelegate(obj)); + for (int i = start; i < stop; ++i) Object_push(result, indexed[i]); + return result; +} #if EXCEPTIONS @@ -1008,6 +1078,8 @@ oop keys(oop self, int all) case Lambda: { Object_push(keys, sym_parameters); Object_push(keys, sym_body); + Object_push(keys, sym_parent); + Object_push(keys, sym_name); break; } case Closure: { @@ -1980,6 +2052,39 @@ void SetArray_codeOn(oop exp, oop str, oop env) codeOn(str, Object_get(exp, sym_value), 0); } +oop newGetSlice(oop object, oop start, oop stop) +{ + oop o = new(pGetSlice); + Object_put(o, sym_object, object); + Object_put(o, sym_start, start ); + Object_put(o, sym_stop, stop ); + return o; +} + +oop GetSlice_eval(oop exp, oop env) +{ + oop obj = eval(Object_get(exp, sym_object), env); + oop start = eval(Object_get(exp, sym_start ), env); + oop stop = eval(Object_get(exp, sym_stop ), env); + switch (getType(obj)) { + case String: return String_slice(obj, start, stop); + case Symbol: return Symbol_slice(obj, start, stop); + case Object: return Object_slice(obj, start, stop); + default: typeError("[:]", "non-indexable object", obj); + } + return nil; +} + +void GetSlice_codeOn(oop exp, oop str, oop env) +{ + codeOn(str, Object_get(exp, sym_object), 0); + String_appendAll(str, "["); + codeOn(str, Object_get(exp, sym_start ), 0); + String_appendAll(str, ":"); + codeOn(str, Object_get(exp, sym_stop ), 0); + String_appendAll(str, "]"); +} + oop newCall(oop function, oop arguments) { oop o = new(pCall); @@ -2273,11 +2378,16 @@ void Raise_codeOn(oop exp, oop str, oop env) #if !PRIMCLOSURE -oop newLambda(oop parameters, oop body) +oop newLambda(oop parameters, oop body, oop parent, oop name) { oop o = new(pLambda); - Object_put(o, sym_parameters, parameters); - Object_put(o, sym_body , body ); + Object_put(o, sym_parameters, parameters ); + Object_put(o, sym_body , body ); +# if PROFILE + Object_put(o, sym_profile , nil ); +# endif + Object_put(o, sym_parent , parent ); + Object_put(o, sym_name , name ); return o; } @@ -2289,11 +2399,6 @@ oop newClosure(oop function, oop environment) return o; } -int isClosure(oop obj) -{ - return is(Object, obj) && pClosure == _getDelegate(obj); -} - oop Lambda_eval(oop exp, oop env) { return newClosure(exp, env); @@ -2315,6 +2420,11 @@ void Closure_codeOn(oop exp, oop str, oop env) printOn(str, exp, 0); } +int isClosure(oop obj) +{ + return is(Object, obj) && pClosure == _getDelegate(obj); +} + #endif // !PRIMCLOSURE #define doBinops(_) \ @@ -3275,10 +3385,10 @@ stmt = WHILE LPAREN c:expr RPAREN s:stmt { $$ = newWhile(c, s) } | ENSURE e:stmt { $$ = newTryEnsure(t, e) } ) | RAISE e:expr EOS { $$ = newRaise(e) } - | LOCAL i:id p:params b:block { $$ = newSetLocal (i, newLambda(p, b)) } - | GLOBAL i:id p:params b:block { $$ = newSetGlobal(i, newLambda(p, b)) } - | i:id p:params b:block { $$ = newSetVar (i, newLambda(p, b)) } - | v:proto DOT i:id p:params b:block { $$ = newSetProp(v, i, newLambda(p, b)) } + | LOCAL i:id p:params b:block { $$ = newSetLocal (i, newLambda(p, b, nil, i)) } + | GLOBAL i:id p:params b:block { $$ = newSetGlobal(i, newLambda(p, b, nil, i)) } + | i:id p:params b:block { $$ = newSetVar (i, newLambda(p, b, nil, i)) } + | v:proto DOT i:id p:params b:block { $$ = newSetProp(v, i, newLambda(p, b, v, i)) } | b:block { $$ = newBlock(b) } | e:expr EOS { $$ = e } @@ -3352,7 +3462,16 @@ prefix = PPLUS p:prefix { $$ = newBinop(opPreAdd, lvalue postfix = SUPER DOT i:id a:args { $$ = newSuper(i, a) } | p:primary - ( LBRAK e:expr RBRAK { p = newGetArray(p, e) } + ( LBRAK + ( COLON ( RBRAK { p = newGetSlice(p, nil, nil) } + | e:xexpr RBRAK { p = newGetSlice(p, nil, e) } + ) + | s:xexpr ( COLON ( RBRAK { p = newGetSlice(p, s, nil) } + | e:xexpr RBRAK { p = newGetSlice(p, s, e) } + ) + | RBRAK { p = newGetArray(p, s) } + ) + ) | DOT i:id ( a:args !LBRACE { p = newInvoke(p, i, a) } | { p = newGetProp(p, i) } ) @@ -3383,9 +3502,9 @@ params = LPAREN p:mkobj mkobj = { $$ = new(pObject) } -primary = nil | number | string | symbol | var | lambda | subexpr | literal +primary = nil | number | string | symbol | var | lambda | subexpr | literal # | regex -lambda = p:params b:block { $$ = newLambda(p, b) } +lambda = p:params b:block { $$ = newLambda(p, b, nil, nil) } subexpr = LPAREN e:expr RPAREN { $$ = e } | b:block { $$ = newBlock(b) } @@ -3434,6 +3553,33 @@ var = LOCAL i:id { $$ = newGetLocal (i) } id = < LETTER ALNUM* > - { $$ = intern(yytext) } +# regex = SLASH a:alts SLASH { $$ = a } + +# alts = s:seq ( OR t:seq { s = Alt_append(t) } +# )* { $$ = s } + +# seq = p:pre ( q:pre { s = Seq_append(t) } +# )* { $$ = s } + +# elt = action | pre + +# action = b:block { $$ = newAction(b) } + +# pre = PLING p:pre { $$ = newNot(p) } +# | AND p:pre { $$ = newAnd(p) } +# | post + +# post = a:atom ( STAR { a = newMany(a) } +# | PLUS { a = newMore(a) } +# | QUERY { a = newMore(a) } +# )? { $$ = a } + +# atom = DOT { $$ = newDot() } +# | "[" ( !"]" "\\"? . )* "]" - { $$ = newClass(yytext) } +# | '"' xxxxxx + +# class = LBRAK + BIGIT = [0-1] OIGIT = [0-7] DIGIT = [0-9] @@ -3520,29 +3666,97 @@ error = - < (!EOL .)* > xexpr = expr | error @{ expected("expression", yytext) } -%%; +%% +; + +#if PROFILE -#define SEND(RCV, MSG) ({ \ - oop _rcv = RCV; \ - oop _fun = Object_get(_rcv, sym_##MSG); \ - get(_fun, Primitive,function)(_fun, _rcv, nil, nil); \ - }) +oop *profiles = 0; +int nprofiles = 0; + +oop profileInit(oop function) +{ + profiles = xrealloc(profiles, sizeof(*profiles) * (nprofiles + 1)); + oop p = profiles[nprofiles++] = new(pObject); + Object_put(p, sym_function, function); + Object_put(p, sym_count, newInteger(0)); + Object_put(p, sym_stamp, newInteger(0)); + Object_put(p, sym_time, newInteger(0)); + return p; +} + +#include + +long uclock(void) +{ + struct rusage ru; + getrusage(RUSAGE_SELF, &ru); + return ru.ru_utime.tv_sec * 1000000 + ru.ru_utime.tv_usec; +} + +void profileTick(oop p) +{ + oop *ref = Object_refLocal(p, sym_count); if (!ref) fatal("profile data lost: count"); + long count = _integerValue(*ref); + *ref = newInteger(count + 1); + ref = Object_refLocal(p, sym_stamp); if (!ref) fatal("profile data lost: stamp"); + //*ref = newInteger(clock()); + *ref = newInteger(uclock()); +} -oop sym_x = 0; -oop sym_y = 0; +void profileTock(oop p) +{ + //long ticks = clock() - _integerValue(Object_getLocal(p, sym_stamp)); + long ticks = uclock() - _integerValue(Object_getLocal(p, sym_stamp)); + oop *timep = Object_refLocal(p, sym_time ); if (!timep) fatal("profile data lost: time"); + ticks += _integerValue(*timep); + *timep = newInteger(ticks); +} -oop Point_magnitude(oop func, oop self, oop args, oop env) +void profileReport(void) { - double x = floatValue(Object_get(self, sym_x), "Point.magnitude"); - double y = floatValue(Object_get(self, sym_y), "Point.magnitude"); - return newFloat(sqrt(x * x + y * y)); + printf("%7s %7s function\n", "count", "msecs"); + for (int i = 0; i < nprofiles; ++i) { + oop prof = profiles[i]; + oop func = Object_getLocal(prof, sym_function); + long count = _integerValue(Object_getLocal(prof, sym_count )); + long ticks = _integerValue(Object_getLocal(prof, sym_time )); + printf("%7ld ", count); + //printf("%7ld ", (long)(1000. * ticks / CLOCKS_PER_SEC)); + printf("%7ld ", ticks); + if (is(Primitive, func)) { + printf("%s\n", printString(func, 0)); + continue; + } + oop parent = Object_getLocal(func, sym_parent); + oop name = Object_getLocal(func, sym_name); + if (nil != parent) printf("%s.", codeString (parent, 0)); + if (nil != name ) printf("%s", printString(name, 0)); + else printf("[anonymous function]"); + printf("\n"); + } } +#endif + oop apply(oop func, oop self, oop args, oop env, oop owner) { int functype = getType(func); - if (Primitive == functype) - return _get(func, Primitive,function)(func, self, args, env); + if (Primitive == functype) { +# if PROFILE + oop profile = nil; + if (opt_p) { + profile = _get(func, Primitive,profile); + if (nil == profile) profile = _set(func, Primitive,profile, profileInit(func)); + profileTick(profile); + } +# endif + oop result = _get(func, Primitive,function)(func, self, args, env); +# if PROFILE + if (opt_p) profileTock(profile); +# endif + return result; + } #if PRIMCLOSURE if (Closure != functype) valueError(nil == self ? "()" : ".()", "cannot apply", func); @@ -3557,6 +3771,14 @@ oop apply(oop func, oop self, oop args, oop env, oop owner) oop environment = Object_get(func, sym_environment); oop parameters = Object_get(lambda, sym_parameters); oop body = Object_get(lambda, sym_body); +# if PROFILE + oop profile = nil; + if (opt_p) { + profile = Object_getLocal(lambda, sym_profile); + if (nil == profile) profile = Object_put(lambda, sym_profile, profileInit(lambda)); + profileTick(profile); + } +# endif #endif oop *exprs = get(body, Object,indexed); int size = _get(body, Object,isize); @@ -3591,6 +3813,9 @@ oop apply(oop func, oop self, oop args, oop env, oop owner) result = eval(exprs[i], args); # if NONLOCAL nlrPop(); +# endif +# if PROFILE + if (opt_p) profileTock(profile); # endif return result; } @@ -3621,6 +3846,7 @@ enum typecode getTypecode(oop exp) #define defineEval(NAME) \ static inline oop prim_##NAME##_eval(oop func, oop exp, oop args, oop env) { \ + if (_get(args,Object,isize) >= 1) env = Object_at(args, 0); \ return NAME##_eval(exp, env); \ } @@ -3652,7 +3878,9 @@ static inline oop evalobj(oop exp, oop env) oop owner = nil; oop evaluator = Object_getOwner(exp, prop_eval, &owner); - return apply(evaluator, exp, new(pObject), env, owner); + oop args = new(pObject); + Object_push(args, env); + return apply(evaluator, exp, args, env, owner); } long evaluations = 0; @@ -4070,7 +4298,7 @@ oop prim_print(oop func, oop self, oop args, oop env) int indent = isInteger(full) ? _integerValue(full) : nil != full; for (int i = 0; i < argc; ++i) print(result = indexed[i], indent); fflush(stdout); - return nil; + return result; } oop prim_codeString(oop func, oop self, oop args, oop env) @@ -4212,6 +4440,7 @@ oop prim_Symbol_setopt(oop func, oop self, oop args, oop env) int optval = _integerValue(val); if (sym_O == self) opt_O = optval; else if (sym_d == self) opt_d = optval; + else if (sym_p == self) opt_p = optval; else if (sym_v == self) opt_v = optval; else valueError("Symbol.setopt", "unknown option", val); return val; @@ -4221,6 +4450,7 @@ oop prim_Symbol_getopt(oop func, oop self, oop args, oop env) { assert(is(Symbol, self)); if (sym_O == self) return newInteger(opt_O); else if (sym_d == self) return newInteger(opt_d); + else if (sym_p == self) return newInteger(opt_p); else if (sym_v == self) return newInteger(opt_v); else valueError("Symbol.getopt", "unknown option", self); return 0; @@ -4544,7 +4774,12 @@ oop replPath(char *path) return result; } - +void cleanup(void) +{ +# if PROFILE + if (opt_p) profileReport(); +# endif +} int main(int argc, char **argv) { @@ -4683,6 +4918,7 @@ int main(int argc, char **argv) switch (*arg) { case 'O': ++opt_O; continue; case 'd': ++opt_d, ++opt_v; continue; + case 'p': ++opt_p; continue; case 'v': ++opt_v; continue; default: fatal("unknown command-line option '%c'", *arg); } @@ -4693,6 +4929,8 @@ int main(int argc, char **argv) for (int i = argn; i < argc; ++i) Object_push(args, newString(argv[i])); + atexit(cleanup); + if (argn == argc) replFile(stdin); else