--- /dev/null
+<AND? <SETG LICENSE "
+Copyright (C) 2017-2018 Keziah Wesley
+
+You can redistribute and/or modify this file under the terms of the
+GNU Affero General Public License as published by the Free Software
+Foundation, either version 3 of the License, or (at your option) any
+later version.
+
+This file 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
+Affero General Public License for more details.
+
+You should have received a copy of the GNU Affero General Public
+License along with this file. If not, see
+<http://www.gnu.org/licenses/>.
+">
+
+<DEFINE result (expr) <STRING "*_res = (" .expr ");">>
+
+<SETG opmname 1> ;"assembler name (e.g. GRTR?, SUB)"
+<SETG opcode 2> ;"numeric opcode"
+<SETG opargs 3> ;"argspec. see examples."
+<SETG opbody-c 4> ;"C implementation (use names from argspec)"
+<SETG opcname 5> ;"unique name (e.g. GRTRB, SUBB)"
+
+<DEFINE def-ops ("TUPLE" ops "AUX" (i 0) (results '()) "NAME" act)
+ <COND (<EMPTY? .ops> <RETURN .results .act>)>
+ <SET results <CONS (<1 <2 .ops>> .i <REST <2 .ops>> <3 .ops> <UNPARSE <1 .ops>>) .results>>
+ <SET ops <REST <REST <REST .ops>>>>
+ <SET i <+ .i 1>>
+ <AGAIN .act>>
+
+<DEFINE def-name-to-opcode (ops "AUX" (rslt "enum {") "NAME" act)
+ <COND (<EMPTY? .ops> <RETURN <STRING .rslt "};"> .act>)>
+ <SET rslt <STRING .rslt "I_" <opcname <1 .ops>> "=" <UNPARSE <opcode <1 .ops>>> ",">>
+ <SET ops <REST .ops>>
+ <AGAIN .act>>
+
+<DEFINE def-opcode-to-name (ops "AUX" (rslt "const char * opcode_to_name (int op) { switch (op) {") "NAME" act)
+ <COND (<EMPTY? .ops> <RETURN <STRING .rslt "default: return 0;}}"> .act>)>
+ <SET rslt <STRING .rslt "case " <UNPARSE <opcode <1 .ops>>> ": return \"" <opcname <1 .ops>> "\";" ,CR>>
+ <SET ops <REST .ops>>
+ <AGAIN .act>>
+
+<DEFINE read-args (args "AUX" (acc "") (i 1) "NAME" act)
+ <COND (<EMPTY? .args> <RETURN .acc .act>)>
+ <SET acc <STRING .acc
+ <COND
+ (<==? <1 .args> result>
+ <STRING "object * _res = RESULT(" <UNPARSE .i> ");" ,CR>)
+ (ELSE
+ <COND
+ (<==? <2 <1 .args>> BYTE>
+ <STRING "uint8_t " <UNPARSE <1 <1 .args>>> " = p[" <UNPARSE .i> "];" ,CR>)
+ (<==? <2 <1 .args>> OFFSET>
+ <STRING "int8_t " <UNPARSE <1 <1 .args>>> " = (int8_t)p[" <UNPARSE .i> "];" ,CR>)
+ (<==? <2 <1 .args>> FIX>
+ <STRING "int64_t " <UNPARSE <1 <1 .args>>> " = GETFIX(bp[p[" <UNPARSE .i> "]]);" ,CR>)
+ >)>>>
+ <SET args <REST .args>>
+ <SET i <+ .i 1>>
+ <AGAIN .act>>
+
+<DEFINE def-dispatch (ops
+ "AUX" (rslt <STRING "void run (const uint8_t * p0, const uint8_t * p, object * bp, int sp) {" ,CR
+ "for (;;) {" ,CR
+ "TRACE(p0, p);" ,CR
+ "switch (*p) {" ,CR>)
+ "NAME" act)
+ <COND (<EMPTY? .ops> <RETURN
+ <STRING .rslt "default: assert(0 && \"bad opcode\");" ,CR "}" ,CR "}" ,CR "}" ,CR> .act>)>
+ <SET rslt
+ <STRING .rslt "case I_" <opcname <1 .ops>> ": {" ,CR
+ <read-args <opargs <1 .ops>>>
+ "const uint8_t * const oldp = p;" ,CR
+ "p += " <UNPARSE <+ 1 <LENGTH <opargs <1 .ops>>>>> !\; ,CR
+ <opbody-c <1 .ops>> ,CR
+ "break;" ,CR !\} ,CR>>
+ <SET ops <REST .ops>>
+ <AGAIN .act>>
+
+<SETG CR !\
+>
+
+<DEFINE gen-opcode-fmt (op "AUX" (args <opargs .op>) (s "\"<%s") "NAME" act)
+ <COND (<EMPTY? .args> <RETURN <STRING .s ">\\n\""> .act>)>
+ <SET s
+ <STRING .s " "
+ <COND
+ (<==? <1 .args> result>
+ "%hhi")
+ (ELSE <COND
+ (<==? <2 <1 .args>> BYTE>
+ "%hhu")
+ (<==? <2 <1 .args>> OFFSET>
+ "%hhi")
+ (<==? <2 <1 .args>> FIX>
+ "fix%hhu")>)>>>
+ <SET args <REST .args>>
+ <AGAIN .act>>
+
+<DEFINE gen-opcode-args (op base "AUX"
+ (s <STRING ", \"" <opcname .op> "\"">)
+ (i 0)
+ (n <LENGTH <opargs .op>>))
+ <PROG ("NAME" act)
+ <COND (<==? .i .n> <RETURN .s .act>)>
+ <SET i <+ 1 .i>>
+ <SET s <STRING .s ", " .base "[" <UNPARSE .i> "]">>
+ <AGAIN .act>>>
+
+<DEFINE def-disasm (ops
+ "AUX" (rslt <STRING "int snprint_op_disasm"
+ "(char ** buf, size_t outlen, const uint8_t ** p, size_t inlen)" ,CR
+ "{" ,CR "switch (**p) {" ,CR>)
+ "NAME" act)
+ <COND (<EMPTY? .ops> <RETURN <STRING .rslt "}" ,CR "return EBADOPCODE;" ,CR "}"> .act>)>
+ <SET rslt
+ <STRING .rslt "case " <UNPARSE <opcode <1 .ops>>> ": " ,CR
+ "if (inlen < " <UNPARSE <LENGTH <opargs <1 .ops>>>> ") { return EBADOPARGS; };" ,CR
+ "*buf += snprintf(*buf, outlen, "
+ <gen-opcode-fmt <1 .ops>>
+ <gen-opcode-args <1 .ops> "(*p)">
+ ");" ,CR
+ "*p += " <UNPARSE <LENGTH <opargs <1 .ops>>>> ";" ,CR
+ "return 0;" ,CR>>
+ <SET ops <REST .ops>>
+ <AGAIN .act>>
+
+<SETG ops <def-ops
+ GRTRB (GRTR? (x FIX) (rhs BYTE) (invert BYTE) (offs OFFSET))
+ "if (invert ^ (x > rhs)) JUMP(offs);"
+ SUB (SUB (x FIX) (y FIX) result) <result "NEWFIX( x - y )">
+ SUBB (SUB (x FIX) (rhs BYTE) result) <result "NEWFIX( x - rhs )">
+ MUL (MUL (x FIX) (y FIX) result) <result "NEWFIX( x * y )">
+ HALT (HALT) "return;">>
+
+<PRINC <STRING "/*" ,LICENSE "*/">> <CRLF>
+
+<PRINC <STRING "/* GENERATED FILE. CHANGES WILL BE OVERRIDDEN. " ,CR
+ "This file is generated by Muddle code; it is included "
+ "in the distribution for bootstrapping. */">> <CRLF>
+
+<PRINC <def-name-to-opcode ,ops>> <CRLF>
+;<PRINC <def-opcode-to-name ,ops>> <CRLF>
+
+<PRINC <def-dispatch ,ops>> <CRLF>
+
+<PRINC <def-disasm ,ops>> <CRLF>
+
+;<PRINC <def-asm ,ops>> <CRLF>
+
+<QUIT>>
--- /dev/null
+/*
+Written in 2018 by Keziah Wesley <kaz@lambdaverse.org>
+
+To the extent possible under law, the author(s) have dedicated all
+copyright and related and neighboring rights to this software to the
+public domain worldwide. This software is distributed without any
+warranty.
+
+You should have received a copy of the CC0 Public Domain Dedication
+along with this software. If not, see
+<http://creativecommons.org/publicdomain/zero/1.0/>.
+*/
+
+strict digraph system {
+ layout = "dot";
+ rankdir = LR;
+
+ # red = runtime
+
+ Muddle [style = filled];
+
+ {
+ rank = same;
+ MUM [style = filled, fillcolor = red, fontcolor = white, shape = box];
+ LiteMuddle [style = filled];
+ MIMC [shape = box];
+ MIMops [style = filled];
+ MIMOC [shape = box];
+ }
+
+ {
+ rank = same;
+ MIM [style = filled, fillcolor = red, fontcolor = white, shape = box];
+ C [style = filled];
+ cc [shape = box];
+ opcodes [style = filled, label = "opcodes"];
+ }
+
+ native2 [style = filled, fillcolor = red, label = "native", fontcolor = white, shape = diamond];
+
+ LiteMuddle -> MIMC [label = "input"];
+ MIMC -> MIMops [label = "output"];
+ MIMops -> MIM [label = "runs on", color = red];
+ MIMops -> MIMOC [label = "input"/*, weight = 0*/];
+ MIMOC -> opcodes [label = "output"];
+ opcodes -> native2 [label = "runs on", color = red];
+ C -> cc [label = "input"];
+ cc -> opcodes [label = "output"];
+
+ //Muddle -> MUMC [weight= 0];
+ //MUMC -> MIMops;
+
+ Muddle -> MUM [label = "runs on", color = red];
+ MUM -> LiteMuddle [label = "written in"];
+
+ MIMC -> Muddle [label = "written in", weight = 0, style = dashed];
+ MIMOC -> Muddle [label = "written in", weight = 0, style = dashed];
+ MIM -> C [label = "written in"];
+}
--- /dev/null
+/*
+Copyright (C) 2017-2018 Keziah Wesley
+
+You can redistribute and/or modify this file under the terms of the
+GNU Affero General Public License as published by the Free Software
+Foundation, either version 3 of the License, or (at your option) any
+later version.
+
+This file 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
+Affero General Public License for more details.
+
+You should have received a copy of the GNU Affero General Public
+License along with this file. If not, see
+<http://www.gnu.org/licenses/>.
+*/
+/* GENERATED FILE. CHANGES WILL BE OVERRIDDEN.
+This file is generated by Muddle code; it is included in the distribution for bootstrapping. */
+enum {I_HALT=4,I_MUL=3,I_SUBB=2,I_SUB=1,I_GRTRB=0,};
+
+void run (const uint8_t * p0, const uint8_t * p, object * bp, int sp) {
+for (;;) {
+TRACE(p0, p);
+switch (*p) {
+case I_HALT: {
+const uint8_t * const oldp = p;
+p += 1;
+return;
+break;
+}
+case I_MUL: {
+int64_t x = GETFIX(bp[p[1]]);
+int64_t y = GETFIX(bp[p[2]]);
+object * _res = RESULT(3);
+const uint8_t * const oldp = p;
+p += 4;
+*_res = (NEWFIX( x * y ));
+break;
+}
+case I_SUBB: {
+int64_t x = GETFIX(bp[p[1]]);
+uint8_t rhs = p[2];
+object * _res = RESULT(3);
+const uint8_t * const oldp = p;
+p += 4;
+*_res = (NEWFIX( x - rhs ));
+break;
+}
+case I_SUB: {
+int64_t x = GETFIX(bp[p[1]]);
+int64_t y = GETFIX(bp[p[2]]);
+object * _res = RESULT(3);
+const uint8_t * const oldp = p;
+p += 4;
+*_res = (NEWFIX( x - y ));
+break;
+}
+case I_GRTRB: {
+int64_t x = GETFIX(bp[p[1]]);
+uint8_t rhs = p[2];
+uint8_t invert = p[3];
+int8_t offs = (int8_t)p[4];
+const uint8_t * const oldp = p;
+p += 5;
+if (invert ^ (x > rhs)) JUMP(offs);
+break;
+}
+default: assert(0 && "bad opcode");
+}
+}
+}
+
+int snprint_op_disasm(char ** buf, size_t outlen, const uint8_t ** p, size_t inlen)
+{
+switch (**p) {
+case 4:
+if (inlen < 0) { return EBADOPARGS; };
+*buf += snprintf(*buf, outlen, "<%s>\n", "HALT");
+*p += 0;
+return 0;
+case 3:
+if (inlen < 3) { return EBADOPARGS; };
+*buf += snprintf(*buf, outlen, "<%s fix%hhu fix%hhu %hhi>\n", "MUL", (*p)[1], (*p)[2], (*p)[3]);
+*p += 3;
+return 0;
+case 2:
+if (inlen < 3) { return EBADOPARGS; };
+*buf += snprintf(*buf, outlen, "<%s fix%hhu %hhu %hhi>\n", "SUBB", (*p)[1], (*p)[2], (*p)[3]);
+*p += 3;
+return 0;
+case 1:
+if (inlen < 3) { return EBADOPARGS; };
+*buf += snprintf(*buf, outlen, "<%s fix%hhu fix%hhu %hhi>\n", "SUB", (*p)[1], (*p)[2], (*p)[3]);
+*p += 3;
+return 0;
+case 0:
+if (inlen < 4) { return EBADOPARGS; };
+*buf += snprintf(*buf, outlen, "<%s fix%hhu %hhu %hhu %hhi>\n", "GRTRB", (*p)[1], (*p)[2], (*p)[3], (*p)[4]);
+*p += 4;
+return 0;
+}
+return EBADOPCODE;
+}
+
--- /dev/null
+/*
+Copyright (C) 2017-2018 Keziah Wesley
+
+You can redistribute and/or modify this file under the terms of the
+GNU Affero General Public License as published by the Free Software
+Foundation, either version 3 of the License, or (at your option) any
+later version.
+
+This file 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
+Affero General Public License for more details.
+
+You should have received a copy of the GNU Affero General Public
+License along with this file. If not, see
+<http://www.gnu.org/licenses/>.
+*/
+
+#include <assert.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+enum {
+ PT_UNBOUND,
+ PT_FIX = (1 << 16),
+ PT_MASK = (0x7fff << 16),
+};
+
+enum {
+ TT_UNBOUND = PT_UNBOUND,
+ TT_FIX = PT_FIX,
+};
+
+enum {
+ B_IF,
+ B_IF_NOT,
+};
+
+enum {
+ R_STACK = 0xff,
+};
+
+typedef struct {
+ uint32_t type;
+ uint32_t _stuff;
+ union {
+ int64_t fix;
+ };
+} object;
+
+inline static int64_t GETFIX (object o) {
+ assert ((o.type & PT_MASK) == PT_FIX);
+ return o.fix;
+}
+inline static object NEWFIX (int64_t v) {
+ return (object){ .type = TT_FIX, .fix = (v) };
+}
+#define RESULT(i) (&bp[(p[i] == R_STACK) ? sp++ : p[i]])
+#define JUMP(off) do { p = (off < 0) ? oldp + off : p + off; } while (0)
+
+int snprint_op_disasm (char ** buf, size_t outlen, const uint8_t ** p, size_t inlen);
+void run (const uint8_t * op, const uint8_t * p, object * bp, int sp);
+
+static void trace(const uint8_t * p0, const uint8_t * p)
+{
+ char buf[512];
+ char *b = buf;
+ b += snprintf(buf, 512, "%ld: ", p-p0);
+ int n = snprint_op_disasm (&b, 512, &p, (size_t)-1);
+ assert (!n);
+ printf(buf);
+}
+
+enum {
+ EOKAY,
+ EBADOPCODE,
+ EBADOPARGS,
+};
+
+#define TRACE(p0, p) trace(p0, p)
+
+#include "gen.c"
+
+int main ()
+{
+ // hand-assembled iterative factorial:
+ uint8_t locl_N = 0;
+ uint8_t locl_TMP1 = 1;
+ uint8_t progn[] = {
+ I_GRTRB, locl_N, 1, B_IF, 1, // <GRTR? N 1 + LOOP>
+ I_HALT, // <HALT>
+ I_MUL, locl_N, locl_TMP1, locl_TMP1, // LOOP <MUL N TMP1 = TMP1>
+ I_SUBB, locl_N, 1, locl_N, // <SUB N 1 = N>
+ I_GRTRB, locl_N, 1, B_IF, (uint8_t)-8, // <GRTR? N 1 + LOOP>
+ I_HALT, // <HALT>
+ };
+
+ object stack[128];
+ memset(stack, '\0', 128 * sizeof(*stack));
+ stack[0] = NEWFIX(7);
+ stack[1] = NEWFIX(1);
+
+ run (progn, progn, stack, 2);
+ printf("%lu", GETFIX(stack[1]));
+ return 0;
+}
projects / mim.git / commitdiff