Implement DOES>

Author: malyn

Diff for: DefGen/src/defgen/core.clj

@@ -141,7 +141,7 @@
   (let [name-size (if hidden? 0 (count name))
         header-size (+ 1 ;; PSF+5bit name length
                        2 ;; LFA
-                       1)] ;; CFA
+                       2)] ;; CFA
     (assoc rom-def ::name-size name-size ::header-size header-size)))
 
 (defn token-byte-size
@@ -195,7 +195,7 @@
                                [(str (when immediate? "0x80|")
                                      (if hidden? 0 (count name)))]
                                [(xt-to-bytes (rom-def-prev-xts id))]
-                               [cfa])))
+                               [0 cfa])))
               rom-defs)))
 
 (defn extract-branch-span

Diff for: TODO.md

@@ -1,5 +1,8 @@
 # Before Release
 
+* Change XTs to point at the CFA (which is what a DOES>-inserted XT already targets...) instead of the NFA.  This will make all XTs immediately executable.
+  * This may make it possible to put real XTs on the return stack, which would avoid that bogus $8xxx thing that only happens to work because Arduino's have less than 32KB of RAM.
+* Change ROM Definitions to be $4xxx instead of $Cxxx; the later could show up if we have >16KB dictionary (since User Defintions are $8xxx and $Cxxx just means that the second-highest bit was set).
 * Implement the remaining `CORE` words (the ones whose tests have been commented out in `test_core.cpp`).
 * Do we need `I*` tokens or can normal tokens just use inProgramSpace?  (and if so, is that actually smaller from a compile perspective?)
   * Looks like we can make this change and that it will be (slightly) smaller, if not (slightly) slower.  We shouldn't make the change until we can run the tests on the Arduino though (just in case we break something).

Diff for: definitions/core.edn

@@ -154,9 +154,9 @@
  :name ":"
  :args [[] []]
  :source ": : ( \"<spaces>name\" -- )
-            CREATE  HIDE  -1 ALLOT ['] DOCOLON C,  ]"
+            CREATE  HIDE  -2 ALLOT ['] DOCOLON XT,  ]"
  :pfa [:create :hide
-       :zero :oneminus :allot :icharlit "DOCOLON" :ccomma
+       :zero :oneminus :oneminus :allot :icharlit "DOCOLON" :xtcomma
        :rtbracket
        :exit]}
 
@@ -170,14 +170,18 @@
 ;; around and basically do a similar thing to decide if this is not a
 ;; DO* word.  We need some way to differentiate between these things: a
 ;; token and a definition.
+;; FIXME XT@XT should really be CFA@ (similar to LFA@) and then do the
+;; offset on its own (just like LFA@).  This will make it easier to
+;; eventually change target of an XT (to the CFA instead of the LFA, for
+;; example).
 {:token :compilecomma
  :name "COMPILE,"
  :args [[:xt] []]
  :source ": COMPILE, ( xt --)
             DUP TOKEN? IF C, EXIT THEN
-            DUP 3 + ( >CFA) C@XT  DUP $70 < IF C, DROP ELSE DROP XT, THEN ;"
+            DUP 3 + ( >CFA) XT@XT DUP $70 < IF C, DROP ELSE DROP XT, THEN ;"
  :pfa [:dup :tokenq :izbranch 3 :ccomma :exit
-       :dup :oneplus :oneplus :oneplus :cfetchxt
+       :dup :oneplus :oneplus :oneplus :xtfetchxt
        :dup :icharlit 0x70 :lessthan :izbranch 5
          :ccomma :drop :ibranch 3
          :drop :xtcomma
@@ -186,8 +190,8 @@
 {:token :constant
  :args [[:x] []]
  :source ": CONSTANT ( x \"<spaces>name\" -- )
-            CREATE  -1 ALLOT ['] DOCONSTANT C,  , ;"
- :pfa [:create :zero :oneminus :allot :icharlit "DOCONSTANT" :ccomma
+            CREATE  -2 ALLOT ['] DOCONSTANT XT,  , ;"
+ :pfa [:create :zero :oneminus :oneminus :allot :icharlit "DOCONSTANT" :xtcomma
        :comma
        :exit]}
 
@@ -215,7 +219,7 @@
             BL PARSE-WORD DUP 0= IF ABORT THEN ( ca u)
             TUCK ( u ca u) NAME, ( u)
             HERE >XT ( u this-xt)  SWAP C,  LATEST @ XT,  ( this-xt) LATEST !
-            ['] DOCREATE C,  ALIGN ;"
+            ['] DOCREATE XT,   ALIGN ;"
  :pfa [:bl :parseword :dup :zeroequals :izbranch 2 :abort
        :tuck
        ; NAME,
@@ -225,7 +229,10 @@
            :oneminus :dup :cfetch :ccomma :ibranch -9
          :twodrop
        :here :toxt :swap :ccomma :latest :fetch :xtcomma :latest :store
-       :icharlit "DOCREATE" :ccomma
+       :icharlit "DOCREATE" :xtcomma
+       ;; FIXME This ALIGN seems wrong; the VM will just point W right
+       ;; after the CFA, for example, and not take ALIGN into account.
+       ;; We should probably no-op ALIGN and then stop calling it.
        :align
        :exit]}
 
@@ -244,6 +251,72 @@
             0 'PREVLEAVE !  ['] (DO) COMPILE,  HERE ; IMMEDIATE"
  :pfa [:zero :tickprevleave :store :icharlit :pdo :compilecomma :here :exit]}
 
+;; CREATE puts a two-byte XT containing the DOCREATE token into the Code
+;; Field.  Various other defining words (CONSTANT, VARIABLE, etc.)
+;; replace that token with a different token.  DOES> also needs to
+;; replace the Code Field, but needs to replace it with an XT and not a
+;; token.  That reason alone is why the Code Field is two bytes instead
+;; of one byte.
+;;
+;; What goes in this DOES>-modified Code Field?  The XT of the runtime
+;; behavior of the defining word -- the code after DOES> in other words.
+;;
+;; Here is how CREATE..DOES>.. works:
+;;
+;; Compile Time behavior:
+;; 1. Defining word is created that looks like: ": NAMEDZERO: CREATE 0 , DOES> @ ;".
+;; 2. DOES> is an immediate word that compiles (does>) into the defining
+;;    word's thread.
+;; 3. User calls this word to create a new word: "NAMEDZERO: nothing".
+;; 4. Defining word runs CREATE, which creates a new definition.  In
+;;    this case, the definition compiles a zero into the dictionary.
+;; 5. Then (does>) executes (remember, we are still in the NAMEDZERO:
+;;    thread at this point).  (does>) exits the current definition (which
+;;    is "NAMEDZERO:" in this example) by popping the return stack
+;;    pointer.  That pointer contains the address of the word after
+;;    (does>) from the NAMEDZERO: definition itself.  That pointer is
+;;    the start of the runtime behavior of the defining word.
+;; 6. (does>) then gets the address of the LATEST definition (which is
+;;    the one that we CREATEd in step 4) and advances to the CFA (which
+;;    so far is DOCREATE).
+;; 7. (does>) rewrites that CFA to point to the address after (does>),
+;;    which was popped in step 5.
+;;
+;; Runtime behavior:
+;; 1. The defined word ("nothing" in this example) runs.  Its CFA points
+;;    to the thread after (does>).  The Enforth inner interpreter has
+;;    special code that detects this situation -- a Code Field that
+;;    contains an XT and not a token -- and knows that the Code Field
+;;    was modified by (does>).  The inner interpreter jumps to DODOES.
+;; 2. DODOES pushes the IP to the return stack -- we're calling another
+;;    word here, just like in DOCOLON.  Then DODOES pushes W (the PFA of
+;;    the *defined* word, aka "nothing" in this example) to the data
+;;    stack.  Finally, DODOES sets IP to the runtime thread of the
+;;    defining word (from "NAMEDZERO:").
+;; 3. Execution continues in the body of the defining word.
+{:token :pdoes
+ :name "(does>)"
+ :flags #{:headerless}
+ :source ": (does>)
+            R> >XT ( XT of runtime behavior for the defining word)
+            LATEST @ >NFA kNFAtoCFA + ( addr of original CFA)
+            XT! ( rewrite CFA to point to runtime part of defining word) ;"
+ :pfa [:rfrom :toxt
+       :latest :fetch :tonfa :icharlit "kNFAtoCFA" :plus
+       :xtstore
+       :exit]}
+
+{:token :does
+ :name "DOES>"
+ :flags #{:immediate}
+ :source ": DOES> ( -- )  ['] (does>) XT, ; IMMEDIATE"
+ :pfa [:icharlit "((uint8_t)((ROMDEF_PDOES >> 8) & 0xff))"
+       :icharlit 8 :lshift
+       :icharlit "((uint8_t)((ROMDEF_PDOES     ) & 0xff))"
+       :or
+       :xtcomma
+       :exit]}
+
 {:token :dot
  :name "."
  :args [[:n] []]
@@ -703,8 +776,8 @@
 {:token :tobody
  :name ">BODY"
  :args [[:xt] [:a-addr]]
- :source ": >BODY ( xt -- a-addr)  XTMASK AND 'DICT + 4 + ( NFA + LFA + CFA) ;"
- :pfa [:xtmask :and :tickdict :plus :icharlit 4 :plus
+ :source ": >BODY ( xt -- a-addr)  XTMASK AND 'DICT + kNFAtoPFA + ;"
+ :pfa [:xtmask :and :tickdict :plus :icharlit "kNFAtoPFA" :plus
        ;; TODO Add :align if we start aligning the PFA.
        :exit]}
 
@@ -774,8 +847,8 @@
 {:token :variable
  :args [[] []]
  :source ": VARIABLE ( \"<spaces>name\" -- )
-            CREATE  -1 ALLOT ['] DOVARIABLE C,  0 , ;"
- :pfa [:create :zero :oneminus :allot :icharlit "DOVARIABLE" :ccomma
+            CREATE  -2 ALLOT ['] DOVARIABLE XT,  0 , ;"
+ :pfa [:create :zero :oneminus :oneminus :allot :icharlit "DOVARIABLE" :xtcomma
        :zero :comma
        :exit]}
 

Diff for: definitions/enforth.edn

@@ -432,11 +432,8 @@
  :name "LFA@"
  :args [[:xt] [:xt]]
  :flags #{:headerless}
- :source ": LFA@ ( xt -- xt')
-            1+ ( NFA>LFA)  DUP C@XT 8 LSHIFT  SWAP 1+ C@XT  OR ;"
- :pfa [:oneplus
-       :dup :cfetchxt :icharlit 8 :lshift
-       :swap :oneplus :cfetchxt :or :exit]}
+ :source ": LFA@ ( xt -- xt')  1+ ( NFA>LFA)  XT@XT ;"
+ :pfa [:oneplus :xtfetchxt :exit]}
 
 ;; Length of the definition name, not necessarily the NFA field (because
 ;; FFI trampolines have a zero-length NFA since the name is stored in
@@ -704,14 +701,14 @@
             0= IF TYPE  SPACE  [CHAR] ? EMIT  CR  ABORT THEN ( ca u addr)
             HERE >XT ( ca u addr this-xt)  ROT %00100000 OR C, ( ca a xt)
             LATEST @ XT,  ( ca addr this-xt) LATEST !
-            ['] DOFFI0 ( ca addr ffitokenbase) OVER FFIDEF-ARITY + C,
+            ['] DOFFI0 ( ca addr ffitokenbase) OVER FFIDEF-ARITY + XT,
             ( ca addr) ALIGN ,  DROP ;"
  :pfa [:bl :parseword :dup :zeroequals :izbranch 2 :abort
        :twodup :findffidef :zeroequals :izbranch 8
          :type :space :icharlit "'?'" :emit :cr :abort
        :here :toxt :rot :icharlit 0x20 :or :ccomma
        :latest :fetch :xtcomma :latest :store
-       :icharlit "DOFFI0" :over :ffidefarity :plus :ccomma
+       :icharlit "DOFFI0" :over :ffidefarity :plus :xtcomma
        :align :comma :drop
        :exit]}
 
@@ -722,6 +719,14 @@
  :source ": XT, ( xt -- )  DUP 8 RSHIFT C,  C, ;"
  :pfa [:dup :icharlit 8 :rshift :ccomma :ccomma :exit]}
 
+{:token :xtfetchxt
+ :name "XT@XT"
+ :args [[:xt] [:xt]]
+ :flags #{:headerless}
+ :source ": XT@XT ( xt -- xt')  DUP C@XT 8 LSHIFT  SWAP 1+ C@XT  OR ;"
+ :pfa [:dup :cfetchxt :icharlit 8 :lshift
+       :swap :oneplus :cfetchxt :or :exit]}
+
 {:token :xtflag
  :args [[] [:u]]
  :flags #{:headerless}
@@ -731,3 +736,10 @@
  :args [[] [:u]]
  :flags #{:headerless}
  :pfa [:icharlit 0xff :icharlit 0x3f :icharlit 8 :lshift :or :exit]}
+
+{:token :xtstore
+ :name "XT!"
+ :args [[:xt :addr] []]
+ :flags #{:headerless}
+ :source ": XT! ( xt addr -- )  OVER 8 RSHIFT OVER C!  1+ C! ;"
+ :pfa [:over :icharlit 8 :rshift :over :cstore :oneplus :cstore :exit]}

Diff for: enforth.c

@@ -75,10 +75,10 @@ typedef enum EnforthToken
     DOCOLONROM,
     DOCONSTANT,
     DOCREATE,
-    DODOES,
     DOVARIABLE,
     /* Unused */
     /* Unused */
+    /* Unused */
 
     DOFFI0 = 0x78,
     DOFFI1,
@@ -97,7 +97,7 @@ typedef enum EnforthToken
  */
 
 static const int kNFAtoCFA = 1 /* PSF+namelen */ + 2 /* LFA */;
-static const int kNFAtoPFA = 1 /* PSF+namelen */ + 2 /* LFA */ + 1; /* CFA */
+static const int kNFAtoPFA = 1 /* PSF+namelen */ + 2 /* LFA */ + 2; /* CFA */
 
 static const int kTaskUserVariableSize = 8;
 static const int kTaskReturnStackSize = 32;
@@ -311,10 +311,10 @@ void enforth_resume(EnforthVM * const vm)
         &&DOCONSTANT,
         &&DOCREATE,
 
-        0, /* &&DODOES, */
         &&DOVARIABLE,
         0, /* Unused */
         0, /* Unused */
+        0, /* Unused */
 
         /* $78 - $7F */
         &&DOFFI0,
@@ -399,12 +399,26 @@ void enforth_resume(EnforthVM * const vm)
             }
 
 DISPATCH_XT:
-            /* Convert the XT into a Word Pointer depending on the type
-             * of XT (ROM definition or user definition) and then read
-             * the CFA. */
+            /* This is a two-byte XT that points at another word.  We
+             * need to find the word that is being targeted by this XT
+             * and set W to that word's PFA.  We then need to dispatch
+             * to the word's Code Field.  The Code Field will almost
+             * always contain a DO* token, *unless the word was modified
+             * by a defining word.*  In that case, the Code Field will
+             * contain a full, two-byte XT and that XT will point to the
+             * runtime behavior of the defining word (the code after
+             * DOES> in the defining word).
+             *
+             * Note that ROM Definitions never use DOES> and so we can
+             * assume that the Code Field in a ROM Definition will
+             * always contain a token. */
             if ((xt & 0xC000) == 0xC000) /* ROM Definition: 0xCxxx */
             {
-                w = (uint8_t*)((uint8_t*)definitions + (xt & 0x3FFF) + kNFAtoCFA);
+                /* Advance past the empty first byte in the Code Field,
+                 * then read the token in the second byte. */
+                /* TODO We could probably eliminate the first byte in
+                 * ROM Definitions. */
+                w = (uint8_t*)((uint8_t*)definitions + (xt & 0x3FFF) + kNFAtoCFA + 1);
 #ifdef __AVR__
                 token = pgm_read_byte(w++);
 #else
@@ -413,8 +427,24 @@ void enforth_resume(EnforthVM * const vm)
             }
             else /* User Definition: 0x8xxx */
             {
+                /* Load the Code Field. */
                 w = (uint8_t*)(vm->dictionary.ram + (xt & 0x3FFF) + kNFAtoCFA);
-                token = *w++;
+                xt = *w++ << 8;
+                xt |= *w++;
+
+                /* We're done if this is a token. */
+                if (xt < 0x80)
+                {
+                    token = xt;
+                    goto DISPATCH_TOKEN;
+                }
+                else
+                {
+                    /* Not a token, which means that this word was
+                     * defined by DOES>; jump to DODOES to perform the
+                     * runtime behavior of the defining word. */
+                    goto DODOES;
+                }
             }
         }
 
@@ -510,6 +540,8 @@ void enforth_resume(EnforthVM * const vm)
 #ifdef __AVR__
             if (inProgramSpace)
             {
+                /* FIXME Can this ever happen?  How would a ROM word
+                 * know about a RAM word? */
                 /* Set the high bit on the return address so that we
                  * know that this address is in ROM. */
                 ip = (uint8_t*)((unsigned int)ip | 0x8000);
@@ -608,6 +640,45 @@ void enforth_resume(EnforthVM * const vm)
         }
         continue;
 
+        DODOES:
+        {
+            /* We're currently sitting in a word that is calling a word
+             * defined with DOES>.  IP has been advanced beyond that
+             * call and is still in the calling word.  XT contains the
+             * Code Field of the defined word (and thus points to the
+             * DOES> part of the defining word's thread).  We need to
+             * push IP to the stack, push the PFA of the defined word to
+             * the stack, and then continue execution at XT (the
+             * defining word's runtime behavior). */
+#ifdef __AVR__
+            if (inProgramSpace)
+            {
+                /* FIXME Can this ever happen?  How would a ROM word
+                 * know about a RAM word? */
+                /* Set the high bit on the return address so that we
+                 * know that this address is in ROM. */
+                ip = (uint8_t*)((unsigned int)ip | 0x8000);
+
+                /* We are no longer in program space since, by design,
+                 * DODOES is only ever used for user-defined words in
+                 * RAM. */
+                inProgramSpace = 0;
+            }
+#endif
+            (--returnTop)->ram = ip;
+
+            /* W points at the PFA of the defined word; push that to the
+             * stack per the runtime behavior of DOES>. */
+            *--restDataStack = tos;
+            tos.ram = w;
+
+            /* Point IP at the DOES> portion of the defining word (which
+             * is the target of the defined word's Code Field and is
+             * thus in XT). */
+            ip = (uint8_t*)(vm->dictionary.ram + (xt & 0x3FFF));
+        }
+        continue;
+
         DOCREATE:
         DOVARIABLE:
         {