From: Kaz Wesley <kaz@lambdaverse.org>
Date: Wed, 21 Feb 2018 06:55:49 +0000 (-0800)
Subject: initial commit
X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;ds=inline;p=mim.git

initial commit
---

32a7568a12485081ddd4d89e4f02cf07e312cef8
diff --git a/codegen.mud b/codegen.mud
new file mode 100644
index 0000000..08da96b
--- /dev/null
+++ b/codegen.mud
@@ -0,0 +1,154 @@
+<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>>
diff --git a/doc/distribution.dot b/doc/distribution.dot
new file mode 100644
index 0000000..136decb
--- /dev/null
+++ b/doc/distribution.dot
@@ -0,0 +1,59 @@
+/*
+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"];
+}
diff --git a/gen.c b/gen.c
new file mode 100644
index 0000000..916a659
--- /dev/null
+++ b/gen.c
@@ -0,0 +1,105 @@
+/*
+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;
+}
+
diff --git a/main.c b/main.c
new file mode 100644
index 0000000..b4aa7b3
--- /dev/null
+++ b/main.c
@@ -0,0 +1,107 @@
+/*
+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;
+}