codegen.mud

   1 <AND? <SETG LICENSE "
   2 Copyright (C) 2017-2018 Keziah Wesley
   3
   4 You can redistribute and/or modify this file under the terms of the
   5 GNU Affero General Public License as published by the Free Software
   6 Foundation, either version 3 of the License, or (at your option) any
   7 later version.
   8
   9 This file is distributed in the hope that it will be useful, but
  10 WITHOUT ANY WARRANTY; without even the implied warranty of
  11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  12 Affero General Public License for more details.
  13
  14 You should have received a copy of the GNU Affero General Public
  15 License along with this file. If not, see
  16 <http://www.gnu.org/licenses/>.
  17 ">
  18
  19 <DEFINE result (expr) <STRING "*_res = (" .expr ");">>
  20
  21 <SETG opmname 1>        ;"assembler name (e.g. GRTR?, SUB)"
  22 <SETG opcode 2>         ;"numeric opcode"
  23 <SETG opargs 3>         ;"argspec. see examples."
  24 <SETG opbody-c 4>       ;"C implementation (use names from argspec)"
  25 <SETG opcname 5>        ;"unique name (e.g. GRTRB, SUBB)"
  26
  27 <DEFINE def-ops ("TUPLE" ops "AUX" (i 0) (results '()) "NAME" act)
  28  <COND (<EMPTY? .ops> <RETURN .results .act>)>
  29  <SET results <CONS (<1 <2 .ops>> .i <REST <2 .ops>> <3 .ops> <UNPARSE <1 .ops>>) .results>>
  30  <SET ops <REST <REST <REST .ops>>>>
  31  <SET i <+ .i 1>>
  32  <AGAIN .act>>
  33
  34 <DEFINE def-name-to-opcode (ops "AUX" (rslt "enum {") "NAME" act)
  35  <COND (<EMPTY? .ops> <RETURN <STRING .rslt "};"> .act>)>
  36  <SET rslt <STRING .rslt "I_" <opcname <1 .ops>> "=" <UNPARSE <opcode <1 .ops>>> ",">>
  37  <SET ops <REST .ops>>
  38  <AGAIN .act>>
  39
  40 <DEFINE def-opcode-to-name (ops "AUX" (rslt "const char * opcode_to_name (int op) { switch (op) {") "NAME" act)
  41  <COND (<EMPTY? .ops> <RETURN <STRING .rslt "default: return 0;}}"> .act>)>
  42  <SET rslt <STRING .rslt "case " <UNPARSE <opcode <1 .ops>>> ": return \"" <opcname <1 .ops>> "\";" ,CR>>
  43  <SET ops <REST .ops>>
  44  <AGAIN .act>>
  45
  46 <DEFINE read-args (args "AUX" (acc "") (i 1) "NAME" act)
  47  <COND (<EMPTY? .args> <RETURN .acc .act>)>
  48  <SET acc <STRING .acc
  49   <COND
  50    (<==? <1 .args> result>
  51     <STRING "object * _res = RESULT(" <UNPARSE .i> ");" ,CR>)
  52    (ELSE
  53     <COND
  54      (<==? <2 <1 .args>> BYTE>
  55       <STRING "uint8_t " <UNPARSE <1 <1 .args>>> " = p[" <UNPARSE .i> "];" ,CR>)
  56      (<==? <2 <1 .args>> OFFSET>
  57       <STRING "int8_t " <UNPARSE <1 <1 .args>>> " = (int8_t)p[" <UNPARSE .i> "];" ,CR>)
  58      (<==? <2 <1 .args>> FIX>
  59       <STRING "int64_t " <UNPARSE <1 <1 .args>>> " = GETFIX(bp[p[" <UNPARSE .i> "]]);" ,CR>)
  60       >)>>>
  61  <SET args <REST .args>>
  62  <SET i <+ .i 1>>
  63  <AGAIN .act>>
  64
  65 <DEFINE def-dispatch (ops
  66         "AUX" (rslt <STRING "void run (const uint8_t * p0, const uint8_t * p, object * bp, int sp) {" ,CR
  67         "for (;;) {" ,CR
  68         "TRACE(p0, p);" ,CR
  69         "switch (*p) {" ,CR>)
  70         "NAME" act)
  71  <COND (<EMPTY? .ops> <RETURN
  72         <STRING .rslt "default: assert(0 && \"bad opcode\");" ,CR "}" ,CR "}" ,CR "}" ,CR> .act>)>
  73  <SET rslt
  74   <STRING .rslt "case I_" <opcname <1 .ops>> ": {" ,CR
  75   <read-args <opargs <1 .ops>>>
  76   "const uint8_t * const oldp = p;" ,CR
  77   "p += " <UNPARSE <+ 1 <LENGTH <opargs <1 .ops>>>>> !\; ,CR
  78   <opbody-c <1 .ops>> ,CR
  79   "break;" ,CR !\} ,CR>>
  80  <SET ops <REST .ops>>
  81  <AGAIN .act>>
  82
  83 <SETG CR !\
  84 >
  85
  86 <DEFINE gen-opcode-fmt (op "AUX" (args <opargs .op>) (s "\"<%s") "NAME" act)
  87  <COND (<EMPTY? .args> <RETURN <STRING .s ">\\n\""> .act>)>
  88  <SET s
  89   <STRING .s " "
  90    <COND
  91    (<==? <1 .args> result>
  92     "%hhi")
  93    (ELSE <COND
  94     (<==? <2 <1 .args>> BYTE>
  95      "%hhu")
  96     (<==? <2 <1 .args>> OFFSET>
  97      "%hhi")
  98     (<==? <2 <1 .args>> FIX>
  99      "fix%hhu")>)>>>
 100  <SET args <REST .args>>
 101  <AGAIN .act>>
 102
 103 <DEFINE gen-opcode-args (op base "AUX"
 104         (s <STRING ", \"" <opcname .op> "\"">)
 105         (i 0)
 106         (n <LENGTH <opargs .op>>))
 107  <PROG ("NAME" act)
 108   <COND (<==? .i .n> <RETURN .s .act>)>
 109   <SET i <+ 1 .i>>
 110   <SET s <STRING .s ", " .base "[" <UNPARSE .i> "]">>
 111   <AGAIN .act>>>
 112
 113 <DEFINE def-disasm (ops
 114         "AUX" (rslt <STRING "int snprint_op_disasm"
 115         "(char ** buf, size_t outlen, const uint8_t ** p, size_t inlen)" ,CR
 116         "{" ,CR "switch (**p) {" ,CR>)
 117         "NAME" act)
 118  <COND (<EMPTY? .ops> <RETURN <STRING .rslt "}" ,CR "return EBADOPCODE;" ,CR "}"> .act>)>
 119  <SET rslt
 120   <STRING .rslt "case " <UNPARSE <opcode <1 .ops>>> ": " ,CR
 121    "if (inlen < " <UNPARSE <LENGTH <opargs <1 .ops>>>> ") { return EBADOPARGS; };" ,CR
 122    "*buf += snprintf(*buf, outlen, "
 123    <gen-opcode-fmt <1 .ops>>
 124    <gen-opcode-args <1 .ops> "(*p)">
 125    ");" ,CR
 126    "*p += " <UNPARSE <LENGTH <opargs <1 .ops>>>> ";" ,CR
 127    "return 0;" ,CR>>
 128  <SET ops <REST .ops>>
 129  <AGAIN .act>>
 130
 131 <SETG ops <def-ops
 132  GRTRB (GRTR? (x FIX) (rhs BYTE) (invert BYTE) (offs OFFSET))
 133        "if (invert ^ (x > rhs)) JUMP(offs);"
 134  SUB (SUB (x FIX) (y FIX) result) <result "NEWFIX( x - y )">
 135  SUBB (SUB (x FIX) (rhs BYTE) result) <result "NEWFIX( x - rhs )">
 136  MUL (MUL (x FIX) (y FIX) result) <result "NEWFIX( x * y )">
 137  HALT (HALT) "return;">>
 138
 139 <PRINC <STRING "/*" ,LICENSE "*/">> <CRLF>
 140
 141 <PRINC <STRING "/* GENERATED FILE. CHANGES WILL BE OVERRIDDEN. " ,CR
 142        "This file is generated by Muddle code; it is included "
 143        "in the distribution for bootstrapping. */">> <CRLF>
 144
 145 <PRINC <def-name-to-opcode ,ops>> <CRLF>
 146 ;<PRINC <def-opcode-to-name ,ops>> <CRLF>
 147
 148 <PRINC <def-dispatch ,ops>> <CRLF>
 149
 150 <PRINC <def-disasm ,ops>> <CRLF>
 151
 152 ;<PRINC <def-asm ,ops>> <CRLF>
 153
 154 <QUIT>>