1 /*
2 * Copyright (c) 2021 Calvin Rose
3 *
4 * Permission is hereby granted, free of charge, to any person obtaining a copy
5 * of this software and associated documentation files (the "Software"), to
6 * deal in the Software without restriction, including without limitation the
7 * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
8 * sell copies of the Software, and to permit persons to whom the Software is
9 * furnished to do so, subject to the following conditions:
10 *
11 * The above copyright notice and this permission notice shall be included in
12 * all copies or substantial portions of the Software.
13 *
14 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
17 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
18 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
19 * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
20 * IN THE SOFTWARE.
21 */
22
23 #ifndef JANET_AMALG
24 #include "features.h"
25 #include <janet.h>
26 #include "compile.h"
27 #include "emit.h"
28 #include "vector.h"
29 #include "util.h"
30 #include "state.h"
31 #endif
32
janetc_fopts_default(JanetCompiler * c)33 JanetFopts janetc_fopts_default(JanetCompiler *c) {
34 JanetFopts ret;
35 ret.compiler = c;
36 ret.flags = 0;
37 ret.hint = janetc_cslot(janet_wrap_nil());
38 return ret;
39 }
40
41 /* Throw an error with a janet string. */
janetc_error(JanetCompiler * c,const uint8_t * m)42 void janetc_error(JanetCompiler *c, const uint8_t *m) {
43 /* Don't override first error */
44 if (c->result.status == JANET_COMPILE_ERROR) {
45 return;
46 }
47 c->result.status = JANET_COMPILE_ERROR;
48 c->result.error = m;
49 }
50
51 /* Throw an error with a message in a cstring */
janetc_cerror(JanetCompiler * c,const char * m)52 void janetc_cerror(JanetCompiler *c, const char *m) {
53 janetc_error(c, janet_cstring(m));
54 }
55
56 static const char *janet_lint_level_names[] = {
57 "relaxed",
58 "normal",
59 "strict"
60 };
61
62 /* Emit compiler linter messages */
janetc_lintf(JanetCompiler * c,JanetCompileLintLevel level,const char * format,...)63 void janetc_lintf(JanetCompiler *c, JanetCompileLintLevel level, const char *format, ...) {
64 if (NULL != c->lints) {
65 /* format message */
66 va_list args;
67 JanetBuffer buffer;
68 int32_t len = 0;
69 while (format[len]) len++;
70 janet_buffer_init(&buffer, len);
71 va_start(args, format);
72 janet_formatbv(&buffer, format, args);
73 va_end(args);
74 const uint8_t *str = janet_string(buffer.data, buffer.count);
75 janet_buffer_deinit(&buffer);
76 /* construct linting payload */
77 Janet *payload = janet_tuple_begin(4);
78 payload[0] = janet_ckeywordv(janet_lint_level_names[level]);
79 payload[1] = c->current_mapping.line == -1 ? janet_wrap_nil() : janet_wrap_integer(c->current_mapping.line);
80 payload[2] = c->current_mapping.column == -1 ? janet_wrap_nil() : janet_wrap_integer(c->current_mapping.column);
81 payload[3] = janet_wrap_string(str);
82 janet_array_push(c->lints, janet_wrap_tuple(janet_tuple_end(payload)));
83 }
84 }
85
86 /* Free a slot */
janetc_freeslot(JanetCompiler * c,JanetSlot s)87 void janetc_freeslot(JanetCompiler *c, JanetSlot s) {
88 if (s.flags & (JANET_SLOT_CONSTANT | JANET_SLOT_REF | JANET_SLOT_NAMED)) return;
89 if (s.envindex >= 0) return;
90 janetc_regalloc_free(&c->scope->ra, s.index);
91 }
92
93 /* Add a slot to a scope with a symbol associated with it (def or var). */
janetc_nameslot(JanetCompiler * c,const uint8_t * sym,JanetSlot s)94 void janetc_nameslot(JanetCompiler *c, const uint8_t *sym, JanetSlot s) {
95 SymPair sp;
96 sp.sym = sym;
97 sp.slot = s;
98 sp.keep = 0;
99 sp.slot.flags |= JANET_SLOT_NAMED;
100 janet_v_push(c->scope->syms, sp);
101 }
102
103 /* Create a slot with a constant */
janetc_cslot(Janet x)104 JanetSlot janetc_cslot(Janet x) {
105 JanetSlot ret;
106 ret.flags = (1 << janet_type(x)) | JANET_SLOT_CONSTANT;
107 ret.index = -1;
108 ret.constant = x;
109 ret.envindex = -1;
110 return ret;
111 }
112
113 /* Get a local slot */
janetc_farslot(JanetCompiler * c)114 JanetSlot janetc_farslot(JanetCompiler *c) {
115 JanetSlot ret;
116 ret.flags = JANET_SLOTTYPE_ANY;
117 ret.index = janetc_allocfar(c);
118 ret.constant = janet_wrap_nil();
119 ret.envindex = -1;
120 return ret;
121 }
122
123 /* Enter a new scope */
janetc_scope(JanetScope * s,JanetCompiler * c,int flags,const char * name)124 void janetc_scope(JanetScope *s, JanetCompiler *c, int flags, const char *name) {
125 JanetScope scope;
126 scope.name = name;
127 scope.child = NULL;
128 scope.consts = NULL;
129 scope.syms = NULL;
130 scope.envs = NULL;
131 scope.defs = NULL;
132 scope.bytecode_start = janet_v_count(c->buffer);
133 scope.flags = flags;
134 scope.parent = c->scope;
135 janetc_regalloc_init(&scope.ua);
136 /* Inherit slots */
137 if ((!(flags & JANET_SCOPE_FUNCTION)) && c->scope) {
138 janetc_regalloc_clone(&scope.ra, &(c->scope->ra));
139 } else {
140 janetc_regalloc_init(&scope.ra);
141 }
142 /* Link parent and child and update pointer */
143 if (c->scope)
144 c->scope->child = s;
145 c->scope = s;
146 *s = scope;
147 }
148
149 /* Leave a scope. */
janetc_popscope(JanetCompiler * c)150 void janetc_popscope(JanetCompiler *c) {
151 JanetScope *oldscope = c->scope;
152 JanetScope *newscope = oldscope->parent;
153 /* Move free slots to parent scope if not a new function.
154 * We need to know the total number of slots used when compiling the function. */
155 if (!(oldscope->flags & (JANET_SCOPE_FUNCTION | JANET_SCOPE_UNUSED)) && newscope) {
156 /* Parent scopes inherit child's closure flag. Needed
157 * for while loops. (if a while loop creates a closure, it
158 * is compiled to a tail recursive iife) */
159 if (oldscope->flags & JANET_SCOPE_CLOSURE) {
160 newscope->flags |= JANET_SCOPE_CLOSURE;
161 }
162 if (newscope->ra.max < oldscope->ra.max)
163 newscope->ra.max = oldscope->ra.max;
164
165 /* Keep upvalue slots */
166 for (int32_t i = 0; i < janet_v_count(oldscope->syms); i++) {
167 SymPair pair = oldscope->syms[i];
168 if (pair.keep) {
169 /* The variable should not be lexically accessible */
170 pair.sym = NULL;
171 janet_v_push(newscope->syms, pair);
172 janetc_regalloc_touch(&newscope->ra, pair.slot.index);
173 }
174 }
175
176 }
177 /* Free the old scope */
178 janet_v_free(oldscope->consts);
179 janet_v_free(oldscope->syms);
180 janet_v_free(oldscope->envs);
181 janet_v_free(oldscope->defs);
182 janetc_regalloc_deinit(&oldscope->ra);
183 janetc_regalloc_deinit(&oldscope->ua);
184 /* Update pointer */
185 if (newscope)
186 newscope->child = NULL;
187 c->scope = newscope;
188 }
189
190 /* Leave a scope but keep a slot allocated. */
janetc_popscope_keepslot(JanetCompiler * c,JanetSlot retslot)191 void janetc_popscope_keepslot(JanetCompiler *c, JanetSlot retslot) {
192 JanetScope *scope;
193 janetc_popscope(c);
194 scope = c->scope;
195 if (scope && retslot.envindex < 0 && retslot.index >= 0) {
196 janetc_regalloc_touch(&scope->ra, retslot.index);
197 }
198 }
199
200 /* Allow searching for symbols. Return information about the symbol */
janetc_resolve(JanetCompiler * c,const uint8_t * sym)201 JanetSlot janetc_resolve(
202 JanetCompiler *c,
203 const uint8_t *sym) {
204
205 JanetSlot ret = janetc_cslot(janet_wrap_nil());
206 JanetScope *scope = c->scope;
207 SymPair *pair;
208 int foundlocal = 1;
209 int unused = 0;
210
211 /* Search scopes for symbol, starting from top */
212 while (scope) {
213 int32_t i, len;
214 if (scope->flags & JANET_SCOPE_UNUSED)
215 unused = 1;
216 len = janet_v_count(scope->syms);
217 /* Search in reverse order */
218 for (i = len - 1; i >= 0; i--) {
219 pair = scope->syms + i;
220 if (pair->sym == sym) {
221 ret = pair->slot;
222 goto found;
223 }
224 }
225 if (scope->flags & JANET_SCOPE_FUNCTION)
226 foundlocal = 0;
227 scope = scope->parent;
228 }
229
230 /* Symbol not found - check for global */
231 {
232 JanetBinding binding = janet_resolve_ext(c->env, sym);
233 switch (binding.type) {
234 default:
235 case JANET_BINDING_NONE:
236 janetc_error(c, janet_formatc("unknown symbol %q", janet_wrap_symbol(sym)));
237 return janetc_cslot(janet_wrap_nil());
238 case JANET_BINDING_DEF:
239 case JANET_BINDING_MACRO: /* Macro should function like defs when not in calling pos */
240 ret = janetc_cslot(binding.value);
241 break;
242 case JANET_BINDING_VAR: {
243 ret = janetc_cslot(binding.value);
244 ret.flags |= JANET_SLOT_REF | JANET_SLOT_NAMED | JANET_SLOT_MUTABLE | JANET_SLOTTYPE_ANY;
245 ret.flags &= ~JANET_SLOT_CONSTANT;
246 break;
247 }
248 }
249 JanetCompileLintLevel depLevel = JANET_C_LINT_RELAXED;
250 switch (binding.deprecation) {
251 case JANET_BINDING_DEP_NONE:
252 break;
253 case JANET_BINDING_DEP_RELAXED:
254 depLevel = JANET_C_LINT_RELAXED;
255 break;
256 case JANET_BINDING_DEP_NORMAL:
257 depLevel = JANET_C_LINT_NORMAL;
258 break;
259 case JANET_BINDING_DEP_STRICT:
260 depLevel = JANET_C_LINT_STRICT;
261 break;
262 }
263 if (binding.deprecation != JANET_BINDING_DEP_NONE) {
264 janetc_lintf(c, depLevel, "%q is deprecated", janet_wrap_symbol(sym));
265 }
266 return ret;
267 }
268
269 /* Symbol was found */
270 found:
271
272 /* Constants can be returned immediately (they are stateless) */
273 if (ret.flags & (JANET_SLOT_CONSTANT | JANET_SLOT_REF))
274 return ret;
275
276 /* Unused references and locals shouldn't add captured envs. */
277 if (unused || foundlocal) {
278 ret.envindex = -1;
279 return ret;
280 }
281
282 /* non-local scope needs to expose its environment */
283 pair->keep = 1;
284 while (scope && !(scope->flags & JANET_SCOPE_FUNCTION))
285 scope = scope->parent;
286 janet_assert(scope, "invalid scopes");
287 scope->flags |= JANET_SCOPE_ENV;
288
289 /* In the function scope, allocate the slot as an upvalue */
290 janetc_regalloc_touch(&scope->ua, ret.index);
291
292 /* Iterate through child scopes and make sure environment is propagated */
293 scope = scope->child;
294
295 /* Propagate env up to current scope */
296 int32_t envindex = -1;
297 while (scope) {
298 if (scope->flags & JANET_SCOPE_FUNCTION) {
299 int32_t j, len;
300 int scopefound = 0;
301 /* Check if scope already has env. If so, break */
302 len = janet_v_count(scope->envs);
303 for (j = 0; j < len; j++) {
304 if (scope->envs[j] == envindex) {
305 scopefound = 1;
306 envindex = j;
307 break;
308 }
309 }
310 /* Add the environment if it is not already referenced */
311 if (!scopefound) {
312 len = janet_v_count(scope->envs);
313 janet_v_push(scope->envs, envindex);
314 envindex = len;
315 }
316 }
317 scope = scope->child;
318 }
319
320 ret.envindex = envindex;
321 return ret;
322 }
323
324 /* Generate the return instruction for a slot. */
janetc_return(JanetCompiler * c,JanetSlot s)325 JanetSlot janetc_return(JanetCompiler *c, JanetSlot s) {
326 if (!(s.flags & JANET_SLOT_RETURNED)) {
327 if (s.flags & JANET_SLOT_CONSTANT && janet_checktype(s.constant, JANET_NIL))
328 janetc_emit(c, JOP_RETURN_NIL);
329 else
330 janetc_emit_s(c, JOP_RETURN, s, 0);
331 s.flags |= JANET_SLOT_RETURNED;
332 }
333 return s;
334 }
335
336 /* Get a target slot for emitting an instruction. */
janetc_gettarget(JanetFopts opts)337 JanetSlot janetc_gettarget(JanetFopts opts) {
338 JanetSlot slot;
339 if ((opts.flags & JANET_FOPTS_HINT) &&
340 (opts.hint.envindex < 0) &&
341 (opts.hint.index >= 0 && opts.hint.index <= 0xFF)) {
342 slot = opts.hint;
343 } else {
344 slot.envindex = -1;
345 slot.constant = janet_wrap_nil();
346 slot.flags = 0;
347 slot.index = janetc_allocfar(opts.compiler);
348 }
349 return slot;
350 }
351
352 /* Get a bunch of slots for function arguments */
janetc_toslots(JanetCompiler * c,const Janet * vals,int32_t len)353 JanetSlot *janetc_toslots(JanetCompiler *c, const Janet *vals, int32_t len) {
354 int32_t i;
355 JanetSlot *ret = NULL;
356 JanetFopts subopts = janetc_fopts_default(c);
357 for (i = 0; i < len; i++) {
358 janet_v_push(ret, janetc_value(subopts, vals[i]));
359 }
360 return ret;
361 }
362
363 /* Get a bunch of slots for function arguments */
janetc_toslotskv(JanetCompiler * c,Janet ds)364 JanetSlot *janetc_toslotskv(JanetCompiler *c, Janet ds) {
365 JanetSlot *ret = NULL;
366 JanetFopts subopts = janetc_fopts_default(c);
367 const JanetKV *kvs = NULL;
368 int32_t cap = 0, len = 0;
369 janet_dictionary_view(ds, &kvs, &len, &cap);
370 for (int32_t i = 0; i < cap; i++) {
371 if (janet_checktype(kvs[i].key, JANET_NIL)) continue;
372 janet_v_push(ret, janetc_value(subopts, kvs[i].key));
373 janet_v_push(ret, janetc_value(subopts, kvs[i].value));
374 }
375 return ret;
376 }
377
378 /* Push slots loaded via janetc_toslots. Return the minimum number of slots pushed,
379 * or -1 - min_arity if there is a splice. (if there is no splice, min_arity is also
380 * the maximum possible arity). */
janetc_pushslots(JanetCompiler * c,JanetSlot * slots)381 int32_t janetc_pushslots(JanetCompiler *c, JanetSlot *slots) {
382 int32_t i;
383 int32_t count = janet_v_count(slots);
384 int32_t min_arity = 0;
385 int has_splice = 0;
386 for (i = 0; i < count;) {
387 if (slots[i].flags & JANET_SLOT_SPLICED) {
388 janetc_emit_s(c, JOP_PUSH_ARRAY, slots[i], 0);
389 i++;
390 has_splice = 1;
391 } else if (i + 1 == count) {
392 janetc_emit_s(c, JOP_PUSH, slots[i], 0);
393 i++;
394 min_arity++;
395 } else if (slots[i + 1].flags & JANET_SLOT_SPLICED) {
396 janetc_emit_s(c, JOP_PUSH, slots[i], 0);
397 janetc_emit_s(c, JOP_PUSH_ARRAY, slots[i + 1], 0);
398 i += 2;
399 min_arity++;
400 has_splice = 1;
401 } else if (i + 2 == count) {
402 janetc_emit_ss(c, JOP_PUSH_2, slots[i], slots[i + 1], 0);
403 i += 2;
404 min_arity += 2;
405 } else if (slots[i + 2].flags & JANET_SLOT_SPLICED) {
406 janetc_emit_ss(c, JOP_PUSH_2, slots[i], slots[i + 1], 0);
407 janetc_emit_s(c, JOP_PUSH_ARRAY, slots[i + 2], 0);
408 i += 3;
409 min_arity += 2;
410 has_splice = 1;
411 } else {
412 janetc_emit_sss(c, JOP_PUSH_3, slots[i], slots[i + 1], slots[i + 2], 0);
413 i += 3;
414 min_arity += 3;
415 }
416 }
417 return has_splice ? (-1 - min_arity) : min_arity;
418 }
419
420 /* Check if a list of slots has any spliced slots */
has_spliced(JanetSlot * slots)421 static int has_spliced(JanetSlot *slots) {
422 int32_t i;
423 for (i = 0; i < janet_v_count(slots); i++) {
424 if (slots[i].flags & JANET_SLOT_SPLICED)
425 return 1;
426 }
427 return 0;
428 }
429
430 /* Free slots loaded via janetc_toslots */
janetc_freeslots(JanetCompiler * c,JanetSlot * slots)431 void janetc_freeslots(JanetCompiler *c, JanetSlot *slots) {
432 int32_t i;
433 for (i = 0; i < janet_v_count(slots); i++) {
434 janetc_freeslot(c, slots[i]);
435 }
436 janet_v_free(slots);
437 }
438
439 /* Compile some code that will be thrown away. Used to ensure
440 * that dead code is well formed without including it in the final
441 * bytecode. */
janetc_throwaway(JanetFopts opts,Janet x)442 void janetc_throwaway(JanetFopts opts, Janet x) {
443 JanetCompiler *c = opts.compiler;
444 JanetScope unusedScope;
445 int32_t bufstart = janet_v_count(c->buffer);
446 int32_t mapbufstart = janet_v_count(c->mapbuffer);
447 janetc_scope(&unusedScope, c, JANET_SCOPE_UNUSED, "unusued");
448 janetc_value(opts, x);
449 janetc_lintf(c, JANET_C_LINT_STRICT, "dead code, consider removing %.2q", x);
450 janetc_popscope(c);
451 if (c->buffer) {
452 janet_v__cnt(c->buffer) = bufstart;
453 if (c->mapbuffer)
454 janet_v__cnt(c->mapbuffer) = mapbufstart;
455 }
456 }
457
458 /* Compile a call or tailcall instruction */
janetc_call(JanetFopts opts,JanetSlot * slots,JanetSlot fun)459 static JanetSlot janetc_call(JanetFopts opts, JanetSlot *slots, JanetSlot fun) {
460 JanetSlot retslot;
461 JanetCompiler *c = opts.compiler;
462 int specialized = 0;
463 if (fun.flags & JANET_SLOT_CONSTANT && !has_spliced(slots)) {
464 if (janet_checktype(fun.constant, JANET_FUNCTION)) {
465 JanetFunction *f = janet_unwrap_function(fun.constant);
466 const JanetFunOptimizer *o = janetc_funopt(f->def->flags);
467 if (o && (!o->can_optimize || o->can_optimize(opts, slots))) {
468 specialized = 1;
469 retslot = o->optimize(opts, slots);
470 }
471 }
472 /* TODO janet function inlining (no c functions)*/
473 }
474 if (!specialized) {
475 int32_t min_arity = janetc_pushslots(c, slots);
476 /* Check for provably incorrect function calls */
477 if (fun.flags & JANET_SLOT_CONSTANT) {
478
479 /* Check for bad arity type if fun is a constant */
480 switch (janet_type(fun.constant)) {
481 case JANET_FUNCTION: {
482 JanetFunction *f = janet_unwrap_function(fun.constant);
483 int32_t min = f->def->min_arity;
484 int32_t max = f->def->max_arity;
485 if (min_arity < 0) {
486 /* Call has splices */
487 min_arity = -1 - min_arity;
488 if (min_arity > max && max >= 0) {
489 const uint8_t *es = janet_formatc(
490 "%v expects at most %d argument%s, got at least %d",
491 fun.constant, max, max == 1 ? "" : "s", min_arity);
492 janetc_error(c, es);
493 }
494 } else {
495 /* Call has no splices */
496 if (min_arity > max && max >= 0) {
497 const uint8_t *es = janet_formatc(
498 "%v expects at most %d argument%s, got %d",
499 fun.constant, max, max == 1 ? "" : "s", min_arity);
500 janetc_error(c, es);
501 }
502 if (min_arity < min) {
503 const uint8_t *es = janet_formatc(
504 "%v expects at least %d argument%s, got %d",
505 fun.constant, min, min == 1 ? "" : "s", min_arity);
506 janetc_error(c, es);
507 }
508 }
509 }
510 break;
511 case JANET_CFUNCTION:
512 case JANET_ABSTRACT:
513 case JANET_NIL:
514 break;
515 case JANET_KEYWORD:
516 if (min_arity == 0) {
517 const uint8_t *es = janet_formatc("%v expects at least 1 argument, got 0",
518 fun.constant);
519 janetc_error(c, es);
520 }
521 break;
522 default:
523 if (min_arity > 1 || min_arity == 0) {
524 const uint8_t *es = janet_formatc("%v expects 1 argument, got %d",
525 fun.constant, min_arity);
526 janetc_error(c, es);
527 }
528 if (min_arity < -2) {
529 const uint8_t *es = janet_formatc("%v expects 1 argument, got at least %d",
530 fun.constant, -1 - min_arity);
531 janetc_error(c, es);
532 }
533 break;
534 }
535 }
536
537 if ((opts.flags & JANET_FOPTS_TAIL) &&
538 /* Prevent top level tail calls for better errors */
539 !(c->scope->flags & JANET_SCOPE_TOP)) {
540 janetc_emit_s(c, JOP_TAILCALL, fun, 0);
541 retslot = janetc_cslot(janet_wrap_nil());
542 retslot.flags = JANET_SLOT_RETURNED;
543 } else {
544 retslot = janetc_gettarget(opts);
545 janetc_emit_ss(c, JOP_CALL, retslot, fun, 1);
546 }
547 }
548 janetc_freeslots(c, slots);
549 return retslot;
550 }
551
janetc_maker(JanetFopts opts,JanetSlot * slots,int op)552 static JanetSlot janetc_maker(JanetFopts opts, JanetSlot *slots, int op) {
553 JanetCompiler *c = opts.compiler;
554 JanetSlot retslot;
555
556 /* Check if this structure is composed entirely of constants */
557 int can_inline = 1;
558 for (int32_t i = 0; i < janet_v_count(slots); i++) {
559 if (!(slots[i].flags & JANET_SLOT_CONSTANT) ||
560 (slots[i].flags & JANET_SLOT_SPLICED)) {
561 can_inline = 0;
562 break;
563 }
564 }
565
566 if (can_inline && (op == JOP_MAKE_STRUCT)) {
567 JanetKV *st = janet_struct_begin(janet_v_count(slots) / 2);
568 for (int32_t i = 0; i < janet_v_count(slots); i += 2) {
569 Janet k = slots[i].constant;
570 Janet v = slots[i + 1].constant;
571 janet_struct_put(st, k, v);
572 }
573 retslot = janetc_cslot(janet_wrap_struct(janet_struct_end(st)));
574 janetc_freeslots(c, slots);
575 } else if (can_inline && (op == JOP_MAKE_TUPLE)) {
576 Janet *tup = janet_tuple_begin(janet_v_count(slots));
577 for (int32_t i = 0; i < janet_v_count(slots); i++) {
578 tup[i] = slots[i].constant;
579 }
580 retslot = janetc_cslot(janet_wrap_tuple(janet_tuple_end(tup)));
581 janetc_freeslots(c, slots);
582 } else {
583 janetc_pushslots(c, slots);
584 janetc_freeslots(c, slots);
585 retslot = janetc_gettarget(opts);
586 janetc_emit_s(c, op, retslot, 1);
587 }
588
589 return retslot;
590 }
591
janetc_array(JanetFopts opts,Janet x)592 static JanetSlot janetc_array(JanetFopts opts, Janet x) {
593 JanetCompiler *c = opts.compiler;
594 JanetArray *a = janet_unwrap_array(x);
595 return janetc_maker(opts,
596 janetc_toslots(c, a->data, a->count),
597 JOP_MAKE_ARRAY);
598 }
599
janetc_tuple(JanetFopts opts,Janet x)600 static JanetSlot janetc_tuple(JanetFopts opts, Janet x) {
601 JanetCompiler *c = opts.compiler;
602 const Janet *t = janet_unwrap_tuple(x);
603 return janetc_maker(opts,
604 janetc_toslots(c, t, janet_tuple_length(t)),
605 JOP_MAKE_TUPLE);
606 }
607
janetc_tablector(JanetFopts opts,Janet x,int op)608 static JanetSlot janetc_tablector(JanetFopts opts, Janet x, int op) {
609 JanetCompiler *c = opts.compiler;
610 return janetc_maker(opts,
611 janetc_toslotskv(c, x),
612 op);
613 }
614
janetc_bufferctor(JanetFopts opts,Janet x)615 static JanetSlot janetc_bufferctor(JanetFopts opts, Janet x) {
616 JanetCompiler *c = opts.compiler;
617 JanetBuffer *b = janet_unwrap_buffer(x);
618 Janet onearg = janet_stringv(b->data, b->count);
619 return janetc_maker(opts,
620 janetc_toslots(c, &onearg, 1),
621 JOP_MAKE_BUFFER);
622 }
623
624 /* Expand a macro one time. Also get the special form compiler if we
625 * find that instead. */
macroexpand1(JanetCompiler * c,Janet x,Janet * out,const JanetSpecial ** spec)626 static int macroexpand1(
627 JanetCompiler *c,
628 Janet x,
629 Janet *out,
630 const JanetSpecial **spec) {
631 if (!janet_checktype(x, JANET_TUPLE))
632 return 0;
633 const Janet *form = janet_unwrap_tuple(x);
634 if (janet_tuple_length(form) == 0)
635 return 0;
636 /* Source map - only set when we get a tuple */
637 if (janet_tuple_sm_line(form) >= 0) {
638 c->current_mapping.line = janet_tuple_sm_line(form);
639 c->current_mapping.column = janet_tuple_sm_column(form);
640 }
641 /* Bracketed tuples are not specials or macros! */
642 if (janet_tuple_flag(form) & JANET_TUPLE_FLAG_BRACKETCTOR)
643 return 0;
644 if (!janet_checktype(form[0], JANET_SYMBOL))
645 return 0;
646 const uint8_t *name = janet_unwrap_symbol(form[0]);
647 const JanetSpecial *s = janetc_special(name);
648 if (s) {
649 *spec = s;
650 return 0;
651 }
652 Janet macroval;
653 JanetBindingType btype = janet_resolve(c->env, name, ¯oval);
654 if (btype != JANET_BINDING_MACRO ||
655 !janet_checktype(macroval, JANET_FUNCTION))
656 return 0;
657
658 /* Evaluate macro */
659 JanetFunction *macro = janet_unwrap_function(macroval);
660 int32_t arity = janet_tuple_length(form) - 1;
661 JanetFiber *fiberp = janet_fiber(macro, 64, arity, form + 1);
662 if (NULL == fiberp) {
663 int32_t minar = macro->def->min_arity;
664 int32_t maxar = macro->def->max_arity;
665 const uint8_t *es = NULL;
666 if (minar >= 0 && arity < minar)
667 es = janet_formatc("macro arity mismatch, expected at least %d, got %d", minar, arity);
668 if (maxar >= 0 && arity > maxar)
669 es = janet_formatc("macro arity mismatch, expected at most %d, got %d", maxar, arity);
670 c->result.macrofiber = NULL;
671 janetc_error(c, es);
672 return 0;
673 }
674 /* Set env */
675 fiberp->env = c->env;
676 int lock = janet_gclock();
677 Janet mf_kw = janet_ckeywordv("macro-form");
678 janet_table_put(c->env, mf_kw, x);
679 Janet tempOut;
680 JanetSignal status = janet_continue(fiberp, janet_wrap_nil(), &tempOut);
681 janet_table_put(c->env, mf_kw, janet_wrap_nil());
682 if (c->lints) {
683 janet_table_put(c->env, janet_ckeywordv("macro-lints"), janet_wrap_array(c->lints));
684 }
685 janet_gcunlock(lock);
686 if (status != JANET_SIGNAL_OK) {
687 const uint8_t *es = janet_formatc("(macro) %V", tempOut);
688 c->result.macrofiber = fiberp;
689 janetc_error(c, es);
690 return 0;
691 } else {
692 *out = tempOut;
693 }
694
695 return 1;
696 }
697
698 /* Compile a single value */
janetc_value(JanetFopts opts,Janet x)699 JanetSlot janetc_value(JanetFopts opts, Janet x) {
700 JanetSlot ret;
701 JanetCompiler *c = opts.compiler;
702 JanetSourceMapping last_mapping = c->current_mapping;
703 c->recursion_guard--;
704
705 /* Guard against previous errors and unbounded recursion */
706 if (c->result.status == JANET_COMPILE_ERROR) return janetc_cslot(janet_wrap_nil());
707 if (c->recursion_guard <= 0) {
708 janetc_cerror(c, "recursed too deeply");
709 return janetc_cslot(janet_wrap_nil());
710 }
711
712 /* Macro expand. Also gets possible special form and
713 * refines source mapping cursor if possible. */
714 const JanetSpecial *spec = NULL;
715 int macroi = JANET_MAX_MACRO_EXPAND;
716 while (macroi &&
717 c->result.status != JANET_COMPILE_ERROR &&
718 macroexpand1(c, x, &x, &spec))
719 macroi--;
720 if (macroi == 0) {
721 janetc_cerror(c, "recursed too deeply in macro expansion");
722 return janetc_cslot(janet_wrap_nil());
723 }
724
725 /* Special forms */
726 if (spec) {
727 const Janet *tup = janet_unwrap_tuple(x);
728 ret = spec->compile(opts, janet_tuple_length(tup) - 1, tup + 1);
729 } else {
730 switch (janet_type(x)) {
731 case JANET_TUPLE: {
732 JanetFopts subopts = janetc_fopts_default(c);
733 const Janet *tup = janet_unwrap_tuple(x);
734 /* Empty tuple is tuple literal */
735 if (janet_tuple_length(tup) == 0) {
736 ret = janetc_cslot(janet_wrap_tuple(janet_tuple_n(NULL, 0)));
737 } else if (janet_tuple_flag(tup) & JANET_TUPLE_FLAG_BRACKETCTOR) { /* [] tuples are not function call */
738 ret = janetc_tuple(opts, x);
739 } else {
740 JanetSlot head = janetc_value(subopts, tup[0]);
741 subopts.flags = JANET_FUNCTION | JANET_CFUNCTION;
742 ret = janetc_call(opts, janetc_toslots(c, tup + 1, janet_tuple_length(tup) - 1), head);
743 janetc_freeslot(c, head);
744 }
745 ret.flags &= ~JANET_SLOT_SPLICED;
746 }
747 break;
748 case JANET_SYMBOL:
749 ret = janetc_resolve(c, janet_unwrap_symbol(x));
750 break;
751 case JANET_ARRAY:
752 ret = janetc_array(opts, x);
753 break;
754 case JANET_STRUCT:
755 ret = janetc_tablector(opts, x, JOP_MAKE_STRUCT);
756 break;
757 case JANET_TABLE:
758 ret = janetc_tablector(opts, x, JOP_MAKE_TABLE);
759 break;
760 case JANET_BUFFER:
761 ret = janetc_bufferctor(opts, x);
762 break;
763 default:
764 ret = janetc_cslot(x);
765 break;
766 }
767 }
768
769 if (c->result.status == JANET_COMPILE_ERROR)
770 return janetc_cslot(janet_wrap_nil());
771 if (opts.flags & JANET_FOPTS_TAIL)
772 ret = janetc_return(c, ret);
773 if (opts.flags & JANET_FOPTS_HINT) {
774 janetc_copy(c, opts.hint, ret);
775 ret = opts.hint;
776 }
777 c->current_mapping = last_mapping;
778 c->recursion_guard++;
779 return ret;
780 }
781
782 /* Add function flags to janet functions */
janet_def_addflags(JanetFuncDef * def)783 void janet_def_addflags(JanetFuncDef *def) {
784 int32_t set_flags = 0;
785 int32_t unset_flags = 0;
786 /* pos checks */
787 if (def->name) set_flags |= JANET_FUNCDEF_FLAG_HASNAME;
788 if (def->source) set_flags |= JANET_FUNCDEF_FLAG_HASSOURCE;
789 if (def->defs) set_flags |= JANET_FUNCDEF_FLAG_HASDEFS;
790 if (def->environments) set_flags |= JANET_FUNCDEF_FLAG_HASENVS;
791 if (def->sourcemap) set_flags |= JANET_FUNCDEF_FLAG_HASSOURCEMAP;
792 if (def->closure_bitset) set_flags |= JANET_FUNCDEF_FLAG_HASCLOBITSET;
793 /* negative checks */
794 if (!def->name) unset_flags |= JANET_FUNCDEF_FLAG_HASNAME;
795 if (!def->source) unset_flags |= JANET_FUNCDEF_FLAG_HASSOURCE;
796 if (!def->defs) unset_flags |= JANET_FUNCDEF_FLAG_HASDEFS;
797 if (!def->environments) unset_flags |= JANET_FUNCDEF_FLAG_HASENVS;
798 if (!def->sourcemap) unset_flags |= JANET_FUNCDEF_FLAG_HASSOURCEMAP;
799 if (!def->closure_bitset) unset_flags |= JANET_FUNCDEF_FLAG_HASCLOBITSET;
800 /* Update flags */
801 def->flags |= set_flags;
802 def->flags &= ~unset_flags;
803 }
804
805 /* Compile a funcdef */
806 /* Once the various other settings of the FuncDef have been tweaked,
807 * call janet_def_addflags to set the proper flags for the funcdef */
janetc_pop_funcdef(JanetCompiler * c)808 JanetFuncDef *janetc_pop_funcdef(JanetCompiler *c) {
809 JanetScope *scope = c->scope;
810 JanetFuncDef *def = janet_funcdef_alloc();
811 def->slotcount = scope->ra.max + 1;
812
813 janet_assert(scope->flags & JANET_SCOPE_FUNCTION, "expected function scope");
814
815 /* Copy envs */
816 def->environments_length = janet_v_count(scope->envs);
817 def->environments = janet_v_flatten(scope->envs);
818
819 def->constants_length = janet_v_count(scope->consts);
820 def->constants = janet_v_flatten(scope->consts);
821
822 def->defs_length = janet_v_count(scope->defs);
823 def->defs = janet_v_flatten(scope->defs);
824
825 /* Copy bytecode (only last chunk) */
826 def->bytecode_length = janet_v_count(c->buffer) - scope->bytecode_start;
827 if (def->bytecode_length) {
828 size_t s = sizeof(int32_t) * (size_t) def->bytecode_length;
829 def->bytecode = janet_malloc(s);
830 if (NULL == def->bytecode) {
831 JANET_OUT_OF_MEMORY;
832 }
833 safe_memcpy(def->bytecode, c->buffer + scope->bytecode_start, s);
834 janet_v__cnt(c->buffer) = scope->bytecode_start;
835 if (NULL != c->mapbuffer && c->source) {
836 size_t s = sizeof(JanetSourceMapping) * (size_t) def->bytecode_length;
837 def->sourcemap = janet_malloc(s);
838 if (NULL == def->sourcemap) {
839 JANET_OUT_OF_MEMORY;
840 }
841 safe_memcpy(def->sourcemap, c->mapbuffer + scope->bytecode_start, s);
842 janet_v__cnt(c->mapbuffer) = scope->bytecode_start;
843 }
844 }
845
846 /* Get source from parser */
847 def->source = c->source;
848
849 def->arity = 0;
850 def->min_arity = 0;
851 def->flags = 0;
852 if (scope->flags & JANET_SCOPE_ENV) {
853 def->flags |= JANET_FUNCDEF_FLAG_NEEDSENV;
854 }
855
856 /* Copy upvalue bitset */
857 if (scope->ua.count) {
858 /* Number of u32s we need to create a bitmask for all slots */
859 int32_t slotchunks = (def->slotcount + 31) >> 5;
860 /* numchunks is min of slotchunks and scope->ua.count */
861 int32_t numchunks = slotchunks > scope->ua.count ? scope->ua.count : slotchunks;
862 uint32_t *chunks = janet_calloc(sizeof(uint32_t), slotchunks);
863 if (NULL == chunks) {
864 JANET_OUT_OF_MEMORY;
865 }
866 memcpy(chunks, scope->ua.chunks, sizeof(uint32_t) * numchunks);
867 /* Register allocator preallocates some registers [240-255, high 16 bits of chunk index 7], we can ignore those. */
868 if (scope->ua.count > 7) chunks[7] &= 0xFFFFU;
869 def->closure_bitset = chunks;
870 }
871
872 /* Pop the scope */
873 janetc_popscope(c);
874
875 return def;
876 }
877
878 /* Initialize a compiler */
janetc_init(JanetCompiler * c,JanetTable * env,const uint8_t * where,JanetArray * lints)879 static void janetc_init(JanetCompiler *c, JanetTable *env, const uint8_t *where, JanetArray *lints) {
880 c->scope = NULL;
881 c->buffer = NULL;
882 c->mapbuffer = NULL;
883 c->recursion_guard = JANET_RECURSION_GUARD;
884 c->env = env;
885 c->source = where;
886 c->current_mapping.line = -1;
887 c->current_mapping.column = -1;
888 c->lints = lints;
889 /* Init result */
890 c->result.error = NULL;
891 c->result.status = JANET_COMPILE_OK;
892 c->result.funcdef = NULL;
893 c->result.macrofiber = NULL;
894 c->result.error_mapping.line = -1;
895 c->result.error_mapping.column = -1;
896 }
897
898 /* Deinitialize a compiler struct */
janetc_deinit(JanetCompiler * c)899 static void janetc_deinit(JanetCompiler *c) {
900 janet_v_free(c->buffer);
901 janet_v_free(c->mapbuffer);
902 c->env = NULL;
903 }
904
905 /* Compile a form. */
janet_compile_lint(Janet source,JanetTable * env,const uint8_t * where,JanetArray * lints)906 JanetCompileResult janet_compile_lint(Janet source,
907 JanetTable *env, const uint8_t *where, JanetArray *lints) {
908 JanetCompiler c;
909 JanetScope rootscope;
910 JanetFopts fopts;
911
912 janetc_init(&c, env, where, lints);
913
914 /* Push a function scope */
915 janetc_scope(&rootscope, &c, JANET_SCOPE_FUNCTION | JANET_SCOPE_TOP, "root");
916
917 /* Set initial form options */
918 fopts.compiler = &c;
919 fopts.flags = JANET_FOPTS_TAIL | JANET_SLOTTYPE_ANY;
920 fopts.hint = janetc_cslot(janet_wrap_nil());
921
922 /* Compile the value */
923 janetc_value(fopts, source);
924
925 if (c.result.status == JANET_COMPILE_OK) {
926 JanetFuncDef *def = janetc_pop_funcdef(&c);
927 def->name = janet_cstring("_thunk");
928 janet_def_addflags(def);
929 c.result.funcdef = def;
930 } else {
931 c.result.error_mapping = c.current_mapping;
932 janetc_popscope(&c);
933 }
934
935 janetc_deinit(&c);
936
937 return c.result;
938 }
939
janet_compile(Janet source,JanetTable * env,const uint8_t * where)940 JanetCompileResult janet_compile(Janet source, JanetTable *env, const uint8_t *where) {
941 return janet_compile_lint(source, env, where, NULL);
942 }
943
944 /* C Function for compiling */
945 JANET_CORE_FN(cfun,
946 "(compile ast &opt env source lints)",
947 "Compiles an Abstract Syntax Tree (ast) into a function. "
948 "Pair the compile function with parsing functionality to implement "
949 "eval. Returns a new function and does not modify ast. Returns an error "
950 "struct with keys :line, :column, and :error if compilation fails. "
951 "If a `lints` array is given, linting messages will be appended to the array. "
952 "Each message will be a tuple of the form `(level line col message)`.") {
953 janet_arity(argc, 1, 4);
954 JanetTable *env = argc > 1 ? janet_gettable(argv, 1) : janet_vm.fiber->env;
955 if (NULL == env) {
956 env = janet_table(0);
957 janet_vm.fiber->env = env;
958 }
959 const uint8_t *source = NULL;
960 if (argc >= 3) {
961 source = janet_getstring(argv, 2);
962 }
963 JanetArray *lints = (argc >= 4) ? janet_getarray(argv, 3) : NULL;
964 JanetCompileResult res = janet_compile_lint(argv[0], env, source, lints);
965 if (res.status == JANET_COMPILE_OK) {
966 return janet_wrap_function(janet_thunk(res.funcdef));
967 } else {
968 JanetTable *t = janet_table(4);
969 janet_table_put(t, janet_ckeywordv("error"), janet_wrap_string(res.error));
970 if (res.error_mapping.line > 0) {
971 janet_table_put(t, janet_ckeywordv("line"), janet_wrap_integer(res.error_mapping.line));
972 }
973 if (res.error_mapping.column > 0) {
974 janet_table_put(t, janet_ckeywordv("column"), janet_wrap_integer(res.error_mapping.column));
975 }
976 if (res.macrofiber) {
977 janet_table_put(t, janet_ckeywordv("fiber"), janet_wrap_fiber(res.macrofiber));
978 }
979 return janet_wrap_table(t);
980 }
981 }
982
janet_lib_compile(JanetTable * env)983 void janet_lib_compile(JanetTable *env) {
984 JanetRegExt cfuns[] = {
985 JANET_CORE_REG("compile", cfun),
986 JANET_REG_END
987 };
988 janet_core_cfuns_ext(env, NULL, cfuns);
989 }
990