Use inline ops to compile ITC version. Slightly faster, less source

src/toolsrc/plforth.pla

@@ -6,9 +6,10 @@ include "inc/longjmp.plh"
 //
 // Internal variables
 //
-word  vlist
+word  vlist, infunc, inptr, IIP, W
-word  startheap, arg, infunc, inptr, IIP, W
+word  vmvect, startheap, arg
 word  keyinbuf   = $1FF
+const JSR        = $20 // 6502 JSR opcode needed for VM entry
 const SRCREFS    = 2
 const INBUF_SIZE = 128
 byte  srclevel   = 0
@@ -92,15 +93,9 @@ const interponly_flag = $80
 //
 // Predefine instrinsics
 //
-predef _drop_(a)#0, _swap_(a,b)#2, _dup_(a)#2, _dashdup_(a)#1, _over_(a,b,c)#4, _rot_(a,b,c)#3
+predef _swap_(a,b)#2, _dashdup_(a)#1, _over_(a,b,c)#4, _rot_(a,b,c)#3
-predef _add_(a,b)#1, _inc_(a)#1, _inc2_(a)#1, _dec_(a)#1, _dec2_(a)#1
+predef _abs_(a)#1, _max_(a,b)#1, _min_(a,b)#1, _wplusset_(a,b)#0
-predef _sub_(a,b)#1, _mul_(a,b)#1, _div_(a,b)#1
-predef _neg_(a)#1, _and_(a,b)#1, _or_(a,b)#1, _xor_(a,b)#1, _complement_(a)#1, _not_(a)#1
-predef _mod_(a,b)#1, _abs_(a)#1, _max_(a,b)#1, _min_(a,b)#1
-predef _lshift_(a,b)#1, _rshift_(a,b)#1
-predef _cset_(a,b)#0, _cget_(a)#1, _wset_(a,b)#0, _wplusset_(a,b)#0, _wget_(a)#1
 predef _ffa_(a)#1, _lfa_(a)#1, _hfa_(a)#1, _cfa_(a)#1, _pfa_(a)#1, _allot_(a)#0
-predef _eq_(a,b)#1, _gt_(a,b)#1, _lt_(a,b)#1, _0lt_(a)#1, _0eq_(a)#1
 predef _branch_#0, _0branch_(a)#0, _if_#0, _else_#0, _then_#0
 predef _begin_#0, _again_#0, _until_#0, _while_#0, _repeat_#0
 predef _case_#0, _of_#0, _endof_#0, _endcase_#0
@@ -124,7 +119,7 @@ predef _compword_(dentry)#0, _compliteral_(a)#0, _execword_(dentry)#0, _isnum_(a
 // DROP
 char d_drop = "DROP"
 byte = inline_flag
-word = 0, 0, @_drop_, $30
+word = 0, 0, 0, $30
 // SWAP
 char d_swap = "SWAP"
 byte = 0
@@ -132,7 +127,7 @@ word = @d_drop, 0, @_swap_
 // DUP
 char d_dup = "DUP"
 byte = inline_flag
-word = @d_swap, 0, @_dup_, $34
+word = @d_swap, 0, 0, $34
 // -DUP
 char d_dashdup = "-DUP"
 byte = 0
@@ -148,87 +143,87 @@ word = @d_over, 0, @_rot_
 // ADD
 char d_add = "+"
 byte = inline_flag
-word = @d_rot, 0, @_add_, $82
+word = @d_rot, 0, 0, $82
 // ONE PLUS
 char d_inc = "1+"
 byte = inline_flag
-word = @d_add, 0, @_inc_, $8C
+word = @d_add, 0, 0, $8C
 // TWO PLUS
 char d_inc2 = "2+"
 byte = inlinew_flag
-word = @d_inc, 0, @_inc2_, $8C8C
+word = @d_inc, 0, 0, $8C8C
 // ONE MINUS
 char d_dec = "1-"
 byte = inline_flag
-word = @d_inc2, 0, @_dec_, $8E
+word = @d_inc2, 0, 0, $8E
 // TWO MINUS
 char d_dec2 = "2-"
 byte = inlinew_flag
-word = @d_dec, 0, @_dec2_, $8E8E
+word = @d_dec, 0, 0, $8E8E
 // SUB
 char d_sub = "-"
 byte = inline_flag
-word = @d_dec2, 0, @_sub_, $84
+word = @d_dec2, 0, 0, $84
 // MUL
 char d_mul = "*"
 byte = inline_flag
-word = @d_sub, 0, @_mul_, $86
+word = @d_sub, 0, 0, $86
 // DIV
 char d_div = "/"
 byte = inline_flag
-word = @d_mul, 0, @_div_, $88
+word = @d_mul, 0, 0, $88
 // DIVMOD
 char d_divmod = "/MOD"
 byte = inline_flag
-word = @d_div, 0, @divmod, $36
+word = @d_div, 0, 0, $36
 // MOD
 char d_mod = "MOD"
 byte = inline_flag
-word = @d_divmod, 0, @_mod_, $8A
+word = @d_divmod, 0, 0, $8A
 // NEG
 char d_neg = "NEGATE"
 byte = inline_flag
-word = @d_mod, 0, @_neg_, $90
+word = @d_mod, 0, 0, $90
 // AND
 char d_and = "AND"
 byte = inline_flag
-word = @d_neg, 0, @_and_, $94
+word = @d_neg, 0, 0, $94
 // OR
 char d_or = "OR"
 byte = inline_flag
-word = @d_and, 0, @_or_, $96
+word = @d_and, 0, 0, $96
 // XOR
 char d_xor = "XOR"
 byte = inline_flag
-word = @d_or, 0, @_xor_, $98
+word = @d_or, 0, 0, $98
 // COMPLEMENT
 char d_complement = "COMPLEMENT"
 byte = inline_flag
-word = @d_xor, 0, @_complement_, $92
+word = @d_xor, 0, 0, $92
 // NOT
 char d_not = "NOT"
 byte = inline_flag
-word = @d_complement, 0, @_not_, $80
+word = @d_complement, 0, 0, $80
 // LEFT SHIFT
 char d_lshift = "LSHIFT"
 byte = inline_flag
-word = @d_not, 0, @_lshift_, $9A
+word = @d_not, 0, 0, $9A
 // RIGHT SHIFT
 char d_rshift = "RSHIFT"
 byte = inline_flag
-word = @d_lshift, 0, @_rshift_, $9C
+word = @d_lshift, 0, 0, $9C
 // EQUALS
 char d_eq = "="
 byte = inline_flag
-word = @d_rshift, 0, @_eq_, $40
+word = @d_rshift, 0, 0, $40
 // GREATER THAN
 char d_gt = ">"
 byte = inline_flag
-word = @d_eq, 0, @_gt_, $44
+word = @d_eq, 0, 0, $44
 // LESS THAN
 char d_lt = "<"
 byte = inline_flag
-word = @d_gt, 0, @_lt_, $46
+word = @d_gt, 0, 0, $46
 // UNSIGNED GREATER THAN
 char d_ugt = "U>"
 byte = 0
@@ -240,11 +235,11 @@ word = @d_ugt, 0, @isult
 // LESS THAN ZERO
 char d_0lt = "0<"
 byte = inlinew_flag
-word = @d_ult, 0, @_0lt_, $4600 // ZERO ISLT
+word = @d_ult, 0, 0, $4600 // ZERO ISLT
 // EQUALS ZERO
 char d_0eq = "0="
 byte = inlinew_flag
-word = @d_0lt, 0, @_0eq_, $4000 // ZERO ISEQ
+word = @d_0lt, 0, 0, $4000 // ZERO ISEQ
 // ABS
 char d_abs = "ABS"
 byte = 0
@@ -260,11 +255,11 @@ word = @d_min, 0, @_max_
 // CHAR PUT
 char d_cset = "C!"
 byte = inline_flag
-word = @d_max, 0, @_cset_, $70
+word = @d_max, 0, 0, $70
 // WORD PUT
 char d_wset = "!"
 byte = inline_flag
-word = @d_cset, 0, @_wset_, $72
+word = @d_cset, 0, 0, $72
 // WORD PLUS PUT
 char d_wplusset = "+!"
 byte = 0
@@ -272,11 +267,11 @@ word = @d_wset, 0, @_wplusset_
 // CHAR GET
 char d_cget = "C@"
 byte = inline_flag
-word = @d_wplusset, 0, @_cget_, $60
+word = @d_wplusset, 0, 0, $60
 // WORD SET
 char d_wget = "@"
 byte = inline_flag
-word = @d_cget, 0, @_wget_, $62
+word = @d_cget, 0, 0, $62
 // EXECUTE
 char d_execute = "EXECUTE"
 byte = 0
@@ -1064,15 +1059,9 @@ end
 //
 // Intrinsics
 //
-def _drop_(a)#0
-  return
-end
 def _swap_(a,b)#2
   return b,a
 end
-def _dup_(a)#2
-  return a,a
-end
 def _dashdup_(a)#1
   if a; (@push)(a)#0; fin
   return a
@@ -1083,78 +1072,6 @@ end
 def _rot_(a,b,c)#3
   return b,c,a
 end
-def _add_(a,b)#1
-  return a+b
-end
-def _inc_(a)
-  return a + 1
-end
-def _inc2_(a)
-  return a + 2
-end
-def _dec_(a)
-  return a - 1
-end
-def _dec2_(a)
-  return a - 2
-end
-def _sub_(a,b)#1
-  return a-b
-end
-def _mul_(a,b)#1
-  return a*b
-end
-def _div_(a,b)#1
-  return a/b
-end
-def _mod_(a,b)#1
-    return a%b
-end
-def _neg_(a)#1
-  return -a
-end
-def _lshift_(a,b)#1
-    return a<<b
-end
-def _rshift_(a,b)#1
-    return a>>b
-end
-def _and_(a,b)#1
-  return a & b
-end
-def _or_(a,b)#1
-  return a | b
-end
-def _xor_(a,b)#1
-  return a ^ b
-end
-def _complement_(a)#1
-  return ~a
-end
-def _not_(a)#1
-  return not a
-end
-def _eq_(a,b)#1
-  return a == b
-end
-def _gt_(a,b)#1
-  return a > b
-end
-def _lt_(a,b)#1
-  return a < b
-end
-def _0lt_(a)#1
-  return a < 0
-end
-def _0eq_(a)#1
-  return a == 0
-end
-def _cset_(a,b)#0
-  ^b = a
-end
-def _wset_(a,b)#0
-  *b = a
-end
 def _wplusset_(a,b)#0
   *b = *b + a
 end
@@ -1167,12 +1084,6 @@ end
 def _max_(a,b)
   return a > b ?? a :: b
 end
-def _cget_(a)#1
-  return ^a
-end
-def _wget_(a)#1
-  return *a
-end
 def _ffa_(dentry)#1
   return dentry + ^dentry + 1
 end
@@ -1272,8 +1183,7 @@ def _plasma_(a)#0
 end
 def _var_(a)#0
   newdict
-  _dictaddb_($20)          // Hack - get VM entry vector from divmod
+  _dictaddb_(JSR); _dictaddw_(vmvect)
-  _dictaddw_(*(@divmod + 1))
   _dictaddb_($2C)          // CONSTANT WORD
   _dictaddw_(heapmark + 3) // Poiner to variable in PFA
   _dictaddb_($5C)          // RET
@@ -1282,8 +1192,7 @@ def _var_(a)#0
 end
 def _const_(a)#0
   newdict
-  _dictaddb_($20)          // Hack - get VM entry vector from divmod
+  _dictaddb_(JSR); _dictaddw_(vmvect)
-  _dictaddw_(*(@divmod + 1))
   _dictaddb_($2C)          // CONSTANT WORD
   _dictaddw_(a)
   _dictaddb_($5C)          // RET
@@ -1291,8 +1200,7 @@ def _const_(a)#0
 end
 def _create_#0
   newdict
-  _dictaddb_($20)          // Hack - get VM entry vector from divmod
+  _dictaddb_(JSR); _dictaddw_(vmvect)
-  _dictaddw_(*(@divmod + 1))
   _dictaddb_($2C)          // CONSTANT WORD
   _dictaddw_(heapmark + 5) // Pointer to rest of PFA
   _dictaddb_($5C)          // RET
@@ -1348,8 +1256,7 @@ def _colon_#0
     ^(_ffa_(vlist)) = itc_flag
     *(_cfa_(vlist)) = @_docolon_
   else // comp_pbc_flag
-    _dictaddb_($20)            // Hack - get VM entry vector from divmod
+    _dictaddb_(JSR); _dictaddw_(vmvect)
-    _dictaddw_(*(@divmod + 1))
   fin
   if state & trace_flag
     puts(vlist); putc(' ')
@@ -1967,18 +1874,47 @@ end
 def _bye_#0
   throw(@exitforth, TRUE)
 end
-
+//
+// Start FORTH
+//
 puts("FORTH (Alpha) for PLASMA 2.1\n")
 if cmdsys:sysver < $0201
   puts("PLASMA >= 2.01 required\n")
   return
 fin
+//
+// Compile ITC version of inline words ( speeds it up a smidge )
+//
+vmvect = *(@divmod + 1)  // Hack - get VM entry vector from divmod
+vlist  = @d_vlist
+while vlist
+  if *_cfa_(vlist) == 0
+    *_cfa_(vlist) = heapmark
+    _dictaddb_(JSR); _dictaddw_(vmvect)
+    if ^_ffa_(vlist) == inline_flag
+      _dictaddb_(^_pfa_(vlist))
+    elsif ^_ffa_(vlist) == inlinew_flag
+      _dictaddw_(*_pfa_(vlist))
+    else
+      puts(vlist); puts(": Invalid dictionary\n")
+      return -1
+    fin
+    _dictaddb_($5C) // RET
+  fin
+  vlist = *_lfa_(vlist)
+loop
 _estkl = ^(@syscall + 1) // Hack to fill in parameter stack locations
 _estkh = ^(@syscall + 3)
 fileio:iobufalloc(4) // Allocate a bunch of file buffers
 startheap = heapmark
 coldstart
+//
+// Check for command line argument
+//
 inptr = argNext(argFirst)
+//
+// Main start and restart entry
+//
 if not except(@exitforth)
   if ^inptr; inptr++; _srcstr_; fin
   _interpret_