/*-*- mode:c;indent-tabs-mode:nil;c-basic-offset:2;tab-width:8;coding:utf-8 -*-│ │vi: set net ft=c ts=2 sts=2 sw=2 fenc=utf-8 :vi│ ╞══════════════════════════════════════════════════════════════════════════════╡ │ Copyright 2022 Justine Alexandra Roberts Tunney │ │ │ │ Permission to use, copy, modify, and/or distribute this software for │ │ any purpose with or without fee is hereby granted, provided that the │ │ above copyright notice and this permission notice appear in all copies. │ │ │ │ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL │ │ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED │ │ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE │ │ AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL │ │ DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR │ │ PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER │ │ TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR │ │ PERFORMANCE OF THIS SOFTWARE. │ ╚─────────────────────────────────────────────────────────────────────────────*/ #include "libc/bits/likely.h" #include "libc/calls/calls.h" #include "libc/calls/strace.internal.h" #include "libc/calls/struct/sigaction.h" #include "libc/intrin/kprintf.h" #include "libc/log/countbranch.h" #include "libc/log/countexpr.h" #include "libc/log/log.h" #include "libc/macros.internal.h" #include "libc/nexgen32e/rdtsc.h" #include "libc/runtime/runtime.h" #include "libc/runtime/stack.h" #include "libc/runtime/symbols.internal.h" #include "libc/str/str.h" #include "libc/sysv/consts/map.h" #include "libc/sysv/consts/o.h" #include "libc/sysv/consts/prot.h" #include "libc/sysv/consts/sig.h" #include "libc/time/clockstonanos.internal.h" #include "third_party/getopt/getopt.h" #include "tool/build/lib/case.h" #include "tool/plinko/lib/char.h" #include "tool/plinko/lib/error.h" #include "tool/plinko/lib/gc.h" #include "tool/plinko/lib/histo.h" #include "tool/plinko/lib/index.h" #include "tool/plinko/lib/plinko.h" #include "tool/plinko/lib/print.h" #include "tool/plinko/lib/printf.h" #include "tool/plinko/lib/stack.h" #include "tool/plinko/lib/trace.h" #include "tool/plinko/lib/tree.h" STATIC_STACK_SIZE(0x100000); #define PUTS(f, s) write(f, s, strlen(s)) #define DISPATCH(ea, tm, r, p1, p2) \ GetDispatchFn(LO(ea))(ea, tm, r, p1, p2, GetShadow(LO(ea))) static void Unwind(int S) { int s; dword t; while (sp > S) { s = --sp & MASK(STACK); if ((t = g_stack[s])) { g_stack[s] = 0; cx = ~HI(t); } } } static void Backtrace(int S) { int i; dword f; for (i = 0; sp > S && i < STACK; ++i) { f = Pop(); Fprintf(2, "%d %p%n", ~HI(f), LO(f)); g_stack[sp & MASK(STACK)] = 0; } } forceinline bool ShouldIgnoreGarbage(int A) { static unsigned cadence; if (DEBUG_GARBAGE) return false; if (!(++cadence & AVERSIVENESS)) return false; return true; } static inline bool ShouldPanicAboutGarbage(int A) { return false; } static inline bool ShouldAbort(int A) { return cx <= A + BANE / STACK * 3; // hacked thrice permitted memory } static relegated dontinline int ErrorExpr(void) { Raise(kError); } static int Order(int x, int y) { if (x < y) return -1; if (x > y) return +1; return 0; } static int Append(int x, int y) { if (!x) return y; return Cons(Car(x), Append(Cdr(x), y)); } static int ReconstructAlist(int a) { int r; for (r = 0; a < 0; a = Cdr(a)) { if (Car(a) == kClosure) { return Reverse(r, a); } if (Caar(a) < 0) { r = Reverse(r, a); } else if (!Assoc(Caar(a), r)) { r = Cons(Car(a), r); } } return Reverse(r, 0); } static bool AtomEquals(int x, const char *s) { dword t; do { if (!*s) return false; t = Get(x); if (LO(t) != *s++) return false; // xxx: ascii } while ((x = HI(t)) != TERM); return !*s; } static pureconst int LastCons(int x) { while (Cdr(x)) x = Cdr(x); return x; } static pureconst int LastChar(int x) { dword e; do e = Get(x); while ((x = HI(e)) != TERM); return LO(e); } forceinline pureconst bool IsClosure(int x) { return x < 0 && Car(x) == kClosure; } forceinline pureconst bool IsQuote(int x) { return x < 0 && Car(x) == kQuote; } static int Quote(int x) { if (IsClosure(x)) return x; if (IsPrecious(x)) return x; return List(kQuote, x); } static int QuoteList(int x) { if (!x) return x; return Cons(Quote(Car(x)), QuoteList(Cdr(x))); } static int GetAtom(const char *s) { int x, y, t, u; ax = y = TERM; x = *s++ & 255; if (*s) y = GetAtom(s); return Intern(x, y); } static int Gensym(void) { char B[16], t; static unsigned g; unsigned a, b, x, n; n = 0; x = g++; B[n++] = L'G'; do B[n++] = L'0' + (x & 7); while ((x >>= 3)); B[n] = 0; for (a = 1, b = n - 1; a < b; ++a, --b) { t = B[a]; B[a] = B[b]; B[b] = t; } return GetAtom(B); } static nosideeffect bool Member(int v, int x) { while (x) { if (x > 0) return v == x; if (v == Car(x)) return true; x = Cdr(x); } return false; } static int GetBindings(int x, int a) { int r, b; for (r = 0; x < 0; x = Cdr(x)) { if ((b = Assoc(Car(x), a))) { r = Cons(b, r); } else { Error("could not find dependency %S in %p", Car(x), a); } } return r; } static int Lambda(int e, int a, dword p1, dword p2) { int u; if (p1) a = Alist(LO(p1), HI(p1), a); if (p2) a = Alist(LO(p2), HI(p2), a); if (DEBUG_CLOSURE || logc) { u = FindFreeVariables(e, 0, 0); a = GetBindings(u, a); } return Enclose(e, a); } static int Function(int e, int a, dword p1, dword p2) { int u; if (e < 0 && Car(e) == kLambda) e = Lambda(e, a, p1, p2); if (e >= 0 || Car(e) != kClosure) Error("not a closure"); a = Cddr(e); e = Cadr(e); u = FindFreeVariables(e, 0, 0); a = GetBindings(u, a); return Enclose(e, a); } static int Simplify(int e, int a) { return Function(e, a, 0, 0); } static int PrintFn(int x) { int y; DCHECK_LT(x, TERM); y = Car(x); while ((x = Cdr(x))) { if (!quiet) { Print(1, y); PrintSpace(1); } y = Car(x); } if (!quiet) { Print(1, y); PrintNewline(1); } return y; } static int PprintFn(int x) { int y, n; DCHECK_LT(x, TERM); n = 0; y = Car(x); while ((x = Cdr(x))) { if (!quiet) { n += Print(1, y); n += PrintSpace(1); } y = Car(x); } if (!quiet) { PrettyPrint(1, y, n); PrintNewline(1); } Flush(1); return y; } static relegated struct T DispatchRetImpossible(dword ea, dword tm, dword r) { Fprintf(2, "ERROR: \e[7;31mIMPOSSIBLE RETURN\e[0m NO %d%n"); Raise(LO(ea)); } static relegated struct T DispatchTailImpossible(dword ea, dword tm, dword r, dword p1, dword p2) { Fprintf(2, "ERROR: \e[7;31mIMPOSSIBLE TAIL\e[0m NO %d%n"); Raise(LO(ea)); } static struct T DispatchRet(dword ea, dword tm, dword r) { return (struct T){LO(ea)}; } static struct T DispatchLeave(dword ea, dword tm, dword r) { Pop(); return (struct T){LO(ea)}; } static struct T DispatchLeaveGc(dword ea, dword tm, dword r) { int A, e; e = LO(ea); A = GetFrameCx(); if (e < A && cx < A && UNLIKELY(!ShouldIgnoreGarbage(A))) { e = MarkSweep(A, e); } Pop(); return (struct T){e}; } static struct T DispatchLeaveTmcGc(dword ea, dword tm, dword r) { int A, e; A = GetFrameCx(); e = Reverse(LO(tm), LO(ea)); if (!ShouldIgnoreGarbage(A)) { e = MarkSweep(A, e); } Pop(); return (struct T){e}; } RetFn *const kRet[] = { DispatchRet, // DispatchRetImpossible, // DispatchRetImpossible, // DispatchRetImpossible, // DispatchLeave, // DispatchLeaveGc, // DispatchRetImpossible, // DispatchLeaveTmcGc, // }; struct T DispatchTail(dword ea, dword tm, dword r, dword p1, dword p2) { return DISPATCH(ea, tm, r, p1, p2); } struct T DispatchTailGc(dword ea, dword tm, dword r, dword p1, dword p2) { int A; struct Gc *G; A = GetFrameCx(); if (cx < A && UNLIKELY(!ShouldIgnoreGarbage(A))) { if (ShouldPanicAboutGarbage(A)) { if (!ShouldAbort(A)) { ea = MAKE(LO(ea), ReconstructAlist(HI(ea))); } else { Raise(kCycle); } } G = NewGc(A); Mark(G, LO(ea)); Mark(G, HI(ea)); Mark(G, HI(p1)); Mark(G, HI(p2)); Census(G); p1 = MAKE(LO(p1), Relocate(G, HI(p1))); p2 = MAKE(LO(p2), Relocate(G, HI(p2))); ea = MAKE(Relocate(G, LO(ea)), Relocate(G, HI(ea))); Sweep(G); } return DISPATCH(ea, tm, r, p1, p2); } struct T DispatchTailTmcGc(dword ea, dword tm, dword r, dword p1, dword p2) { int A; struct Gc *G; A = GetFrameCx(); if (UNLIKELY(!ShouldIgnoreGarbage(A))) { if (ShouldPanicAboutGarbage(A)) { if (!ShouldAbort(A)) { ea = MAKE(LO(ea), ReconstructAlist(HI(ea))); } else { Raise(kCycle); } } G = NewGc(A); Mark(G, LO(tm)); Mark(G, LO(ea)); Mark(G, HI(ea)); Mark(G, HI(p1)); Mark(G, HI(p2)); Census(G); p1 = MAKE(LO(p1), Relocate(G, HI(p1))); p2 = MAKE(LO(p2), Relocate(G, HI(p2))); ea = MAKE(Relocate(G, LO(ea)), Relocate(G, HI(ea))); tm = MAKE(Relocate(G, LO(tm)), Relocate(G, HI(tm))); Sweep(G); } return DISPATCH(ea, tm, r, p1, p2); } struct T DispatchNil(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { return Ret(0, tm, r); // 𝑥 ⟹ ⊥ } struct T DispatchTrue(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { return Ret(1, tm, r); // 𝑥 ⟹ ⊤ } struct T DispatchPrecious(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { return Ret(ea, tm, r); // 𝑘 ⟹ 𝑘 } struct T DispatchIdentity(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { return Ret(ea, tm, r); // e.g. (⅄ (λ 𝑥 𝑦) 𝑎) ⟹ (⅄ (λ 𝑥 𝑦) 𝑎) } struct T DispatchShortcut(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { return Ret(MAKE(HI(d), 0), tm, r); } struct T DispatchLookup(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int e, a, kv; e = LO(ea); a = HI(ea); DCHECK(!IsPrecious(e)); DCHECK_GT(e, 0); DCHECK_LE(a, 0); if (LO(p1) == LO(ea)) return Ret(MAKE(HI(p1), 0), tm, r); if (LO(p2) == LO(ea)) return Ret(MAKE(HI(p2), 0), tm, r); if ((kv = Assoc(e, a))) { return Ret(MAKE(Cdr(kv), 0), tm, r); // (eval 𝑘 (…(𝑘 𝑣)…)) ⟹ 𝑣 } else { Error("crash variable %S%n", e); } } struct T DispatchQuote(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { return Ret(MAKE(HI(d), 0), tm, r); // (Ω 𝑥) ⟹ 𝑥 } struct T DispatchAtom(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int x = FasterRecurse(HI(d), HI(ea), p1, p2); return Ret(MAKE(x >= 0, 0), tm, r); // (α (𝑥 . 𝑦)) ⟹ ⊥, (α 𝑘) ⟹ ⊤ } struct T DispatchCar(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int x = FasterRecurse(HI(d), HI(ea), p1, p2); return Ret(MAKE(Head(x), 0), tm, r); // (⍅ (𝑥 . 𝑦)) ⟹ 𝑥 } struct T DispatchCdr(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int x = FasterRecurse(HI(d), HI(ea), p1, p2); return Ret(MAKE(Tail(x), 0), tm, r); // (⍆ (𝑥 . 𝑦)) ⟹ 𝑦 } struct T DispatchEq(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int x = FasterRecurse(ARG1(LO(ea)), HI(ea), p1, p2); int y = FasterRecurse(HI(d), HI(ea), p1, p2); return Ret(MAKE(x == y, 0), tm, r); // (≡ 𝑥 𝑥) ⟹ ⊤, (≡ 𝑥 𝑦) ⟹ ⊥ } struct T DispatchCmp(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int x = FasterRecurse(ARG1(LO(ea)), HI(ea), p1, p2); int y = FasterRecurse(HI(d), HI(ea), p1, p2); return Ret(MAKE(Cmp(x, y), 0), tm, r); // (≷ 𝑥 𝑦) ⟹ (⊥) | ⊥ | ⊤ } struct T DispatchOrder(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int x = FasterRecurse(ARG1(LO(ea)), HI(ea), p1, p2); int y = FasterRecurse(HI(d), HI(ea), p1, p2); return Ret(MAKE(Order(x, y), 0), tm, r); // (⊙ 𝑥 𝑦) ⟹ (⊥) | ⊥ | ⊤ } struct T DispatchCons(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int x; if (cx < cHeap) cHeap = cx; x = Car(Cdr(LO(ea))); x = FasterRecurse(x, HI(ea), p1, p2); if (!HI(d)) return Ret(MAKE(Cons(x, 0), 0), tm, r); if (~r & NEED_POP) { r |= NEED_POP; Push(LO(ea)); } r |= NEED_GC | NEED_TMC; tm = MAKE(Cons(x, LO(tm)), 0); return TailCall(MAKE(HI(d), HI(ea)), tm, r, p1, p2); // (ℶ x 𝑦) ↩ (tm 𝑥′ . 𝑦) } struct T DispatchLambda(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { // (eval (𝑘 𝑥 𝑦) 𝑎) ⟹ (⅄ (𝑘 𝑥 𝑦) . 𝑎) SetFrame(r, LO(ea)); r |= NEED_GC; return Ret(MAKE(Lambda(LO(ea), HI(ea), p1, p2), 0), tm, r); } struct T DispatchCond(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int y, z, c = HI(d); if (r & NEED_POP) { Repush(LO(ea)); } do { if (!Cdr(c) && !Cdr(Car(c))) { // (ζ …(𝑝)) ↩ 𝑝 return TailCall(MAKE(Car(Car(c)), HI(ea)), tm, r, p1, p2); } if (~r & NEED_POP) { r |= NEED_POP; Push(LO(ea)); } if ((y = FasterRecurse(Car(Car(c)), HI(ea), p1, p2))) { if ((z = Cdr(Car(c))) < 0) { // (ζ …(𝑝 𝑏)…) ↩ 𝑏 if 𝑝′ return TailCall(MAKE(Car(z), HI(ea)), tm, r, p1, p2); } else { // (ζ …(𝑝)…) ⟹ 𝑝′ if 𝑝′ return Ret(MAKE(y, 0), tm, r); } } } while ((c = Cdr(c))); return Ret(MAKE(c, 0), tm, r); // (ζ) ⟹ ⊥ } struct T DispatchIf(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { return TailCall( MAKE(Get(LO(ea) + 4 + !FasterRecurse(Get(LO(ea) + 3), HI(ea), p1, p2)), HI(ea)), tm, r, p1, p2); } struct T DispatchPrinc(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { bool b; int x, e, A; e = LO(ea); SetFrame(r, e); b = literally; literally = true; e = recurse(MAKE(Head(Tail(e)), HI(ea)), p1, p2); Print(1, e); literally = b; return Ret(MAKE(e, 0), tm, r); } struct T DispatchFlush(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int x, A; SetFrame(r, LO(ea)); Flush(1); return Ret(MAKE(kIgnore0, 0), tm, r); } struct T DispatchPrint(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int a, f, x, A; f = LO(ea); a = HI(ea); SetFrame(r, f); for (;;) { f = Cdr(f); if (!Cdr(f)) { if (quiet) { return TailCall(MAKE(Car(f), a), tm, r, p1, p2); } else { x = recurse(MAKE(Car(f), a), p1, p2); Print(1, x); PrintNewline(1); return Ret(MAKE(x, 0), tm, r); } } if (!quiet) { A = cx; x = recurse(MAKE(Car(f), a), p1, p2); Print(1, x); PrintSpace(1); MarkSweep(A, 0); } } } struct T DispatchPprint(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int a, f, x, n, A; f = LO(ea); a = HI(ea); SetFrame(r, f); for (n = 0;;) { f = Cdr(f); if (!Cdr(f)) { if (quiet) { return TailCall(MAKE(Car(f), a), tm, r, p1, p2); } else { x = recurse(MAKE(Car(f), a), p1, p2); PrettyPrint(1, x, n); PrintNewline(1); return Ret(MAKE(x, 0), tm, r); } } if (!quiet) { A = cx; x = recurse(MAKE(Car(f), a), p1, p2); n += Print(1, x); n += PrintSpace(1); MarkSweep(A, 0); } } } struct T DispatchPrintheap(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int x, A; SetFrame(r, LO(ea)); if (Cdr(LO(ea))) { A = cx; x = recurse(MAKE(Cadr(LO(ea)), HI(ea)), p1, p2); PrintHeap(A); } else { PrintHeap(0); x = 0; } return Ret(x, tm, r); } struct T DispatchGc(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int A, e; SetFrame(r, LO(ea)); A = GetFrameCx(); e = recurse(MAKE(HI(d), HI(ea)), p1, p2); if (e < A && cx < A && !ShouldIgnoreGarbage(A)) { e = MarkSweep(A, e); } return Ret(MAKE(e, 0), tm, r); } struct T DispatchProgn(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int A, y, x = HI(d); for (;;) { y = Car(x); x = Cdr(x); if (!x) { if (r & NEED_POP) { Repush(y); } return TailCall(MAKE(y, HI(ea)), tm, r, p1, p2); // (progn ⋯ 𝑥) ↩ 𝑥 } A = cx; recurse(MAKE(y, HI(ea)), p1, p2); // evaluate for effect MarkSweep(A, 0); } } struct T DispatchGensym(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { return Ret(MAKE(Gensym(), 0), tm, r); } struct T DispatchQuiet(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { SAVE(quiet, true); ea = MAKE(recurse(MAKE(Cadr(LO(ea)), HI(ea)), p1, p2), 0); RESTORE(quiet); return Ret(ea, tm, r); } struct T DispatchTrace(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { START_TRACE; ea = MAKE(recurse(MAKE(Cadr(LO(ea)), HI(ea)), p1, p2), 0); END_TRACE; return Ret(ea, tm, r); } struct T DispatchFtrace(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { ftrace_install(); ++g_ftrace; ea = MAKE(recurse(MAKE(Cadr(LO(ea)), HI(ea)), p1, p2), 0); --g_ftrace; return Ret(ea, tm, r); } struct T DispatchBeta(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { SetFrame(r, LO(ea)); r |= NEED_GC; return Ret(MAKE(Simplify(recurse(MAKE(HI(d), HI(ea)), p1, p2), HI(ea)), 0), tm, r); } struct T DispatchFunction(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { // (eval (𝑓 (𝑘 𝑥 𝑦)) 𝑎) ⟹ (⅄ (𝑘 𝑥 𝑦) . prune 𝑎 wrt (𝑘 𝑥 𝑦)) SetFrame(r, LO(ea)); r |= NEED_GC; return Ret( MAKE(Function(recurse(MAKE(HI(d), HI(ea)), p1, p2), HI(ea), p1, p2), 0), tm, r); } struct T DispatchIgnore0(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { return Ret(MAKE(kIgnore0, 0), tm, r); } struct T DispatchIgnore1(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int x = recurse(MAKE(Car(Cdr(LO(ea))), HI(ea)), p1, p2); return Ret(MAKE(List(kIgnore, x), 0), tm, r); } struct T DispatchExpand(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int x; SetFrame(r, LO(ea)); r |= NEED_GC; x = HI(d); x = recurse(MAKE(x, HI(ea)), p1, p2); return Ret(MAKE(expand(x, HI(ea)), 0), tm, r); } static int GrabArgs(int x, int a, dword p1, dword p2) { if (x >= 0) return x; return Cons(recurse(MAKE(Car(x), a), p1, p2), GrabArgs(Cdr(x), a, p1, p2)); } struct T DispatchError(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int e, x; e = LO(ea); SetFrame(r, e); r |= NEED_GC; x = GrabArgs(Cdr(e), HI(ea), p1, p2); Raise(Cons(Car(e), x)); } struct T DispatchExit(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { longjmp(exiter, 1); } struct T DispatchRead(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { return Ret(MAKE(Read(0), 0), tm, r); } struct T DispatchFuncall(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int a, b, e, f, t, u, y, p, z; e = LO(ea); a = HI(ea); DCHECK_LT(e, 0); SetFrame(r, e); r |= NEED_GC; f = Car(e); z = Cdr(e); y = HI(d) ? HI(d) : FasterRecurse(f, a, p1, p2); Delegate: if (y < 0) { t = Car(y); if (t == kClosure) { // (eval ((⅄ (λ 𝑥 𝑦) 𝑏) 𝑧) 𝑎) ↩ (eval ((λ 𝑥 𝑦) 𝑧) 𝑏) y = Cdr(y); // ((λ 𝑥 𝑦) 𝑏) u = Cdr(y); // 𝑏 y = Car(y); // (λ 𝑥 𝑦) t = Car(y); // λ } else { u = a; } p = Car(Cdr(y)); b = Car(Cdr(Cdr(y))); if (t == kLambda) { if (!(p > 0 && b < 0 && Cdr(b) == p)) { struct Binding bz = bind_(p, z, a, u, p1, p2); return TailCall(MAKE(b, bz.u), tm, r, bz.p1, 0); } else { // fast path ((lambda 𝑣 (𝑦 . 𝑣)) 𝑧) ↩ (𝑦′ 𝑧) y = recurse(MAKE(Car(b), u), 0, 0); goto Delegate; } } else if (t == kMacro) { // (eval ((ψ 𝑥 𝑦) 𝑥) 𝑎) ↩ (eval (eval 𝑦 ((𝑥ᵢ 𝑥ᵢ) 𝑎)) 𝑎) return TailCall(MAKE(eval(b, pairlis(p, Exlis(z, a), u)), a), tm, r, 0, 0); } } else if (y > 1 && y != f && IsPrecious(y)) { // unplanned builtin calls // e.g. ((cond (p car) (cdr)) x) return TailCall(MAKE(Cons(y, z), a), tm, r, p1, p2); } React(e, y, kFunction); } struct T DispatchCall1(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int a, b, e, f, t, u, y, p, z; e = LO(ea); a = HI(ea); DCHECK_LT(e, 0); SetFrame(r, e); f = Car(e); z = Cdr(e); y = HI(d); t = Car(y); // (eval ((⅄ (λ 𝑥 𝑦) 𝑏) 𝑧) 𝑎) ↩ (eval ((λ 𝑥 𝑦) 𝑧) 𝑏) y = Cdr(y); // ((λ 𝑥 𝑦) 𝑏) u = Cdr(y); // 𝑏 y = Car(y); // (λ 𝑥 𝑦) p = Car(Cdr(y)); b = Car(Cdr(Cdr(y))); return TailCall(MAKE(b, u), tm, r, MAKE(Car(p), FasterRecurse(Car(Cdr(LO(ea))), HI(ea), p1, p2)), 0); } struct T DispatchCall2(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { int a, b, e, f, t, u, y, p, z; e = LO(ea); a = HI(ea); DCHECK_LT(e, 0); SetFrame(r, e); f = Car(e); z = Cdr(e); y = HI(d); t = Car(y); // (eval ((⅄ (λ 𝑥 𝑦) 𝑏) 𝑧) 𝑎) ↩ (eval ((λ 𝑥 𝑦) 𝑧) 𝑏) y = Cdr(y); // ((λ 𝑥 𝑦) 𝑏) u = Cdr(y); // 𝑏 y = Car(y); // (λ 𝑥 𝑦) p = Car(Cdr(y)); b = Car(Cdr(Cdr(y))); return TailCall( MAKE(b, u), tm, r, MAKE(Car(p), FasterRecurse(Car(Cdr(LO(ea))), HI(ea), p1, p2)), MAKE(Car(Cdr(p)), FasterRecurse(Car(Cdr(Cdr(LO(ea)))), HI(ea), p1, p2))); } struct T DispatchLet1(dword ea, dword tm, dword r, dword p1, dword p2, dword d) { // Fast path DispatchFuncall() for ((λ (𝑣) 𝑦) 𝑧₀) expressions // HI(d) contains ((𝑣) 𝑦) if (UNLIKELY(trace)) Fprintf(2, "%J╟─%s[%p @ %d] δ %'Rns%n", "DispatchLet1", LO(ea), LO(ea)); int v = Car(Car(HI(d))); int y = Car(Cdr(HI(d))); int z = FasterRecurse(Car(Cdr(LO(ea))), HI(ea), p1, p2); int a = HI(ea); if (!LO(p1) || LO(p1) == v) { p1 = MAKE(v, z); } else if (!LO(p2) || LO(p2) == v) { p2 = MAKE(v, z); } else { a = Alist(LO(p2), HI(p2), a); p2 = p1; p1 = MAKE(v, z); } return TailCall(MAKE(y, a), tm, r, p1, p2); } int Eval(int e, int a) { return ((ForceIntTailDispatchFn *)GetDispatchFn(e))(MAKE(e, a), 0, 0, 0, 0, GetShadow(e)); } static void ResetStats(void) { cHeap = cx; cGets = 0; cSets = 0; } static void PrintStats(long usec) { Fprintf(2, ";; heap %'16ld nsec %'16ld%n" ";; gets %'16ld sets %'16ld%n" ";; atom %'16ld frez %'16ld%n", -cHeap - -cFrost, usec, cGets, cSets, cAtoms, -cFrost); } static wontreturn Exit(void) { exit(0 <= fails && fails <= 255 ? fails : 255); } static wontreturn void PrintUsage(void) { PUTS(!!fails + 1, "Usage: "); PUTS(!!fails + 1, program_invocation_name); PUTS(!!fails + 1, " [-MNSacdfgqstz?h] errput.lisp\n\ -d dump global defines, on success\n\ -s print statistics upon each eval\n\ -z uses alternative unicode glyphs\n\ -f print log of all function calls\n\ -S avoid pretty printing most case\n\ -c dont conceal transitive closure\n\ -a log name bindings in the traces\n\ -t hyper verbose jump table traces\n\ -M enable tracing of macro expands\n\ -N disable define name substitutes\n\ -g will log garbage collector pass\n\ -q makes (print) and (pprint) noop\n\ "); Exit(); } int Plinko(int argc, char *argv[]) { long *p; bool trace; int S, x, u, j; uint64_t t1, t2; tick = kStartTsc; #ifndef NDEBUG ShowCrashReports(); #endif signal(SIGPIPE, SIG_DFL); depth = -1; trace = false; while ((x = getopt(argc, argv, "MNSacdfgqstz?h")) != -1) { switch (x) { CASE(L'd', dump = true); CASE(L's', stats = true); CASE(L'z', symbolism = true); CASE(L'f', ftrace = true); CASE(L'S', simpler = true); CASE(L'c', logc = true); CASE(L'a', loga = true); CASE(L't', trace = true); CASE(L'g', gtrace = true); CASE(L'q', quiet = true); CASE(L'M', mtrace = true); CASE(L'N', noname = true); CASE(L'?', PrintUsage()); CASE(L'h', PrintUsage()); default: ++fails; PrintUsage(); } } if (arch_prctl(ARCH_SET_FS, 0x200000000000) == -1 || arch_prctl(ARCH_SET_GS, (intptr_t)DispatchPlan) == -1) { kprintf("error: %m%nyour operating system doesn't allow you change both " "the %%fs and %%gs registers in your processor which is a shame " "since they're crucial for performance and thread-local storage%n"); exit(1); } if (mmap((void *)0x200000000000, ROUNDUP((TERM + 1) * sizeof(g_mem[0]), FRAMESIZE), PROT_READ | PROT_WRITE, MAP_ANONYMOUS | MAP_PRIVATE | MAP_FIXED, -1, 0) == MAP_FAILED || mmap((void *)(0x200000000000 + (BANE & (BANE | MASK(BANE))) * sizeof(g_mem[0])), (BANE & (BANE | MASK(BANE))) * sizeof(g_mem[0]), PROT_READ | PROT_WRITE, MAP_ANONYMOUS | MAP_PRIVATE | MAP_FIXED, -1, 0) == MAP_FAILED || mmap((void *)0x400000000000, ROUNDUP((TERM + 1) * sizeof(g_mem[0]), FRAMESIZE), PROT_READ | PROT_WRITE, MAP_ANONYMOUS | MAP_PRIVATE | MAP_FIXED, -1, 0) == MAP_FAILED || mmap((void *)(0x400000000000 + (BANE & (BANE | MASK(BANE))) * sizeof(g_mem[0])), (BANE & (BANE | MASK(BANE))) * sizeof(g_mem[0]), PROT_READ | PROT_WRITE, MAP_ANONYMOUS | MAP_PRIVATE | MAP_FIXED, -1, 0) == MAP_FAILED) { kprintf("error: %m%nyour operating system doesn't allow you to allocate " "outrageous amounts of overcommit memory, which is a shame, since " "the pml4t feature in your processor was intended to give you that " "power since it's crucial for sparse data applications and lisp. " "for instance, the way racket works around this problem is by " "triggering thousands of segmentation faults as part of normal " "operation%n"); exit(1); } g_mem = (void *)0x200000000000; inputs = argv + optind; if (*inputs) { close(0); DCHECK_NE(-1, open(*inputs++, O_RDONLY)); } eval = Eval; bind_ = Bind; evlis = Evlis; expand = Expand; recurse = Recurse; pairlis = Pairlis; kTail[0] = DispatchTail; kTail[1] = DispatchTailImpossible; kTail[2] = DispatchTailImpossible; kTail[3] = DispatchTailImpossible; kTail[4] = DispatchTail; kTail[5] = DispatchTailGc; kTail[6] = DispatchTailImpossible; kTail[7] = DispatchTailTmcGc; if (trace) EnableTracing(); cx = -1; cFrost = cx; Setup(); cFrost = cx; if (!setjmp(exiter)) { for (;;) { S = sp; DCHECK_EQ(0, S); DCHECK_EQ(cx, cFrost); if (!(x = setjmp(crash))) { x = Read(0); x = expand(x, globals); if (stats) ResetStats(); if (x < 0 && Car(x) == kDefine) { globals = Define(x, globals); cFrost = cx; } else { t1 = rdtsc(); x = eval(x, globals); if (x < 0 && Car(x) == kIgnore) { MarkSweep(cFrost, 0); } else { Fprintf(1, "%p%n", x); MarkSweep(cFrost, 0); if (stats) { t2 = rdtsc(); PrintStats(ClocksToNanos(t1, t2)); } } } } else { x = ~x; ++fails; eval = Eval; expand = Expand; Fprintf(2, "?%p%s%n", x, cx == BANE ? " [HEAP OVERFLOW]" : ""); Backtrace(S); Exit(); Unwind(S); MarkSweep(cFrost, 0); } } } #if HISTO_ASSOC PrintHistogram(2, "COMPARES PER ASSOC", g_assoc_histogram, ARRAYLEN(g_assoc_histogram)); #endif #if HISTO_GARBAGE PrintHistogram(2, "GC MARKS PER COLLECTION", g_gc_marks_histogram, ARRAYLEN(g_gc_marks_histogram)); PrintHistogram(2, "GC DISCARDS PER COLLECTION", g_gc_discards_histogram, ARRAYLEN(g_gc_discards_histogram)); PrintHistogram(2, "GC MARKS / DISCARDS FOR DENSE COLLECTIONS", g_gc_dense_histogram, ARRAYLEN(g_gc_dense_histogram)); PrintHistogram(2, "GC DISCARDS / MARKS FOR SPARSE COLLECTIONS", g_gc_sparse_histogram, ARRAYLEN(g_gc_sparse_histogram)); PrintHistogram(2, "GC LOP", g_gc_lop_histogram, ARRAYLEN(g_gc_lop_histogram)); #endif if (dump && !fails) { DumpDefines(kDefine, globals, Reverse(ordglob, 0)); } Exit(); }