123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772 |
- /* Definitions for the bytecode compiler.
- This file is part of khipu.
- khipu is free software: you can redistribute it and/or modify
- it under the terms of the GNU Lesser General Public License as published by
- the Free Software Foundation; either version 3 of the License, or
- (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU Lesser General Public License for more details.
- You should have received a copy of the GNU Lesser General Public License
- along with this program. If not, see <https://www.gnu.org/licenses/>. */
- #include <cstdlib>
- #include <cstdio>
- #include <climits>
- #include <vector>
- #include "khipu.hpp"
- #include "utils/sorted_list.hpp"
- #include "utils/raw_acc.hpp"
- KP_DECLS_BEGIN
- // Special instruction used to refer to labels in the code.
- static const int OP_LABEL = 0x100;
- #define OPX_(opc) (EXTRA_BIT | (fixint ((int)OP_##opc)))
- /* Opcodes that follow OP_VARGC are defined as pairs, the second one being
- * the 'long' form. This means that computing the long form of an instruction
- * is very simple. */
- static object
- make_lform (object inst)
- {
- return ((inst & ~EXTRA_BIT) + (fixint (1) | EXTRA_BIT));
- }
- struct xcmp_call
- {
- interpreter *ip;
- int operator() (intptr_t left, intptr_t right) const
- {
- auto i1 = itype (left), i2 = itype (right);
- if (i1 == i2)
- {
- auto rv = xcmp (this->ip, (object)left, (object)right);
- if (!rv.error_p ())
- return (deref (rv));
- this->ip->reset_exc ();
- }
- return ((int)(i1 - i2));
- }
- };
- struct whl_block
- {
- int top_lbl;
- int end_lbl;
- int stkpos;
- uint32_t exc_cnt;
- uint32_t n_dbinds;
- whl_block *next;
- };
- struct bitmap
- {
- raw_acc<array> bmap;
- size_t nelem;
- static const uint32_t NBITS = sizeof (uintptr_t) * 8;
- bitmap () : bmap (1)
- {
- *this->ptr() = 0;
- this->nelem = 0;
- }
- uint32_t& len ()
- {
- return (this->bmap.ptr->len_ref ());
- }
- object* ptr ()
- {
- return (this->bmap.ptr->data_ptr ());
- }
- void expand (uint32_t nl)
- {
- this->bmap.expand (nl);
- if (nl > this->len ())
- {
- memset (this->ptr () + this->len (), 0, (nl - this->len ()) * 8);
- this->len() = nl;
- }
- }
- bool set (uintptr_t bit)
- {
- uint32_t idx = (uint32_t)(bit / NBITS + 1);
- this->expand (idx);
- if (this->ptr()[--idx] & (uintptr_t)1 << (bit % NBITS))
- return (false);
- this->ptr()[idx] |= (uintptr_t)1 << (bit % NBITS);
- ++this->nelem;
- return (true);
- }
- bool get (uintptr_t bit)
- {
- uint32_t idx = (uint32_t)(bit / NBITS);
- if (idx > this->len ())
- return (false);
- return ((this->ptr()[idx] & ((uintptr_t)1 << (bit % NBITS))) != 0);
- }
- };
- /* The bytecode compiler receives an expression read from a stream and
- * produces a bvector that can be executed by the interpreter. Compilation is
- * split into several passes:
- *
- * - Macro expansion: The original expression is recursively expanded, but
- * only at the outermost level.
- *
- * - Symbolic code generation: After the outermost form has been expanded,
- * the compiler generates the instructions defined by the OPX_ macros, and
- * does some piecemeal optimizations here and there. Every inner form is
- * macroexpanded before being compiled.
- *
- * - Bytecode output: The symbolic instructions are transformed into bytecode.
- * Depending on the size, long versions of the instructions may be emitted.
- *
- * - Label fixing: With the bytecode finished, the placeholders used as labels
- * are replaced by correct offsets.
- */
- struct bc_compiler
- {
- enum
- {
- flg_toplevel = 0x01,
- flg_warnings = 0x02,
- flg_incatch = 0x04
- };
- struct frame_data
- {
- int nargs = 0;
- int stkdisp = 0;
- int acc = 0;
- size_t *ipp = nullptr;
- frame_data *next = nullptr;
- };
- struct whl_handler
- {
- bc_compiler& bc;
- whl_handler (bc_compiler& ebc, whl_block *wp) : bc (ebc)
- {
- this->bc.push_whl (wp);
- }
- ~whl_handler ()
- {
- this->bc.pop_whl ();
- }
- };
- struct frame_vec
- {
- frame_data *head = nullptr;
- int size = 0;
- void push (const frame_data& fd)
- {
- frame_data *f = (frame_data *)xmalloc (sizeof (*f));
- *f = fd;
- f->next = this->head;
- this->head = f;
- ++this->size;
- }
- void pop ()
- {
- frame_data *top = this->head;
- this->head = top->next;
- xfree (top);
- --this->size;
- }
- frame_data& top ()
- {
- return (*this->head);
- }
- const frame_data& top () const
- {
- return (*this->head);
- }
- frame_data& operator[] (int ix)
- {
- frame_data *runp = this->head;
- for (int i = this->size - ix - 1; i > 0; --i, runp = runp->next) ;
- return (*runp);
- }
- ~frame_vec ()
- {
- for (auto runp = this->head; runp; )
- {
- auto tmp = runp->next;
- xfree (runp);
- runp = tmp;
- }
- }
- };
- typedef sorted_list<xcmp_call> ctable_t;
- typedef std::vector<object> codevec_t;
- sp_guard spg;
- interpreter *interp;
- ctable_t ctable;
- codevec_t code;
- int lbl_cnt = 0;
- raw_acc<bvector> bytecode;
- object ct_env;
- struct
- {
- cons expr;
- symbol sym;
- string name;
- unsigned char sn[2];
- } xdo;
- whl_block *whl = nullptr;
- frame_vec frames;
- uint32_t rflags = 0;
- uint32_t exc_depth = 0;
- uint32_t n_dbinds = 0;
- int min_argc;
- int max_argc;
- object ldargs[4];
- bc_compiler *bprev = nullptr;
- bitmap captures;
- sorted_list<> capt_idx;
- bc_compiler (interpreter *ip, uint32_t iflags = 0) :
- spg (ip), interp (ip), bytecode (16)
- {
- this->xdo.expr.car = UNBOUND;
- this->ct_env = NIL;
- this->ctable.cmp.ip = ip;
- this->rflags |= iflags;
- this->ldargs[0] = this->ldargs[1] = this->ldargs[2] = UNBOUND;
- frame_data fr;
- fr.stkdisp = interpreter::frame_size;
- this->frames.push (fr);
- }
- struct insertp_handler
- {
- bc_compiler *bp;
- size_t ipoint;
- size_t f0;
- size_t f1;
- insertp_handler (bc_compiler& b) : bp (&b)
- {
- this->ipoint = this->bp->code.size ();
- this->f0 = this->f1 = this->bp->frames.size - 1;
- bool got = false;
- while (true)
- {
- auto& fr = this->bp->frames[this->f0];
- if (fr.ipp)
- break;
- fr.ipp = &this->ipoint;
- got = true;
- if (!this->f0)
- break;
- --this->f0;
- }
- if (!got)
- this->bp = nullptr;
- else
- ++this->f1;
- }
- ~insertp_handler ()
- {
- if (!this->bp)
- return;
- for (; this->f0 < this->f1; ++this->f0)
- this->bp->frames[this->f0].ipp = nullptr;
- }
- };
- int cur_stkpos () const
- {
- const auto& f = this->frames.top ();
- return (f.acc + f.nargs + f.stkdisp);
- }
- void push_f ()
- {
- frame_data fr;
- fr.acc = this->cur_stkpos ();
- this->frames.push (fr);
- }
- void pop_f ()
- {
- this->frames.pop ();
- }
- frame_data& cur_f ()
- {
- return (this->frames.top ());
- }
- int next_label ()
- { // Return a symbolic value for the next label.
- return (this->lbl_cnt++);
- }
- void mark_label (int lbl)
- {
- this->code.push_back (OPX_(LABEL));
- this->code.push_back (fixint (lbl));
- }
- void push_whl (whl_block *wp)
- {
- wp->top_lbl = this->next_label ();
- wp->end_lbl = this->next_label ();
- wp->stkpos = this->cur_stkpos ();
- wp->exc_cnt = this->exc_depth;
- wp->n_dbinds = this->n_dbinds;
- wp->next = this->whl;
- this->whl = wp;
- }
- void pop_whl ()
- {
- this->whl = this->whl->next;
- }
- int index (object val)
- {
- auto np = this->ctable.add (val);
- if (np->val == -1)
- np->val = this->ctable.len () - 1;
- return ((int)np->val);
- }
- object idxvec (object out)
- {
- for (ctable_t::iterator it (this->ctable); it.valid (); ++it)
- xaref(out, it.val ()) = it.key ();
- as_array(out)->len = this->ctable.len ();
- as_array(out)->vo_full |= array::nonref_flag;
- return (out);
- }
- result<object> idxvec ()
- {
- object ret = KP_TRY (alloc_array (this->interp, this->ctable.len ()));
- if (this->ctable.len ())
- this->idxvec (ret);
- return (ret);
- }
- cons* expr_do ()
- {
- if (this->xdo.expr.car != UNBOUND)
- return (&this->xdo.expr);
- this->xdo.sn[0] = 'd';
- this->xdo.sn[1] = 'o';
- this->xdo.name.vo_type = typecode::STR;
- this->xdo.name.data = this->xdo.sn;
- this->xdo.name.len = this->xdo.name.nbytes = 2;
- this->xdo.sym.vo_type = typecode::SYMBOL;
- this->xdo.sym.name = this->xdo.name.as_obj ();
- this->xdo.sym.value = this->xdo.sym.pkg = UNBOUND;
- this->xdo.expr.car = this->xdo.sym.as_obj ();
- this->xdo.expr.cdr = NIL;
- return (&this->xdo.expr);
- }
- int bc_len () const
- {
- return (as_bvector(this->bytecode.as_obj ())->nbytes);
- }
- template <typename T>
- void bytecode_write (T code)
- {
- this->bytecode.add_data (&code, sizeof (code));
- }
- void emit (object inst, object *argp, int nargs);
- template <typename ...Args>
- void emit (object inst, Args... args)
- {
- object lst[] = { args..., 0};
- this->emit (inst, lst, (int)KP_NELEM (lst) - 1);
- }
- void restore_exc (uint32_t n)
- {
- for (; n; --n)
- this->emit (OPX_(TRYEND));
- if (this->rflags & flg_incatch)
- this->emit (OPX_(CLREXC));
- }
- void unwind_state (whl_block *wlp)
- {
- this->restore_exc (this->exc_depth - wlp->exc_cnt);
- if (this->n_dbinds > wlp->n_dbinds)
- this->emit (OPX_(UNBIND), fixint (this->n_dbinds - wlp->n_dbinds));
- uint32_t diff = this->cur_stkpos () - wlp->stkpos;
- if (diff > 0)
- this->emit (OPX_(SKIP), fixint (diff));
- }
- void erase (codevec_t::iterator it)
- {
- this->code.erase (it);
- this->ldargs[0] = UNBOUND;
- }
- void erase (codevec_t::iterator i1, codevec_t::iterator i2)
- {
- this->code.erase (i1, i2);
- this->ldargs[0] = UNBOUND;
- }
- bvector* encode (bool release);
- object encode ();
- struct operation_set
- {
- object local;
- object closure;
- object global;
- object boxed;
- object dynamic;
- bool write;
- };
- result<int> compile_sym (object env, bool tail, object s,
- const operation_set& ops);
- result<int> compile_atom (object env, bool tail, object expr,
- bool quoted = false);
- result<int> compile_cond (object env, bool tail,
- object expr, bool popa = true);
- result<int> compile_if (object env, bool tail, object expr);
- result<int> compile_do (object env, bool tail, object forms);
- result<int> compile_while (object env, object cond, object body);
- result<int> compile_short_circuit (object env, bool tail, object forms,
- object dfl, object branch);
- result<int> compile_and (object env, bool tail, object forms)
- {
- return (this->compile_short_circuit (env, tail, forms,
- symbol::t, OPX_(JMPN)));
- }
- result<int> compile_or (object env, bool tail, object forms)
- {
- return (this->compile_short_circuit (env, tail, forms,
- NIL, OPX_(JMPT)));
- }
- result<int> compile_arglist (object env, object expr,
- int off = 1, int nmax = INT_MAX);
- result<int> compile_app (object env, bool tail, object expr);
- result<bool> compile_seq (object env, bool tail, object expr);
- result<void> compile_try (object env, bool tail, object expr);
- result<int> compile_in (object env, bool tail, object expr);
- result<void> emit_optargs_init (object env, object opta, object vars, int idx);
- result<object> compile_fct (object env, object expr);
- result<object> compile_fct_body (object env, object expr, uint32_t flags = 0);
- result<int> compile_let (object env, bool tail, object expr);
- int last_idx () const
- {
- for (int i = (int)this->code.size () - 1; i >= 0; --i)
- if ((this->code[i] & EXTRA_BIT) && this->code[i] != OPX_(LABEL))
- return (i);
- return (-1);
- }
- result<void> warn_helper (stream *sp, object msg)
- {
- KP_VTRY (sp->write (this->interp, ";; warning: ", 12),
- sp->write (this->interp, str_cdata (msg), as_str(msg)->nbytes),
- sp->write (this->interp, "\n\n", 2),
- sp->flush (this->interp));
- return (0);
- }
- void test_nargs_fct (object obj, object env, int nargs);
- };
- #define BC_WARN(Comp, ...) \
- do \
- { \
- auto pm = KP_SPRINTF ((Comp).interp, __VA_ARGS__); \
- if (!pm.error_p ()) \
- { \
- valref msg ((Comp).interp, deref (pm)); \
- stream *sp = as_stream (err_stream); \
- if (sp->io_flags & STRM_NOLOCK) \
- deref ((Comp).warn_helper (sp, *msg)); \
- else \
- { \
- lock_guard g ((Comp).interp, as_lock (sp->ilock)); \
- deref ((Comp).warn_helper (sp, *msg)); \
- } \
- } \
- } \
- while (false)
- static bool
- equal_opcodes (object i1, const object *p1, const object *p2, int n)
- {
- if (i1 != *p2++)
- return (false);
- for (int i = 0; i < n; ++i)
- if (*p1++ != *p2++)
- return (false);
- return (true);
- }
- struct ldarg_reset
- {
- object* dstp;
- ldarg_reset (object *head) : dstp (head) {}
- ~ldarg_reset ()
- {
- if (this->dstp)
- *this->dstp = UNBOUND;
- }
- };
- void bc_compiler::emit (object inst, object *argp, int nargs)
- {
- auto& cv = this->code;
- ldarg_reset lr (&this->ldargs[0]);
- if (inst == OPX_(CAR) && !cv.empty () && cv.back () == OPX_(CDR))
- { // Transform (car (cdr $expr)) into (cadr $expr)
- cv.back() = OPX_(CADR);
- return;
- }
- else if (cv.size () >= 2 && make_lform (cv[cv.size () - 2]) == OPX_(SKIPL))
- {
- if (inst == OPX_(RET))
- { // Remove unnecessary 'skip' if it's followed by a ret.
- cv.erase (cv.end () - 2);
- cv.back() = inst;
- return;
- }
- else if (make_lform (inst) == OPX_(SKIPL))
- { // Condense multiple 'skip' forms into a single one.
- if (as_int (cv.back () += *argp) > 0xff)
- cv[cv.size () - 2] = OPX_(SKIPL);
- return;
- }
- }
- else if (inst == OPX_(RET) && !cv.empty () && cv.back () == inst)
- // Redundant 'ret'.
- return;
- if (inst == OPX_(POP) && cv.size () >= 2)
- {
- if (make_lform (cv[cv.size () - 2]) == OPX_(SETAL))
- {
- cv[cv.size () - 2] += fixint (OP_SETAPOP - OP_SETA);
- return;
- }
- else
- {
- int ix = this->last_idx ();
- if (ix >= 0 && (cv[ix] == OPX_(LOADT) || cv[ix] == OPX_(LOADNIL)))
- {
- if (ix >= 4 && cv[ix - 2] == OPX_(LABEL) &&
- cv[cv.size () - 2] == cv[ix - 2] &&
- bcode_get(as_int (cv[ix - 4]))->branch_p () &&
- cv[ix - 3] == cv[ix + 2])
- { /* Common pattern:
- * branch L1
- * ...
- * jmp L2
- * L1: loadnil
- * L2: pop
- * ...
- *
- * Such bytecode can be generated by non-tail 'if' forms
- * without an 'else' clause. We optimize by rearranging
- * the label L1 to point forward and avoid the redundant
- * loadnil+pop instruction:
- *
- * branch L1
- * ...
- * pop
- * L1: ...
- */
- int lbl = as_int (cv[ix - 1]);
- cv.erase (cv.begin () + ix - 2, cv.begin () + ix + 1);
- this->emit (OPX_(POP));
- this->mark_label (lbl);
- }
- else
- // Eliminate the loadK+pop sequence.
- cv.erase (cv.begin () + ix);
- return;
- }
- }
- }
- else if (inst == OPX_(LOADV) || inst == OPX_(LOADG) ||
- inst == OPX_(SETG) || inst == OPX_(LOADX) || inst == OPX_(BIND))
- *argp = fixint (this->index (*argp));
- {
- const bcode_instr *instrp = bcode_get (as_int (inst) + 1);
- if (instrp->long_p ())
- for (int ix = 0; ix < instrp->nops (); ++ix)
- if ((inst == OPX_(LOADI8) && (as_int (argp[ix]) >= 0x80 ||
- as_int (argp[ix]) < -128)) ||
- as_int (argp[ix]) > 0xff)
- {
- inst = make_lform (inst); // Convert to long form.
- break;
- }
- }
- // Try to optimize load instruction.
- if (inst == OPX_(LOADA) && as_int (*argp) <= 1)
- {
- nargs = 0;
- inst = *argp == fixint (0) ? OPX_(LOADA0) : OPX_(LOADA1);
- }
- else if (inst == OPX_(LOADC) && as_int (*argp) == 0)
- {
- if (as_int (argp[1]) <= 1)
- {
- nargs = 0;
- inst = argp[1] == fixint (0) ? OPX_(LOADC00) : OPX_(LOADC01);
- }
- else
- {
- nargs = 1;
- *argp = argp[1];
- inst = OPX_(LOADC0);
- }
- }
- else if (inst == OPX_(SETC) && as_int (*argp) == 0)
- {
- nargs = 1;
- *argp = argp[1];
- inst = OPX_(SETC0);
- }
- object lasti = cv.empty () ? UNBOUND : cv.back ();
- // Try to optimize branching instruction.
- if (inst == OPX_(BRN))
- {
- if (lasti == OPX_(NOT))
- {
- if (cv.size () > 2 && cv[cv.size () - 2] == lasti)
- {
- cv.pop_back ();
- cv.back() = OPX_(BRN);
- }
- else
- cv.back() = OPX_(BRT);
- cv.push_back (*argp);
- }
- else if (lasti == OPX_(IS))
- {
- cv.back() = OPX_(BRNEQ);
- cv.push_back (*argp);
- }
- else
- {
- cv.push_back (inst);
- cv.push_back (*argp);
- }
- }
- else if (inst == OPX_(BRT) && lasti == OPX_(NOT))
- {
- cv.back() = OPX_(BRN);
- cv.push_back (*argp);
- }
- else
- {
- lr.dstp = nullptr;
- if (bcode_get(as_int (inst))->loadf_p () && (nargs > 0 ||
- inst == OPX_(LOADC00) || inst == OPX_(LOADC01)) &&
- equal_opcodes (inst, argp, this->ldargs, nargs))
- {
- cv.push_back (OPX_(DUP));
- return;
- }
- cv.push_back (inst);
- for (int i = 0; i < nargs; ++i)
- cv.push_back (argp[i]);
- this->ldargs[0] = inst;
- copy_objs (this->ldargs + 1, argp, nargs);
- }
- }
- static inline int
- label_get (bool large, const uint8_t *ip)
- {
- return (large ? get32 (ip) : (int16_t)get16 (ip));
- }
- static inline int
- label_size (bool large)
- {
- return (large ? sizeof (int32_t) : sizeof (int16_t));
- }
- static inline void
- label_put (bool large, uint8_t *ip, uint32_t val)
- {
- if (large)
- put32 (ip, val);
- else
- put16 (ip, val);
- }
- static int
- lastjmp (const uint8_t *ip, int off, bool large, int first)
- {
- for (int ijmp = large ? OP_JMPL : OP_JMP ; ; )
- {
- int opc = ip[off];
- if (opc == ijmp || opc == first)
- off += label_get (large, &ip[off + 1]) + 1;
- else
- break;
- }
- return (off);
- }
- static void
- condense_jmps (bvector *bvp, sorted_list<>& fixup, bool large)
- {
- for (sorted_list<>::iterator it (fixup); it.valid (); ++it)
- {
- int off = it.key () + label_get (large, &bvp->data[it.key ()]);
- int first = bvp->data[it.key () - 1];
- if (first != OP_JMPT && first != OP_JMPTL &&
- first != OP_JMPN && first != OP_JMPNL)
- first = -1; // Any non-opcode will do.
- int npos = lastjmp (bvp->data, off, large, first);
- if (npos != off)
- label_put (large, bvp->data + it.key (), npos - it.key ());
- }
- }
- static void
- remove_jmp (bvector *bvp, sorted_list<>& fixup,
- int pos, int len, bool large)
- {
- for (sorted_list<>::iterator it (fixup); it.valid (); ++it)
- {
- int lbl = it.key (), off = label_get (large, &bvp->data[lbl]);
- if (lbl < pos && lbl + off > pos)
- label_put (large, bvp->data + lbl, off - len);
- else if (lbl > pos)
- {
- it.key() -= len;
- if (lbl + off < pos)
- label_put (large, bvp->data + lbl, off + len);
- }
- }
- memmove (bvp->data + pos, bvp->data + pos + len, bvp->nbytes - pos - len);
- bvp->nbytes -= len;
- }
- static void
- simplify_jmps (bvector *bvp, sorted_list<>& fixup, bool large)
- {
- uint8_t *ip = bvp->data;
- for (sorted_list<>::iterator it (fixup); it.valid (); )
- {
- int opc = ip[it.key () - 1];
- if (opc != OP_JMP && opc != OP_JMPL)
- {
- ++it;
- continue;
- }
- const int sz = label_size (large);
- int next = it.key () + sz;
- if (opc == ip[next])
- { // 2 jumps in a row - Delete the second one.
- remove_jmp (bvp, fixup, next, sz + 1, large);
- fixup.erase (it.link()->next);
- }
- if (label_get (large, &ip[it.key ()]) == sz)
- { // Trivial jump - Delete.
- sorted_list<>::iterator tmp = it;
- ++tmp;
- fixup.erase (it.link ());
- remove_jmp (bvp, fixup, next - sz - 1, sz + 1, large);
- it = tmp;
- }
- else if (ip[it.key () + label_get (large, ip + it.key ())] == OP_RET)
- { // Jump and return - Simplify to ret.
- ip[it.key () - 1] = OP_RET;
- sorted_list<>::iterator tmp = it;
- ++tmp;
- fixup.erase (it.link ());
- remove_jmp (bvp, fixup, next - sz, sz, large);
- it = tmp;
- }
- else
- ++it;
- }
- }
- static void
- optimize_jmps (bvector *bvp, sorted_list<>& fixup, bool large)
- {
- condense_jmps (bvp, fixup, large);
- simplify_jmps (bvp, fixup, large);
- bool pass = false;
- for (sorted_list<>::iterator it (fixup); it.valid (); ++it)
- {
- int idx = it.key () + label_get (large, bvp->data + it.key ());
- if (bvp->data[idx] == OP_LOADNIL && bvp->data[idx + 1] == OP_POP)
- {
- remove_jmp (bvp, fixup, idx, 1, large);
- label_put (large, bvp->data + it.key (),
- label_get (large, bvp->data + it.key ()) + 1);
- pass = true;
- }
- }
- if (pass)
- simplify_jmps (bvp, fixup, large);
- }
- bvector* bc_compiler::encode (bool release)
- {
- auto& cv = this->code;
- bool large = cv.size () + (3 * cv.size () / 2) >= 0xffff;
- sorted_list<> lbl_loc, fixup_lbl;
- for (unsigned int it = 0; it < cv.size (); )
- {
- object vi = cv[it++];
- if (vi == OPX_(LABEL))
- {
- lbl_loc.add (cv[it++], this->bc_len ());
- continue;
- }
- const bcode_instr *instrp = bcode_get (as_int (vi));
- if (large && !instrp->long_p () && instrp->branch_p ())
- instrp = bcode_get (as_int (vi = make_lform (vi)));
- this->bytecode_write ((uint8_t)as_int (vi));
- if (instrp->branch_p ())
- {
- fixup_lbl.add (this->bc_len (), cv[it++]);
- this->bytecode_write ((int16_t)0);
- if (large)
- this->bytecode_write ((int16_t)0);
- continue;
- }
- else
- for (int i = 0; i < instrp->nops (); ++i)
- if (instrp->argsize () > 1)
- this->bytecode_write ((int32_t)as_int (cv[it + i]));
- else
- this->bytecode_write ((uint8_t)as_int (cv[it + i]));
- it += instrp->nops ();
- }
- bvector *bvp = this->bytecode.get ();
- // Convert labels to bytecode offsets.
- for (sorted_list<>::iterator it (fixup_lbl); it.valid (); ++it)
- label_put (large, bvp->data + it.key (),
- lbl_loc.get (it.val (), 0) - it.key ());
- // Minimize the amount of jumps needed.
- optimize_jmps (bvp, fixup_lbl, large);
- if (release)
- this->bytecode.release ();
- return (bvp);
- }
- object bc_compiler::encode ()
- {
- bvector *bvp = this->encode (true);
- bvp->vo_full |= FLAGS_CONST;
- this->interp->alval = bvp->as_obj ();
- gc_register (this->interp, bvp, sizeof (*bvp) + this->bytecode.alloc);
- return (this->interp->alval);
- }
- static inline int
- index_of (object item, object lst, int start = 0)
- {
- for ( ; ; ++start, lst = xcdr (lst))
- if (lst == NIL)
- return (-1);
- else if (item == xcar (lst))
- return (start);
- }
- static inline bool
- in_env (object s, object env)
- {
- for (; env != NIL; env = xcdr (env))
- for (object sub = xcar (env); sub != NIL; sub = xcdr (sub))
- if (s == xcar (sub))
- return (true);
- return (false);
- }
- static inline int
- lookup_sym (object s, object env, int& depth)
- {
- for (depth = 0; env != NIL; env = xcdr (env), ++depth)
- {
- int i = index_of (s, xcar (env));
- if (i >= 0)
- return (i);
- }
- return (-1);
- }
- enum
- {
- SPECFORM_DOTTED,
- SPECFORM_TOOMANY,
- SPECFORM_TOOFEW
- };
- static exception
- specform_error (interpreter *interp, const char *form, int type)
- {
- char buf[128], *bp = buf;
- int lenf = (int)strlen (form);
- memcpy (bp, form, lenf);
- bp[lenf++] = ':';
- bp[lenf++] = ' ';
- bp += lenf;
- if (type == SPECFORM_DOTTED)
- memcpy (bp, "got a dotted list", 18);
- else if (type == SPECFORM_TOOMANY)
- memcpy (bp, "too many parameters", 20);
- else if (type == SPECFORM_TOOFEW)
- memcpy (bp, "too few parameters", 19);
- return (interp->raise ("syntax-error", buf));
- }
- static const struct
- {
- object code;
- const char *name;
- uint32_t namelen;
- int argcnt;
- } global_builtins[] =
- {
- { OPX_(IS), "is", 2, 2 },
- { OPX_(NOT), "not", 3, 1 },
- { OPX_(CONS), "cons", 4, 2 },
- { OPX_(CAR), "car", 3, 1 },
- { OPX_(CDR), "cdr", 3, 1 },
- { OPX_(CADR), "cadr", 4, 1 },
- { OPX_(APPLY), "apply", 5, -2 },
- { OPX_(SYMNAME), "symname", 7, 1 },
- { OPX_(SYMPKG), "sympkg", 6, 1 },
- { OPX_(COROVAL), "coro-val", 8, 1 },
- { OPX_(TYPEP), "char-p", 6, 1 },
- { OPX_(TYPEP), "list-p", 6, 1 },
- { OPX_(TYPEP), "str-p", 5, 1 },
- { OPX_(TYPEP), "array-p", 7, 1 },
- { OPX_(TYPEP), "table-p", 7, 1 },
- { OPX_(TYPEP), "tuple-p", 7, 1 },
- { OPX_(TYPEP), "symbol-p", 8, 1 },
- { OPX_(TYPEP), "fct-p", 5, 1 },
- { OPX_(TYPEP), "coro-p", 6, 1 },
- { OPX_(TYPEP), "pkg-p", 5, 1 },
- { OPX_(TYPEP2), "int-p", 5, 1 },
- { OPX_(TYPEP2), "float-p", 7, 1 },
- { OPX_(TYPEP2), "bvector-p", 9, 1 }
- };
- static const int typep_codes[] =
- {
- typecode::CHAR, typecode::CONS, typecode::STR, typecode::ARRAY,
- typecode::TABLE, typecode::TUPLE, typecode::SYMBOL, typecode::FCT,
- typecode::CORO, typecode::PKG
- };
- static const int typep2_codes[] =
- {
- typecode::INT | (typecode::BIGINT << 8),
- typecode::FLOAT | (typecode::BIGFLOAT << 8),
- typecode::BVECTOR | (typecode::STR << 8)
- };
- static const int typep_start = 10;
- static const int typep2_start = 20;
- static inline int
- find_builtin (const string* np, int *nmaxp = nullptr, object expr = UNBOUND)
- {
- for (int i = 0; i < (int)KP_NELEM (global_builtins); ++i)
- if (global_builtins[i].namelen == np->nbytes &&
- memcmp (global_builtins[i].name, np->data, np->nbytes) == 0)
- return (i);
- if (!nmaxp)
- return (-1);
- object head = xcar (expr);
- if (symbol_p (head) && len_s (symname (head)) == 3 &&
- memcmp (str_cdata (symname (head)), "isa", 3) == 0 &&
- xcdr (xcddr (expr)) == NIL)
- {
- object last = xcar (xcddr (expr));
- if (!symbol_p (last) ||
- !as_symbol(last)->flagged_p (symbol::literal_flag) ||
- !builtin_typespec_p (last = symval (last)))
- return (-1);
- /* We got an expression with the form (isa x TYPE-t).
- * Transform it into (TYPE-p x) */
- char buf[32];
- object name = symname (type_name (last));
- uint32_t len = len_s (name);
- memcpy (buf, str_cdata (name), len + 1);
- buf[len - 1] = 'p';
- local_varobj<string> tmp;
- tmp.local_init (buf, len_s (name));
- int ret = find_builtin (&tmp);
- if (ret >= 0)
- {
- *nmaxp = 1;
- return (ret);
- }
- }
- return (-1);
- }
- static object
- lookup_ctv (object env, object sym)
- {
- for (; env != NIL; env = xcdr (env))
- for (object sub = xcar (env); sub != NIL; sub = xcddr (sub))
- if (sym == xcar (sub))
- return (xcadr (sub));
- return (sym & ~EXTRA_BIT);
- }
- static inline object
- lookup_alias (object env, object sym)
- {
- return (lookup_ctv (env, sym | EXTRA_BIT));
- }
- static object
- cfold (interpreter *interp, object expr, object env, object ct_env)
- {
- switch (itype (expr))
- {
- case typecode::CONS:
- case typecode::SYMBOL:
- break;
- case typecode::STR:
- case typecode::ARRAY:
- case typecode::BVECTOR:
- if (deref (length (interp, expr)) == fixint (0))
- return (expr);
- case typecode::TABLE:
- case typecode::TUPLE:
- expr = UNBOUND;
- default:
- return (expr);
- }
- if (expr == NIL)
- return (expr);
- else if (symbol_p (expr))
- return (!in_env (expr, env) && lookup_alias (ct_env, expr) == expr &&
- as_symbol(expr)->flagged_p (symbol::literal_flag) ?
- symval (expr) : UNBOUND);
- object head = xcar (expr), xt;
- int idx;
- if (head == symbol::quote && cons_p (xcdr (expr)) && xcddr (expr) == NIL)
- return (xcadr (expr));
- else if (nksymbol_p (head) &&
- (idx = find_builtin (as_str (symname (head)))) >= 0 &&
- len_L (interp, xcdr (expr), xt) ==
- global_builtins[idx].argcnt && xt == NIL)
- {
- xt = global_builtins[idx].code;
- if ((xt == OPX_(CAR) || xt == OPX_(CDR)) &&
- (head = cfold (interp, xcadr (expr), env, ct_env)) != UNBOUND &&
- xcons_p (head))
- return (xt == OPX_(CAR) ? xcar (head) : xcdr (head));
- else if (xt == OPX_(IS))
- {
- object a1 = cfold (interp, xcadr (expr), env, ct_env),
- a2 = cfold (interp, xcar (xcddr (expr)), env, ct_env);
- if (a1 != UNBOUND && a2 != UNBOUND)
- return (a1 == a2 ? symbol::t : NIL);
- object elem = xcadr (expr);
- if (symbol_p (elem) && elem == xcar (xcddr (expr)) &&
- lookup_alias (ct_env, elem) == elem && in_env (elem, env))
- return (symbol::t);
- }
- }
- return (UNBOUND);
- }
- // Forward declarations.
- static result<object> macroexp_atom (interpreter *, object, object);
- static result<object> macroexp_cons (interpreter *, object, object);
- // Evaluation results.
- enum
- {
- EVR_NIL,
- EVR_ATOM,
- EVR_IRET,
- EVR_BRK,
- EVR_CONT,
- EVR_YIELD,
- EVR_SE = 0x80,
- EVR_NIL_SE = EVR_NIL | EVR_SE,
- EVR_ATOM_SE = EVR_ATOM | EVR_SE,
- EVR_NONE = 0xff
- };
- static inline bool
- evr_nlexit_p (int r)
- {
- return (r == EVR_IRET || r == EVR_BRK || r == EVR_CONT);
- }
- result<int> bc_compiler::compile_atom (object env, bool tail,
- object expr, bool quoted)
- {
- if (expr == fixint (0))
- this->emit (OPX_(LOAD0));
- else if (expr == fixint (1))
- this->emit (OPX_(LOAD1));
- else if (fixint_p (expr))
- this->emit (OPX_(LOADI8), expr);
- else if (char_p (expr))
- this->emit (OPX_(LOADCHR8), expr);
- else if (expr == symbol::t)
- this->emit (OPX_(LOADT));
- else if (expr == NIL)
- {
- this->emit (OPX_(LOADNIL));
- return (EVR_NIL);
- }
- else
- {
- if (!quoted)
- {
- if (str_p (expr))
- {
- expr = KP_TRY (expand_str (this->interp, expr));
- if (!str_p (expr))
- {
- KP_VTRY (this->interp->push (expr),
- this->compile_in (env, tail, expr));
- this->interp->popn ();
- return (EVR_NONE);
- }
- }
- bool rv = KP_TRY (this->compile_seq (env, tail, expr));
- if (rv)
- return (EVR_ATOM_SE);
- }
- this->emit (OPX_(LOADV), expr);
- }
- return (EVR_ATOM);
- }
- result<int> bc_compiler::compile_sym (object env, bool tail,
- object s, const operation_set& ops)
- {
- KP_VTRY (macroexp_atom (this->interp, this->ct_env, s));
- if (this->interp->retval != s)
- { // Evaluate the expanded alias.
- valref tmp (this->interp, this->interp->retval);
- return (this->compile_in (env, false, *tmp));
- }
- int depth, loc = lookup_sym (s, env, depth);
- if (loc < 0)
- {
- if (as_symbol(s)->flagged_p (symbol::literal_flag) &&
- !ops.write && symval (s) != UNBOUND)
- return (this->compile_atom (env, tail, symval (s), true));
- else
- { // Dynamic access.
- if (as_symbol(s)->flagged_p (symbol::special_flag))
- this->emit (ops.dynamic, s);
- else
- {
- int s_idx = builtin_idx (interp, str_cdata (symname (s)));
- if (s_idx < 0)
- {
- if (as_symbol(s)->flagged_p (FLAGS_CONST) && ops.write &&
- (this->rflags & flg_warnings))
- BC_WARN (*this, "setting constant %Q will always fail", s);
- this->emit (ops.global, s);
- }
- else
- this->emit (ops.write ?
- OPX_(SETFGS) : OPX_(LOADFGS), fixint (s_idx));
- }
- }
- }
- else if (depth >= this->frames.size)
- { // Outside this function's scope.
- auto bp = this->bprev, self = this;
- int nprev = 0;
- for (depth -= this->frames.size ; ; ++nprev)
- { // XXX: Check this.
- if (depth < bp->frames.size)
- break;
- depth -= bp->frames.size;
- self = bp, bp = bp->bprev;
- self->capt_idx.root.val = 1;
- }
- auto& f = bp->frames[bp->frames.size - depth - 1];
- loc += f.acc;
- if (bp->captures.set (loc))
- {
- bp->code.insert (bp->code.begin () + *f.ipp + 0, OPX_(BOX));
- bp->code.insert (bp->code.begin () + *f.ipp + 1, fixint (loc));
- *f.ipp += 2;
- }
- auto np = self->capt_idx.add (loc);
- if (np->val < 0)
- np->val = self->capt_idx.len () - 1;
- this->capt_idx.root.val = 1;
- this->emit (ops.closure, fixint (nprev), fixint (np->val));
- }
- else
- { // Local (possibly boxed) variable.
- auto& f = this->frames[this->frames.size - depth - 1];
- bool boxed_p = this->captures.get (f.acc + loc);
- this->emit (boxed_p ? ops.boxed : ops.local, fixint (f.acc + loc));
- }
- return (EVR_NONE);
- }
- result<int> bc_compiler::compile_cond (object env, bool tail,
- object expr, bool popa)
- {
- size_t pos = this->code.size ();
- int r = KP_TRY (this->compile_in (env, tail, expr));
- if (r == EVR_NIL || r == EVR_ATOM)
- this->erase (this->code.begin () + pos, this->code.end ());
- else if (popa && (r == EVR_NIL_SE || r == EVR_ATOM_SE))
- {
- object lasti = this->code.back ();
- if (lasti == OPX_(LOADT) || lasti == OPX_(LOADNIL))
- this->code.pop_back ();
- else
- this->code.push_back (OPX_(POP));
- }
- return (r);
- }
- result<int> bc_compiler::compile_if (object env, bool tail, object x)
- {
- if (!xcons_p (x) || !xcons_p (xcdr (x)))
- return (specform_error (this->interp, "if", SPECFORM_DOTTED));
- else if (xcdr (x) == NIL)
- return (specform_error (this->interp, "if", SPECFORM_TOOFEW));
- object tst = xcar (x);
- object then = xcadr (x);
- object els = xcddr (x);
- insertp_handler ih (*this);
- int r = KP_TRY (this->compile_cond (env, false, tst));
- r &= ~EVR_SE;
- if (kp_unlikely (evr_nlexit_p (r)))
- return (r);
- else if (kp_unlikely (r == EVR_ATOM))
- return (this->compile_in (env, tail, then));
- else if (kp_unlikely (r == EVR_NIL))
- return (xcdr (els) == NIL ? this->compile_in (env, tail, xcar (els)) :
- this->compile_if (env, tail, els));
- int el = this->next_label (), endl = this->next_label ();
- this->emit (OPX_(BRN), fixint (el));
- r = KP_TRY (this->compile_in (env, tail, then));
- if (evr_nlexit_p (r))
- ;
- else if (tail)
- this->emit (OPX_(RET));
- else
- this->emit (OPX_(JMP), fixint (endl));
- this->mark_label (el);
- if (xcdr (els) != NIL)
- KP_VTRY (this->compile_if (env, tail, els));
- else
- KP_VTRY (this->compile_in (env, tail, xcar (els)));
- this->mark_label (endl);
- return (EVR_NONE);
- }
- static result<int>
- compile_while_helper (bc_compiler& bc, object env, object cond,
- object body, object lbl, bool& pad)
- {
- int r = KP_TRY_IP (bc.interp, bc.compile_cond (env, false, cond));
- int rm = r & ~EVR_SE;
- if (kp_unlikely (rm == EVR_NIL))
- {
- bc.emit (OPX_(LOADNIL));
- return (r);
- }
- else if (evr_nlexit_p (r))
- return (r);
- else if (r == EVR_ATOM)
- {
- r = KP_TRY_IP (bc.interp, bc.compile_in (env, false, body));
- bc.emit (OPX_(POP));
- }
- else
- {
- bc.emit (OPX_(BRN), lbl);
- bc.emit (OPX_(POP));
- r = KP_TRY_IP (bc.interp, bc.compile_in (env, false, body));
- pad = true;
- }
- return (r);
- }
- result<int> bc_compiler::compile_while (object env, object cond, object body)
- {
- whl_block blk;
- whl_handler whandler (*this, &blk);
- size_t pos = this->code.size (), ncapts = this->captures.nelem;
- bool pad = false;
- insertp_handler ih (*this);
- this->mark_label (blk.top_lbl);
- int r = KP_TRY (compile_while_helper (*this, env, cond, body,
- fixint (blk.end_lbl), pad));
- if (this->cur_f().ipp == &ih.ipoint && ncapts != this->captures.nelem)
- { /* This 'while' loop references a boxed variable that wasn't boxed
- * before. Undo the last expression and retry with them already boxed. */
- pos = ih.ipoint;
- this->erase (this->code.begin () + pos + 2, this->code.end ());
- KP_VTRY (compile_while_helper (*this, env, cond, body,
- fixint (blk.end_lbl), pad));
- }
- if (pad)
- this->code.insert (this->code.begin () + pos, OPX_(LOADT));
- if (r != EVR_NIL && !evr_nlexit_p (r))
- this->emit (OPX_(IRTJMP), fixint (blk.top_lbl));
- this->mark_label (blk.end_lbl);
- return (EVR_NONE);
- }
- static result<int>
- compile_sc_helper (bc_compiler& bc, object env, bool tail,
- object forms, object dfl, object branch)
- {
- if (!xcons_p (forms))
- return (specform_error (bc.interp, dfl == symbol::t ?
- "and" : "or", SPECFORM_DOTTED));
- else if (forms == NIL)
- return (bc.compile_in (env, tail, dfl));
- else if (xcdr (forms) == NIL)
- return (bc.compile_in (env, tail, xcar (forms)));
- object cf = xcar (forms);
- int r = KP_TRY_IP (bc.interp, bc.compile_cond (env, false, cf, false));
- int rm = r & ~EVR_SE;
- if (kp_unlikely (r == EVR_IRET))
- return (r);
- else if (kp_unlikely (rm == EVR_NIL || rm == EVR_ATOM))
- { // Constant form.
- if ((rm == EVR_NIL && dfl != symbol::t) || (rm == EVR_ATOM && dfl != NIL))
- // Skip constant form.
- return (bc.compile_short_circuit (env, tail, xcdr (forms),
- dfl, branch));
- else if ((r & EVR_SE) == 0)
- KP_VTRY (bc.compile_in (env, true, cf));
- // nil argument in 'and' form, or non-nil argument in 'or' form.
- return (r);
- }
- int end = bc.next_label ();
- bc.emit (branch, fixint (end));
- KP_VTRY (bc.compile_short_circuit (env, tail,
- xcdr (forms), dfl, branch));
- bc.mark_label (end);
- return (EVR_NONE);
- }
- result<int> bc_compiler::compile_short_circuit (object env, bool tail,
- object forms, object dfl,
- object branch)
- {
- insertp_handler ih (*this);
- return (compile_sc_helper (*this, env, tail, forms, dfl, branch));
- }
- result<int> bc_compiler::compile_arglist (object env, object expr,
- int off, int nmax)
- {
- int ret = 0;
- this->cur_f().stkdisp += off;
- for (; expr != NIL && ret < nmax;
- expr = xcdr (expr), ++ret, ++this->cur_f().stkdisp)
- if (xcons_p (expr))
- KP_VTRY (this->compile_in (env, false, xcar (expr)));
- else
- return (this->interp->raise ("arg-error",
- "argument list must not be dotted"));
- this->cur_f().stkdisp -= ret + off;
- return (ret);
- }
- void bc_compiler::test_nargs_fct (object obj, object env, int nargs)
- {
- if (!(this->rflags & flg_warnings) || in_env (obj, env))
- return;
- valref f (this->interp, obj);
- if (!symbol_p (*f) || !fct_p (*f = symval (*f)))
- return;
- function_base *fbp = (function_base *)unmask (*f);
- auto rv = deref (fbp->test_nargs (this->interp, nargs, false));
- if (rv)
- return;
- char buf[128];
- this->interp->nargs_msg (buf, sizeof (buf) - 1,
- fbp->min_argc, fbp->max_argc, nargs);
- BC_WARN (*this, buf, fbp->name);
- }
- result<int> bc_compiler::compile_app (object env, bool tail, object expr)
- {
- object h = xcar (expr);
- int nmax = INT_MAX;
- int bidx = !nksymbol_p (h) ? -1 :
- find_builtin (as_str (symname (h)), &nmax, expr);
- if (bidx < 0)
- {
- KP_VTRY (macroexp_cons (this->interp, this->ct_env, expr));
- if (this->interp->retval != expr)
- { // Evaluate the macro-expansion.
- valref tmp (this->interp, this->interp->retval);
- return (this->compile_in (env, tail, *tmp));
- }
- // Evaluate the calling function's definition.
- KP_TRY (this->compile_in (env, false, h));
- }
- else
- {
- auto e_len = KP_TRY (len_L (this->interp, xcdr (expr)));
- int len = min (e_len, nmax);
- int cnt = global_builtins[bidx].argcnt;
- if ((cnt >= 0 && len != cnt) || (cnt < 0 && len < -cnt))
- {
- this->emit (OPX_(LOADG), xcar (expr));
- bidx = -1;
- }
- }
- int nargs = KP_TRY (this->compile_arglist (env, xcdr (expr),
- bidx < 0, nmax));
- if (bidx < 0)
- {
- this->emit (tail ? OPX_(TCALL) : OPX_(CALL), fixint (nargs));
- this->test_nargs_fct (h, env, nargs);
- }
- else
- {
- object instr = global_builtins[bidx].code;
- if (instr == OPX_(APPLY))
- this->emit (tail ? OPX_(TAPPLY) : OPX_(APPLY), fixint (nargs));
- else if (instr == OPX_(TYPEP))
- this->emit (instr, fixint (typep_codes[bidx - typep_start]));
- else if (instr == OPX_(TYPEP2))
- {
- int tx = typep2_codes[bidx - typep2_start];
- this->emit (instr, fixint (tx & 0xff), fixint (tx >> 8));
- }
- else
- this->emit (instr);
- }
- return (EVR_NONE);
- }
- result<int> bc_compiler::compile_do (object env, bool tail, object forms)
- {
- if (!cons_p (forms))
- {
- this->emit (OPX_(LOADT));
- return (EVR_ATOM);
- }
- else if (!cons_p (xcdr (forms)))
- return (this->compile_in (env, tail, xcar (forms)));
- int r = KP_TRY (this->compile_cond (env, false, xcar (forms)));
- r &= ~EVR_SE;
- if (r == EVR_IRET || r == EVR_BRK || r == EVR_CONT)
- // Ignore every expression after this form.
- return (r);
- else if (r != EVR_NIL && r != EVR_ATOM)
- this->emit (OPX_(POP));
- r = KP_TRY (this->compile_do (env, tail, xcdr (forms)));
- return (r == EVR_ATOM || r == EVR_NIL ? (r | EVR_SE) : r);
- }
- static inline int
- get_specform (const string* sp)
- {
- return (symbol::specform_byname (sp->data, sp->nbytes));
- }
- /* For sequences that may contain symbols (i.e: arrays, tables and tuples),
- * modify the expression so that instead of a literal, it becomes a call
- * to its respective constructor function, therefore evaluating the
- * symbols into values. */
- result<bool> bc_compiler::compile_seq (object env, bool tail, object expr)
- {
- tmp_allocator ta { this->interp };
- cons *tmp;
- char name[16] = "";
- uint32_t namelen, i = 0;
- if (array_p (expr))
- {
- const array *ap = as_array (expr);
- if (ap->len == 0)
- return (false);
- tmp = (cons *)ta.alloc (ap->len * sizeof (*tmp));
- for (; i < ap->len; ++i)
- tmp[i].car = ap->data[i];
- memcpy (name, "array", namelen = 5);
- }
- else if (table_p (expr))
- {
- uint32_t len = len_u (expr);
- tmp = (cons *)ta.alloc ((len + 1) * 2 * sizeof (*tmp));
- // Push the test and hash functions.
- tmp[i++].car = NIL;
- tmp[i++].car = NIL;
- // Push the key/value pairs.
- for (table::iterator it (this->interp, expr); it.valid (); ++it)
- {
- tmp[i++].car = it.key ();
- tmp[i++].car = it.val ();
- }
- memcpy (name, "table", namelen = 5);
- }
- else if (tuple_p (expr))
- {
- uint32_t len = len_o (expr);
- tmp = (cons *)ta.alloc ((len + 1) * sizeof (*tmp));
- // Push the test function.
- tmp[i++].car = NIL;
- // Push the keys.
- for (tuple::iterator it (this->interp, expr); it.valid (); ++it)
- tmp[i++].car = *it;
- memcpy (name, "tuple", namelen = 5);
- }
- else if (bvector_p (expr))
- { /* Byte vectors don't really have a constructor, but we still need
- * to copy them so as to make them unique across calls. */
- tmp = (cons *)ta.alloc (5 * sizeof (*tmp));
- tmp[i++].car = tmp[3].as_obj ();
- tmp[3].car = symbol::quote;
- tmp[3].cdr = tmp[4].as_obj ();
- tmp[4].car = expr;
- tmp[4].cdr = NIL;
- memcpy (name, "copy", namelen = 4);
- }
- else
- return (false);
- // Link the contiguous conses.
- for (uint32_t j = 0; j < i - 1; ++j)
- tmp[j].cdr = tmp[j + 1].as_obj ();
- tmp[i - 1].cdr = NIL;
- int s_idx = builtin_idx (this->interp, name);
- if (s_idx >= 0)
- this->emit (OPX_(LOADFGS), fixint (s_idx));
- else
- {
- object sym = find_sym (this->interp, name, namelen);
- if (!symbol_p (sym))
- return (false);
- this->emit (OPX_(LOADG), sym);
- }
- KP_VTRY (this->compile_arglist (env, tmp->as_obj ()));
- this->emit (tail ? OPX_(TCALL) : OPX_(CALL) , fixint (i));
- return (true);
- }
- result<void> bc_compiler::compile_try (object env, bool, object expr)
- {
- insertp_handler ih (*this);
- int clbl = this->next_label (), end = this->next_label ();
- this->emit (OPX_(TRYBEGIN), fixint (clbl));
- ++this->exc_depth;
- this->cur_f().stkdisp += 2;
- int rv = KP_TRY (this->compile_in (env, false, xcadr (expr)));
- if (!evr_nlexit_p (rv))
- {
- this->emit (OPX_(TRYEND));
- this->emit (OPX_(JMP), fixint (end));
- }
- this->cur_f().stkdisp -= 2;
- --this->exc_depth;
- this->mark_label (clbl);
- auto prev = this->rflags & flg_incatch;
- this->rflags |= flg_incatch;
- rv = KP_TRY (this->compile_in (env, false, xcar (xcddr (expr))));
- if (!evr_nlexit_p (rv))
- this->emit (OPX_(CLREXC));
- this->rflags = (this->rflags & ~flg_incatch) | prev;
- this->mark_label (end);
- return (0);
- }
- static const bc_compiler::operation_set LOAD_OPS =
- {
- OPX_(LOADA), OPX_(LOADC), OPX_(LOADG), OPX_(LOADB), OPX_(LOADX), false
- };
- static const bc_compiler::operation_set SET_OPS =
- {
- OPX_(SETA), OPX_(SETC), OPX_(SETG), OPX_(SETB), OPX_(SETG), true
- };
- static exception
- outside_error (interpreter *interp, const char *form, const char *where)
- {
- char buf[64];
- sprintf (buf, "'%s' outside %s", form, where);
- return (interp->raise ("syntax-error", buf));
- }
- result<int> bc_compiler::compile_in (object env, bool tail, object expr)
- {
- if (symbol_p (expr))
- return (this->compile_sym (env, tail, expr, LOAD_OPS));
- else if (atom_p (expr))
- return (this->compile_atom (env, tail, expr));
- object e1 = cfold (this->interp, expr, env, this->ct_env);
- if (e1 != UNBOUND)
- // A constant expression is always implicitly quoted.
- return (this->compile_atom (env, tail, e1, true));
- // Complex expression.
- e1 = xcar (expr);
- if (!nksymbol_p (e1))
- return (this->compile_app (env, tail, expr));
- switch (get_specform (as_str (symname (e1))))
- {
- case SF_QUOTE:
- if (!xcons_p (xcdr (expr)))
- return (specform_error (this->interp, "quote", SPECFORM_DOTTED));
- else if (xcdr (expr) == NIL)
- return (specform_error (this->interp, "quote", SPECFORM_TOOFEW));
- else if (xcddr (expr) != NIL)
- return (specform_error (this->interp, "quote", SPECFORM_TOOMANY));
- return (this->compile_atom (env, tail, xcadr (expr), true));
- case SF_IF:
- return (this->compile_if (env, tail, xcdr (expr)));
- case SF_DO:
- return (this->compile_do (env, tail, xcdr (expr)));
- case SF_FCT:
- {
- if (!xcons_p (xcdr (expr)))
- return (specform_error (this->interp, "fct", SPECFORM_DOTTED));
- else if (xcdr (expr) == NIL)
- return (specform_error (this->interp, "fct", SPECFORM_TOOFEW));
-
- insertp_handler ih (*this);
- bc_compiler bc (this->interp, bc_compiler::flg_warnings);
- bc.bprev = this;
- object fn = KP_TRY (bc.compile_fct (env, xcdr (expr)));
- KP_VTRY (this->interp->push (fn));
- this->emit (OPX_(LOADV), fn);
- if (bc.capt_idx.root.val)
- {
- object vec = KP_TRY (alloc_array (this->interp,
- bc.capt_idx.len ()));
- for (sorted_list<>::iterator it (bc.capt_idx); it.valid (); ++it)
- xaref(vec, it.val ()) = fixint (it.key ());
- as_fct(fn)->env = vec;
- this->emit (OPX_(CLOSURE));
- }
- return (EVR_ATOM_SE);
- }
- case SF_AND:
- return (this->compile_and (env, tail, xcdr (expr)));
- case SF_OR:
- return (this->compile_or (env, tail, xcdr (expr)));
- case SF_WHILE:
- {
- if (xcdr (expr) == NIL)
- return (specform_error (this->interp, "while", SPECFORM_TOOFEW));
- else if (!xcons_p (xcdr (expr)))
- return (specform_error (this->interp, "while", SPECFORM_DOTTED));
- cons *ep = this->expr_do ();
- ep->cdr = xcddr (expr);
- return (this->compile_while (env, xcadr (expr), ep->as_obj ()));
- }
- case SF_BREAK:
- if (!this->whl)
- return (outside_error (this->interp, "break", "while loop"));
- else if (!xcons_p (xcdr (expr)))
- return (specform_error (this->interp, "break", SPECFORM_DOTTED));
- else if (xcddr (expr) != NIL)
- return (specform_error (this->interp, "break", SPECFORM_TOOMANY));
- KP_VTRY (this->compile_in (env, false, xcadr (expr)));
- this->unwind_state (this->whl);
- this->emit (OPX_(JMP), fixint (this->whl->end_lbl));
- return (EVR_BRK);
- case SF_CONTINUE:
- if (!this->whl)
- return (outside_error (this->interp, "continue", "while loop"));
- else if (xcdr (expr) != NIL)
- return (this->interp->raise ("syntax-error",
- "invalid argument in "
- "'continue' expression"));
- this->unwind_state (this->whl);
- this->emit (OPX_(LOADNIL));
- this->emit (OPX_(IRTJMP), fixint (this->whl->top_lbl));
- return (EVR_CONT);
- case SF_RETURN:
- if (this->rflags & flg_toplevel)
- return (outside_error (this->interp, "return", "function"));
- else if (xcdr (expr) != NIL && !xcons_p (xcdr (expr)))
- return (specform_error (this->interp, "return", SPECFORM_DOTTED));
- else if (xcddr (expr) != NIL)
- return (specform_error (this->interp, "return", SPECFORM_TOOMANY));
- KP_VTRY (this->compile_in (env, true, xcadr (expr)));
- this->restore_exc (this->exc_depth);
- if (this->n_dbinds)
- this->emit (OPX_(UNBIND), fixint (this->n_dbinds));
- this->emit (OPX_(RET));
- return (EVR_IRET);
- case SF_YIELD:
- // (yield $x) is equivalent to (return (%make-cont $x))
- if (this->rflags & flg_toplevel)
- return (outside_error (this->interp, "yield", "function"));
- else if (xcdr (expr) != NIL && !xcons_p (xcdr (expr)))
- return (specform_error (this->interp, "yield", SPECFORM_DOTTED));
- else if (xcddr (expr) != NIL)
- return (specform_error (this->interp, "yield", SPECFORM_TOOMANY));
- KP_VTRY (this->compile_in (env, false, xcadr (expr)));
- this->emit (OPX_(MKCONT), fixint (1 + this->exc_depth +
- (this->n_dbinds > 0xff ? 5 : (this->n_dbinds > 0 ? 2 : 0))));
- this->restore_exc (this->exc_depth);
- if (this->n_dbinds)
- this->emit (OPX_(UNBIND), fixint (this->n_dbinds));
- this->emit (OPX_(RET));
- return (EVR_YIELD);
- case SF_SETQ:
- if (!xcons_p (xcdr (expr)) || !xcons_p (xcddr (expr)))
- return (specform_error (this->interp, "setq", SPECFORM_DOTTED));
- else if (xcddr (expr) == NIL)
- return (specform_error (this->interp, "setq", SPECFORM_TOOFEW));
- else if (xcdr (xcddr (expr)) != NIL)
- return (specform_error (this->interp, "setq", SPECFORM_TOOMANY));
- else if (!symbol_p (xcadr (expr)))
- return (this->interp->raise ("syntax-error",
- "setq requires a symbol"));
- KP_VTRY (this->compile_in (env, false, xcar (xcddr (expr))),
- this->compile_sym (env, tail, xcadr (expr), SET_OPS));
- break;
- case SF_LET:
- return (this->compile_let (env, tail, xcdr (expr)));
- case SF_CALLCC:
- {
- if (this->rflags & flg_toplevel)
- return (outside_error (this->interp, "call/cc", "function"));
- bc_compiler bc (this->interp, bc_compiler::flg_warnings);
- bc.bprev = this;
- cons cc_env;
- cc_env.car = xcadr (expr);
- cc_env.cdr = env;
- insertp_handler ih (*this);
- object cls = KP_TRY (bc.compile_fct_body (cc_env.as_obj (),
- xcddr (expr)));
- KP_VTRY (this->interp->push (cls));
- this->emit (OPX_(LOADV), cls);
- this->emit (OPX_(CLOSURE));
- this->emit (OPX_(LOADNIL));
- this->emit (OPX_(MKCONT), fixint (2));
- this->emit (tail ? OPX_(TCALL) : OPX_(CALL), fixint (1));
- break;
- }
- case SF_RECUR:
- {
- if (this->rflags & flg_toplevel)
- return (outside_error (this->interp, "recur", "function"));
- this->emit (OPX_(LDCALLER));
- int n = KP_TRY (this->compile_arglist (env, xcdr (expr)));
- this->emit (tail ? OPX_(TRECUR) : OPX_(RECUR), fixint (n));
- if (n < this->min_argc || (uint32_t)n > (uint32_t)this->max_argc &&
- (this->rflags & flg_warnings))
- {
- char buf[128];
- this->interp->nargs_msg (buf, sizeof (buf) - 1, this->min_argc,
- this->max_argc, n);
- local_varobj<string> sf;
- sf.local_init ("#:recur", 7);
- BC_WARN (*this, buf, sf.as_obj ());
- }
- break;
- }
- case SF_TRY:
- if (!xcons_p (xcdr (expr)) || !xcons_p (xcddr (expr)))
- return (specform_error (this->interp, "try", SPECFORM_DOTTED));
- else if (xcddr (expr) == NIL)
- return (specform_error (this->interp, "try", SPECFORM_TOOFEW));
- else if (xcdr (xcddr (expr)) != NIL)
- return (specform_error (this->interp, "try", SPECFORM_TOOMANY));
- KP_VTRY (this->compile_try (env, tail, expr));
- break;
- case SF_RAISE:
- {
- int n = KP_TRY (this->compile_arglist (env, xcdr (expr), 0));
- if (n > 2)
- return (specform_error (this->interp, "raise", SPECFORM_TOOMANY));
- this->emit (OPX_(RAISE), fixint (n));
- break;
- }
- default:
- KP_VTRY (this->compile_app (env, tail, expr));
- }
- return (EVR_NONE);
- }
- struct arglist
- {
- cons *ptr = nullptr;
- uint32_t n = 0;
- void add_sym (cons *basep, object sym)
- {
- if (!this->ptr)
- this->ptr = basep;
- cons *outp = this->ptr + this->n++;
- outp->cdr = outp[1].as_obj ();
- outp->car = sym;
- }
- void fixup_env ()
- { /* For keyword and optional arguments, we need to strip the
- * default definition in the environment lists. */
- for (uint32_t i = 0; i < this->n; ++i)
- this->ptr[i].car = xcar (this->ptr[i].car);
- }
- };
- struct proc_args
- {
- cons *buf;
- arglist req;
- arglist opt;
- arglist kw;
- proc_args (cons *space) : buf (space) {}
- result<int> parse (interpreter *interp, object args)
- {
- bool kwargs = false, optargs = false;
- for (object orig = args ; ; args = xcdr (args))
- {
- if (args == NIL || symbol_p (args))
- break;
- else if (!cons_p (args))
- {
- invalid_arglist:
- if (orig == args)
- return (interp->raise ("arg-error",
- KP_SPRINTF (interp,
- "invalid argument list: %Q",
- orig)));
- else
- return (interp->raise ("arg-error",
- KP_SPRINTF (interp, "invalid required "
- "argument: %Q",
- args)));
- }
- object tmp = xcar (args);
- if (nksymbol_p (tmp))
- {
- if (optargs || kwargs)
- return (interp->raise ("arg-error",
- KP_SPRINTF (interp, "optional arguments "
- "must come after "
- "required ones")));
- req.add_sym (this->buf, tmp);
- }
- else if (!cons_p (tmp))
- goto invalid_arglist;
- else if (!cons_p (xcdr (tmp)) ||
- xcddr (tmp) != NIL || !symbol_p (xcar (tmp)))
- return (interp->raise ("arg-error",
- KP_SPRINTF (interp, "invalid optional "
- "argument: %Q",
- tmp)));
- else if (keyword_p (xcar (tmp)))
- {
- kwargs = true;
- this->kw.add_sym (this->buf + this->req.n + this->opt.n, tmp);
- }
- else
- {
- if (kwargs)
- return (interp->raise ("arg-error",
- KP_SPRINTF (interp, "keyword arguments "
- "must come last")));
- optargs = true;
- this->opt.add_sym (this->buf + this->req.n, tmp);
- }
- }
- return (0);
- }
- };
- result<void> bc_compiler::emit_optargs_init (object env, object opta,
- object vars, int idx)
- {
- for (; opta != NIL; ++idx, opta = xcdr (opta))
- {
- int nxt = this->next_label ();
- this->emit (OPX_(BRBOUND), fixint (idx));
- this->emit (OPX_(BRT), fixint (nxt));
- cons *p = as_cons (vars);
- object prev = p[idx].cdr;
- p[idx].cdr = NIL;
- cons aux;
- aux.car = p->as_obj ();
- aux.cdr = env;
- KP_VTRY (this->compile_in (aux.as_obj (), false, xcadr (xcar (opta))));
- this->emit (OPX_(SETA), fixint (idx));
- this->emit (OPX_(POP));
- this->mark_label (nxt);
- p[idx].cdr = prev;
- }
- return (0);
- }
- static result<object>
- make_kwtab (interpreter *interp, arglist& args, uint32_t off = 0)
- {
- uint32_t n = upsize (args.n + 1);
- object tab = KP_TRY (alloc_array (interp, n * 2, fixint (0)));
- for (uint32_t i = 0; i < args.n; ++i)
- {
- object obj = xcar (args.ptr[i].car);
- for (uint32_t idx = hash_S (interp, obj) & (n - 1) ; ;
- idx = (idx + 1) & (n - 1))
- if (xaref (tab, idx * 2) == fixint (0))
- {
- xaref(tab, idx * 2 + 0) = obj;
- xaref(tab, idx * 2 + 1) = fixint (i + off);
- break;
- }
- }
- KP_VTRY (interp->push (interp->alval));
- return (interp->stktop ());
- }
- result<object> bc_compiler::compile_fct (object env, object expr)
- {
- object atail = NIL;
- object vars, args = xcar (expr);
- cons last;
- int nargs = 0, nreq = 0, nkw = 0;
- bool has_opt = false;
- tmp_allocator ta { this->interp };
- if (kp_likely (cons_p (args)))
- {
- nargs = len_L (this->interp, args, atail);
- cons *tmp = (cons *)ta.alloc ((nargs + 1) * sizeof (*tmp));
- proc_args pa (tmp);
- KP_VTRY (pa.parse (this->interp, args));
- nreq = pa.req.n;
- tmp[nargs - 1].cdr = NIL;
- if ((has_opt = pa.opt.n != 0 || pa.kw.n != 0))
- {
- if (pa.kw.n == 0)
- this->emit (OPX_(OPTARGS), fixint (pa.req.n),
- fixint (atail == NIL ? nargs : -nargs));
- else
- {
- object kwtab = KP_TRY (make_kwtab (this->interp,
- pa.kw, pa.opt.n));
- this->index (kwtab);
- this->emit (OPX_(KWARGS), fixint (nreq), fixint (pa.kw.n),
- fixint (atail == NIL ? nargs : -nargs));
- nkw = pa.kw.n;
- }
- cons *first_opt = pa.opt.ptr ? pa.opt.ptr : pa.kw.ptr;
- if (pa.req.n == 0)
- pa.req.ptr = first_opt;
- for (uint32_t i = 0; i < pa.kw.n; ++i)
- { /* Convert all the keywords in the list to regular
- * symbols. Note that the keywords have been saved
- * in the table produced by 'make_kwtab'. */
- object& dst = xcar (pa.kw.ptr[i].car);
- const string *np = as_str (symname (dst));
- object sym = KP_TRY (intern (this->interp,
- (char *)np->data, np->nbytes));
- KP_VTRY (this->interp->push (sym));
- dst = this->interp->stktop ();
- }
- tmp[nargs - 1].cdr = NIL;
- KP_VTRY (this->emit_optargs_init (env, first_opt->as_obj (),
- pa.req.ptr->as_obj (), nreq));
- pa.opt.fixup_env ();
- pa.kw.fixup_env ();
- }
- if (atail != NIL)
- { // Append the varargs to the argument list.
- last.car = atail;
- last.cdr = NIL;
- tmp[nargs - 1].cdr = last.as_obj ();
- }
- this->cur_f().nargs += nargs + (atail != NIL);
- vars = tmp->as_obj ();
- }
- else
- {
- last.car = atail = args;
- last.cdr = NIL;
- vars = last.as_obj ();
- this->cur_f().nargs = atail != NIL;
- }
- if (atail == NIL)
- this->max_argc = nargs + nkw;
- else
- {
- this->emit (OPX_(VARGC), fixint (nargs));
- this->max_argc = -1;
- }
- this->min_argc = nreq;
- cons tmp;
- tmp.car = vars;
- tmp.cdr = env;
- return (this->compile_fct_body (tmp.as_obj (), xcdr (expr),
- (nkw ? function::kwargs_flag : 0)));
- }
- result<object> bc_compiler::compile_fct_body (object env,
- object expr, uint32_t flags)
- {
- int r;
- if (xcdr (expr) == NIL)
- { // Single-expression function.
- r = KP_TRY (this->compile_in (env, true, xcar (expr)));
- }
- else
- { // Multi-expression body. Transform it into a '(do (...)).
- cons body;
- body.car = xcar (expr);
- body.cdr = xcdr (expr);
- r = KP_TRY (this->compile_do (env, true, body.as_obj ()));
- }
- if (r == EVR_YIELD)
- {
- this->emit (OPX_(LOADNIL));
- this->emit (OPX_(RET));
- }
- else if (r != EVR_IRET)
- this->emit (OPX_(RET));
- KP_VTRY (alloc_fct (this->interp, flags));
- function *retp = as_fct (this->interp->alval);
- KP_VTRY (this->interp->push (this->interp->alval));
- retp->bcode = this->encode ();
- retp->vals = KP_TRY (this->idxvec ());
- retp->max_sp = retp->max_stack ();
- retp->min_argc = this->min_argc;
- retp->max_argc = this->max_argc;
- return (this->interp->pop ());
- }
- static int
- ctv_letdef (object ev)
- {
- if (!cons_p (ev) || !keyword_p (xcar (ev)))
- return (-1);
- const string *np = as_str (symname (xcar (ev)));
- if (np->nbytes == 5)
- {
- if (memcmp ("macro", np->data, 5) == 0)
- return (0);
- else if (memcmp ("alias", np->data, 5) == 0)
- return (1);
- }
- return (-1);
- }
- static result<int>
- eval_ctv (bc_compiler& self, object bindings, cons *ctvs, int nctv)
- {
- object ev = xcadr (bindings);
- int r = ctv_letdef (ev);
- if (r < 0)
- return (r);
- else if (r == 1)
- KP_VTRY (eval (self.interp, xcadr (ev)));
- else if (r == 0)
- {
- bc_compiler tmp (self.interp, self.rflags & ~bc_compiler::flg_toplevel);
- object prev = NIL;
- tmp.ct_env = self.ct_env;
- if (nctv > 0)
- swap (prev, ctvs[nctv - 1].cdr);
- KP_VTRY (tmp.compile_fct (NIL, xcdr (ev)));
- if (nctv > 0)
- ctvs[nctv - 1].cdr = prev;
- }
- KP_VTRY (self.interp->push (self.interp->retval));
- ctvs[nctv].car = xcar (bindings) | (r ? EXTRA_BIT : 0);
- ctvs[nctv].cdr = ctvs[nctv + 1].as_obj ();
- ctvs[nctv + 1].car = self.interp->retval;
- ctvs[nctv + 1].cdr = NIL;
- return (r);
- }
- static inline int
- count_let_nlex (object bindings)
- {
- int nlex = 0;
- for (; bindings != NIL; bindings = xcddr (bindings))
- nlex += ctv_letdef (xcadr (bindings)) < 0;
- return (nlex);
- }
- static inline bool
- special_symbol_p (object obj)
- {
- return (as_symbol(obj)->flagged_p (symbol::special_flag));
- }
- static result<int>
- array_nbindings (interpreter *interp, object obj)
- {
- const array *ap = as_array (obj);
- int ret = 0;
- if (ap->len == 0)
- return (interp->raise ("arg-error",
- "let: array bindings must not be empty"));
- for (uint32_t i = 0; i < ap->len; ++i)
- {
- if (symbol_p (ap->data[i]))
- ++ret;
- else if (array_p (ap->data[i]))
- { ret += KP_TRY (array_nbindings (interp, ap->data[i])); }
- else
- return (interp->raise ("arg-error",
- KP_SPRINTF (interp, "let: invalid binding: %Q",
- ap->data[i])));
- }
- return (ret);
- }
- static inline result<int>
- count_bindings (interpreter *interp, object obj)
- {
- if (!array_p (obj))
- return (1);
- return (array_nbindings (interp, obj));
- }
- #define ADD_BIND(lst, obj, var) \
- do \
- { \
- lst[var].car = obj; \
- lst[var].cdr = NIL; \
- if (var > 0) \
- lst[var - 1].cdr = syms[var].as_obj (); \
- ++var; \
- } \
- while (0)
- static result<int>
- flatten_array_args (bc_compiler& bc, cons *syms, object bindings,
- bool& curr_dynamic, int& nvframes)
- {
- auto interp = bc.interp;
- const array *ap = as_array (bindings);
- int ret = 0;
- for (uint32_t i = 0; i < ap->len; ++i)
- {
- if (array_p (ap->data[i]))
- {
- int rx = KP_TRY (flatten_array_args (bc, syms + ret, ap->data[i],
- curr_dynamic, nvframes));
- ret += rx, syms += rx;
- }
- else
- {
- object tmp = ap->data[i];
- if (special_symbol_p (tmp))
- {
- if (!curr_dynamic)
- {
- bc.emit (OPX_(VFRAME));
- bc.cur_f().stkdisp += 2;
- curr_dynamic = true;
- ++nvframes;
- ADD_BIND (syms, fixint (0), ret);
- ADD_BIND (syms, fixint (0), ret);
- }
- bc.emit (OPX_(LOAD0)); // Just a placeholder.
- bc.emit (OPX_(BIND), tmp);
- bc.cur_f().stkdisp += 2;
- ADD_BIND (syms, fixint (0), ret);
- }
- else
- {
- if (keyword_p (tmp))
- {
- KP_VTRY (intern (interp, as_str (symname (tmp))),
- interp->push (interp->retval));
- tmp = interp->stktop ();
- }
- bc.emit (OPX_(LOAD0));
- ++bc.cur_f().nargs;
- curr_dynamic = false;
- }
- ADD_BIND (syms, tmp | (special_symbol_p (tmp) ? EXTRA_BIT : 0), ret);
- }
- }
- return (ret);
- }
- result<int> bc_compiler::compile_let (object env, bool tail, object expr)
- {
- object bindings = xcar (expr);
- if (bindings == NIL)
- // 'let' with no bindings -> compile as a 'do' form.
- return (this->compile_do (env, tail, xcdr (expr)));
- cons sbody[2];
- int nargs = 0;
- auto ip = this->interp;
- if (!xcons_p (bindings))
- {
- if (!nksymbol_p (bindings) && !array_p (bindings))
- return (ip->raise ("arg-error",
- KP_SPRINTF (ip, "let: invalid binding: %Q",
- bindings)));
- else if (!xcons_p (xcdr (expr)))
- return (ip->raise ("arg-error",
- KP_SPRINTF (ip, "let: got a dotted list in the "
- "body: %Q", expr)));
- else if (xcdr (expr) == NIL)
- return (ip->raise ("arg-error", "missing body in let"));
- nargs = KP_TRY (count_bindings (ip, bindings));
- sbody[0].car = bindings;
- sbody[0].cdr = sbody[1].as_obj ();
- sbody[1].car = xcadr (expr);
- sbody[1].cdr = NIL;
- bindings = sbody[0].as_obj ();
- expr = xcdr (expr);
- }
- else
- for (object tmp = bindings; tmp != NIL; )
- {
- if (!nksymbol_p (xcar (tmp)) && !array_p (xcar (tmp)))
- return (ip->raise ("arg-error",
- KP_SPRINTF (ip, "let: invalid binding: %Q",
- xcar (tmp))));
- nargs += KP_TRY (count_bindings (ip, xcar (tmp)));
- if (xcdr (tmp) == NIL)
- return (ip->raise ("arg-error",
- KP_SPRINTF (ip, "let bindings must come in pairs, "
- "got: %Q", bindings)));
- else if (!xcons_p (xcdr (tmp)) || !xcons_p (tmp = xcddr (tmp)))
- return (ip->raise ("arg-error",
- KP_SPRINTF (ip, "let bindings must not come in a "
- "dotted list: %Q", bindings)));
- }
- tmp_allocator ta { ip };
- cons *syms = (cons *)ta.alloc ((nargs + 2) * 8 * sizeof (*syms));
- cons *ctvs = syms + nargs * 4;
- cons t1, t2;
- int nctv = 0, nvframes = 0, nbinds = 0;
- bool curr_dynamic = false;
- // Link the lexical and compile-time environments.
- syms->car = syms->cdr = NIL;
- t1.car = syms->as_obj (), t1.cdr = env;
- ctvs->car = ctvs->cdr = NIL;
- t2.car = ctvs->as_obj (), t2.cdr = this->ct_env;
- this->ct_env = t2.as_obj ();
- nargs = count_let_nlex (bindings);
- this->push_f ();
- env = t1.as_obj ();
- for (; bindings != NIL; bindings = xcddr (bindings))
- {
- {
- int rv = KP_TRY (eval_ctv (*this, bindings, ctvs, nctv));
- if (rv >= 0)
- { /* This is a compile-time (i.e: macro or alias) definition,
- * rather than a lexical or dynamic binding. */
- nctv += 2;
- continue;
- }
- }
- object sym = xcar (bindings);
- if (array_p (sym))
- {
- object setf = find_sym (ip, "setf", 4);
- valref se (ip, fixint (0));
- if (!symbol_p (setf) ||
- !as_symbol(setf)->flagged_p (symbol::ctv_flag) ||
- !fct_p (*se = symval (setf)))
- return (ip->raise ("runtime-error", "let: setf is not bound"));
- nbinds += KP_TRY (flatten_array_args (*this, syms + nbinds, sym,
- curr_dynamic, nvframes));
- // Expand the (let [x y ...] (expr)) into (setf [x y ...] (expr))
- *se = KP_TRY (KP_CALL (ip, *se, xcar (bindings), xcadr (bindings)));
- KP_VTRY (this->compile_in (env, false, *se));
- this->emit (OPX_(POP));
- continue;
- }
- object evx = xcadr (bindings);
- if (kp_likely (!special_symbol_p (sym)))
- {
- KP_VTRY (this->compile_in (env, false, evx));
- ++this->cur_f().nargs;
- curr_dynamic = false;
- }
- else
- {
- if (!curr_dynamic)
- {
- this->emit (OPX_(VFRAME));
- this->cur_f().stkdisp += 2;
- curr_dynamic = true;
- ++nvframes;
- ADD_BIND (syms, fixint (0), nbinds);
- ADD_BIND (syms, fixint (0), nbinds);
- }
- KP_VTRY (this->compile_in (env, false, evx));
- this->emit (OPX_(BIND), sym);
- this->cur_f().stkdisp += 2;
- ADD_BIND (syms, fixint (0), nbinds);
- }
- ADD_BIND (syms, sym | (special_symbol_p (sym) ? EXTRA_BIT : 0), nbinds);
- }
- if (nctv)
- ctvs[nctv - 1].cdr = NIL;
- if (nbinds)
- syms[nbinds - 1].cdr = NIL;
- this->n_dbinds += nvframes;
- int r = KP_TRY (this->compile_do (env, tail && nvframes == 0, xcdr (expr)));
- this->ct_env = t2.cdr;
- if (nvframes)
- this->emit (OPX_(UNBIND), fixint (nvframes));
- if (nbinds && !evr_nlexit_p (r) && !tail)
- this->emit (OPX_(SKIP), fixint (nbinds));
- this->pop_f ();
- this->n_dbinds -= nvframes;
- return (r);
- }
- #undef ADD_BIND
- result<object> compile_expr (interpreter *interp, object expr)
- {
- bc_compiler bc (interp, bc_compiler::flg_toplevel);
- KP_VTRY (bc.compile_in (NIL, true, expr));
- bc.emit (OPX_(RET));
- valref ret = KP_TRY (alloc_fct (interp, function::artificial_flag));
- function *retp = as_fct (*ret);
- retp->bcode = bc.encode ();
- retp->vals = KP_TRY (bc.idxvec ());
- retp->max_sp = retp->max_stack ();
- return (*ret);
- }
- static result<object>
- macroexp_atom (interpreter *interp, object env, object sym)
- {
- object s2 = sym;
- if (nksymbol_p (s2) && (s2 = lookup_alias (env, sym)) == sym &&
- (as_symbol(s2)->flagged_p (symbol::alias_flag)))
- s2 = symval (s2);
- kp_return (s2);
- }
- static result<object>
- macroexp_cons (interpreter *interp, object env, object expr)
- {
- object x, h = xcar (expr);
- if (!symbol_p (h))
- kp_return (expr);
- else if ((x = lookup_ctv (env, h)) == h)
- {
- if (!as_symbol(h)->flagged_p (symbol::ctv_flag) ||
- !fct_p (interp->retval = symval (h)))
- kp_return (expr);
-
- x = interp->retval;
- }
- uint32_t n = 0;
- KP_VTRY (interp->push (x));
- for (expr = xcdr (expr); expr != NIL; expr = xcdr (expr), ++n)
- {
- if (!xcons_p (expr))
- return (interp->raise ("arg-error", "macro expasion requires "
- "a proper list as arguments"));
- KP_VTRY (macroexp_atom (interp, env, xcar (expr)),
- interp->push (interp->retval));
- }
- KP_TRY (call_n (interp, n));
- return (interp->retval);
- }
- result<object> macroexp_1 (interpreter *interp, object expr, object env)
- {
- return ((xcons_p (expr) ? macroexp_cons : macroexp_atom) (interp, env, expr));
- }
- result<object> macroexp (interpreter *interp, object expr, object env)
- {
- valref p (interp, expr);
- while (true)
- {
- *p = KP_TRY (macroexp_1 (interp, expr, env));
- if (expr == *p)
- kp_return (*p);
- expr = *p;
- }
- }
- result<object> compile_pkg (interpreter *interp, reader& rd)
- {
- bc_compiler::ctable_t ctable;
- raw_acc<bvector> bytecode;
- raw_acc<array> fvals;
- valref expr (interp, NIL);
- valref ret = KP_TRY (alloc_fct (interp, function::artificial_flag));
- function *retp = as_fct (*ret);
- KP_VTRY (interp->growstk (1));
- for (ctable.cmp.ip = interp ; ; )
- {
- *expr = KP_TRY (rd.read_sexpr ());
- if (*expr == EOS)
- break;
- *expr = KP_TRY (macroexp (interp, *expr));
- bc_compiler bc (interp, bc_compiler::flg_toplevel |
- bc_compiler::flg_warnings);
- ctable.swap (bc.ctable);
- KP_VTRY (bc.compile_in (NIL, false, *expr));
- bc.code.push_back (OPX_(RET));
- retp->bcode = bc.encode(false)->as_obj ();
- retp->name = retp->env = NIL;
- fvals.expand (bc.ctable.len ());
- retp->vals = bc.idxvec (fvals.as_obj ());
- retp->max_sp = retp->max_stack ();
- *interp->stkend++ = *ret;
- KP_VTRY (call_n (interp, 0));
- // Add a 'POP' instruction to mantain the stack size consistent.
- bvector *bvp = as_bvector (retp->bcode);
- bvp->data[bvp->nbytes - 1] = OP_POP;
- bytecode.add_data (bvp->data, bvp->nbytes);
- ctable.swap (bc.ctable);
- }
- unsigned char ret_code[] = { OP_RET };
- bytecode.add_data (ret_code, 1);
- retp->bcode = bytecode.release()->as_obj ();
- as_varobj(retp->bcode)->vo_full |= FLAGS_CONST;
- gc_register (interp, as_varobj (retp->bcode),
- sizeof (bvector) + bytecode.alloc);
- retp->vals = fvals.release()->as_obj ();
- as_varobj(retp->vals)->vo_full |= array::nonref_flag;
- gc_register (interp, as_varobj (retp->vals),
- sizeof (array) + fvals.alloc);
- retp->max_sp = retp->max_stack ();
- kp_return (*ret);
- }
- KP_DECLS_END
|