Optimizations: JUMP-loops, FOR loops, and variable access

examples/21locals.txt

@@ -1,8 +1,15 b''
 
 # locals
 
+local variable
+variable = 5
+*pl variable
+global = 42
+
 var = 1
 dynamic { local var = 2 & *pl var }
 *pl var
 
+dynamic { *pl 'Здесь нет локальных переменных' }
+
 ----- locals ---------------

examples/bench.txt

@@ -1,22 +1,37 b''
 
 # start
+act 'Протестировать цикл на метках':
+  gs 'test_jump'
+end
+act 'Протестировать цикл for':
+  gs 'test_for'
+end
+-
+
+# test_jump
+*nl
 i = 0
+local start_time = MSECSCOUNT
 :loop
 if i < 10000000:
   i += 1
   if (i MOD 100000) = 0:
     *p '.'
   end
-  jump loop
+  jump 'loop'
 end
-looptime = MSECSCOUNT
+local looptime = MSECSCOUNT - start_time
 *nl 'JUMP: Выполнено за <<looptime>> миллисекунд'
+-
+
+# test_for
 *nl
+local start_time = MSECSCOUNT
 for i = 0 to 10000000:
   if (i MOD 100000) = 0:
     *p '.'
   end
 end
-fortime = MSECSCOUNT - looptime
-*nl 'FOR: Выполнено за <<fortime>> миллисекунд'
+local looptime = MSECSCOUNT - start_time
+*nl 'FOR: Выполнено за <<looptime>> миллисекунд'
 -

extras/body.html

@@ -1,13 +1,13 b''
 
 <div id="qsp">
   <div class="qsp-col qsp-col1">
-    <div id="qsp-main" class="qsp-frame">&nbsp;</div>
-    <div id="qsp-acts" class="qsp-frame">&nbsp;</div>
+    <div id="qsp-main" class="qsp-frame">&zwnj;</div>
+    <div id="qsp-acts" class="qsp-frame">&zwnj;</div>
     <input id="qsp-input" class="qsp-frame">
   </div>
   <div class="qsp-col qsp-col2">
-    <div id="qsp-stat" class="qsp-frame">&nbsp;</div>
-    <div id="qsp-objs" class="qsp-frame">&nbsp;</div>
+    <div id="qsp-stat" class="qsp-frame">&zwnj;</div>
+    <div id="qsp-objs" class="qsp-frame">&zwnj;</div>
   </div>
   <div class="qsp-col qsp-col3">
     <a id="qsp-btn-save"><img></a>

src/api.ps

@@ -66,7 +66,7 b''
           (finish-menu nil))))
 
 (defun call-serv-loc (var-name &rest args)
-  (let ((loc-name (get-var var-name 0 :str)))
+  (let ((loc-name (get-global var-name 0)))
     (when loc-name
       (let ((loc (getprop (root locs) loc-name)))
         (when loc
@@ -102,7 +102,8 b''
          (replace (regex "/'/g") "'")))
 
 (defun prepare-contents (s &optional force-html)
-  (if (or force-html (get-var "USEHTML" 0 :num))
+  (setf s (chain s (to-string)))
+  (if (or force-html (get-global "USEHTML" 0))
       s
       (escape-html s)))
 
@@ -119,7 +120,7 b''
 (defun on-input-key (ev)
   (when (= 13 (@ ev key-code))
     (chain ev (prevent-default))
-    (call-serv-loc "USERCOM")))
+    (call-serv-loc "$USERCOM")))
 
 ;;; Function calls
 
@@ -131,9 +132,8 b''
           (set-var args i :str arg)))))
 
 (defun get-result ()
-  (if (not (equal "" (get-var "RESULT" 0 :str)))
-      (get-var "RESULT" 0 :str)
-      (get-var "RESULT" 0 :num)))
+  (or (get-global "$RESULT" 0)
+      (get-global "RESULT" 0)))
 
 (defun call-loc (name args)
   (setf name (chain name (to-upper-case)))
@@ -202,7 +202,7 b''
   (loop :for (k v) :of (root acts)
      :do (setf (getprop v :selected) nil))
   (setf (getprop (root acts) title :selected) t)
-  (call-serv-loc "ONACTSEL"))
+  (call-serv-loc "$ONACTSEL"))
 
 ;;; "Syntax"
 
@@ -214,103 +214,39 b''
        (unless (await (funcall body))
          (return-from qspfor))))
 
-;;; Variable class
-
-(defun *var (name)
-  ;; From strings to numbers
-  (setf (@ this :indexes) (create))
-  ;; From numbers to {num: 0, str: ""} objects
-  (setf (@ this :values) (list))
-  (void))
-
-(defun new-value ()
-  (create :num 0 :str ""))
-
-(setf (@ *var prototype index-num)
-      (lambda (index)
-        (let ((num-index
-               (if (stringp index)
-                   (if (in index (@ this :indexes))
-                       (getprop (@ this :indexes) index)
-                       (let ((n (length (@ this :values))))
-                         (setf (getprop (@ this :indexes) index) n)
-                         n))
-                   index)))
-          (unless (in num-index (@ this :values))
-            (setf (elt (@ this :values) num-index) (new-value)))
-          num-index)))
-
-(setf (@ *var prototype get)
-      (lambda (index slot)
-        (unless (or index (= 0 index))
-          (setf index (1- (length (@ this :values)))))
-        (getprop (@ this :values) (chain this (index-num index)) slot)))
-
-(setf (@ *var prototype set)
-      (lambda (index slot value)
-        (unless (or index (= 0 index))
-          (setf index (length (@ this :values))))
-        (case slot
-          (:num (setf value (chain *number (parse-int value))))
-          (:str (setf value (chain value (to-string)))))
-        (setf (getprop (@ this :values)
-                       (chain this (index-num index))
-                       slot) value)
-        (void)))
-
-(setf (@ *var prototype kill)
-      (lambda (index)
-        (setf (elt (@ this :values) (chain this (index-num index)))
-              (new-value))
-        (delete (getprop 'this :indexes index))))
-
 ;;; Variables
 
-(defun var-real-name (name)
-  (if (= (@ name 0) #\$)
-      (values (chain name (substr 1)) :str)
-      (values name :num)))
-
-(defun ensure-var (name)
-  (setf name (chain name (to-upper-case)))
-  (let ((store (var-ref name)))
-    (unless store
-      (setf store (new (*var name)))
-      (setf (getprop (root vars) name) store))
-    store))
-
-(defun var-ref (name)
-  (let ((local-store (current-local-frame)))
-    (cond ((and local-store (in name local-store))
-           (getprop local-store name))
-          ((in name (root vars))
-           (getprop (root vars) name))
-          (t nil))))
+(defun new-var (&optional index)
+  (let ((v (list)))
+    (when index
+      (setf (elt v index) (if (eq #\$ (elt slot 0)) "" 0)))
+    (setf (@ v indexes) (create))
+    v))
 
-(defun get-var (name index slot)
-  (chain (ensure-var name) (get index slot)))
-
-(defun set-var (name index slot value)
-  (chain (ensure-var name) (set index slot value))
-  (let ((serv-var (getprop serv-vars name)))
-    (when serv-var
-      (funcall (@ serv-var :body)
-               (get-var name index (@ serv-var :slot))
-               index)))
-  (void))
+(defun set-str-element (slot index value)
+  (if (in index (getprop slot :indexes))
+      (setf (elt (getprop slot) 
+                 (getprop slot :indexes index))
+            value)
+      (progn
+        (chain slot (push value))
+        (setf (elt slot index)
+              (length slot)))))
 
-(defun get-array (name)
-  (setf name (chain name (to-upper-case)))
-  (ensure-var name))
+(defun set-any-element (slot index value)
+  (if (numberp index)
+      (setf (elt slot index) value)
+      (set-str-element slot index value)))
 
-(defun set-array (name value)
-  (setf name (chain name (to-upper-case)))
-  (let ((store (ensure-var name)))
-    (setf (@ store :values) (@ value :values))
-    (setf (@ store :indexes) (@ value :indexes)))
-  (void))
+(defun get-element (slot index)
+  (if (numberp index)
+      (elt slot index)
+      (elt slot (getprop slot :indexes index))))
 
-(defun kill-var (name &optional index)
+(defun get-global (name index)
+  (elt (getprop (root vars) name) index))
+
+(defun kill-var (store name &optional index)
   (setf name (chain name (to-upper-case)))
   (if (and index (not (= 0 index))) 
       (chain (getprop (root vars) name) (kill index))
@@ -333,19 +269,13 b''
 (defun current-local-frame ()
   (elt (root locals) (1- (length (root locals)))))
 
-(defun new-local (name)
-  (let ((frame (current-local-frame)))
-    (unless (in name frame)
-      (setf (getprop frame name) (create)))
-    (void)))
-
 ;;; Objects
 
 (defun select-obj (title img)
   (loop :for (k v) :of (root objs)
      :do (setf (getprop v :selected) nil))
   (setf (getprop (root objs) title :selected) t)
-  (call-serv-loc "ONOBJSEL" title img))
+  (call-serv-loc "$ONOBJSEL" title img))
 
 (defun update-objs ()
   (let ((elt (by-id "qsp-objs")))
@@ -475,7 +405,7 b''
     (chain document body (remove-child element))))
 
 (defun stash-state (args)
-  (call-serv-loc "ONGSAVE")
+  (call-serv-loc "$ONGSAVE")
   (setf (root state-stash)
         (chain *j-s-o-n (stringify
                          (create :vars (root vars)
@@ -506,7 +436,7 b''
           (@ data :stat-html))
     (update-objs)
     (set-timer (@ data :timer-interval))
-    (call-serv-loc "ONGLOAD")
+    (call-serv-loc "$ONGLOAD")
     (call-loc (root current-location) (@ data :loc-args))
     (void)))
 
@@ -524,7 +454,7 b''
   (setf (root timer-obj)
         (set-interval
          (lambda ()
-           (call-serv-loc "COUNTER"))
+           (call-serv-loc "$COUNTER"))
          interval)))
 
 ;;; Special variables

src/package.lisp

@@ -12,6 +12,14 b''
            #:state-stash #:playing #:locals
            #:acts #:locs #:games))
 
+(defpackage :code-walker
+  (:use :cl)
+  (:export #:deftransform
+           #:deftransform-stop
+           #:walk
+           #:whole
+           #:walk-continue))
+
 ;;; API functions
 (defpackage :sugar-qsp.api
   (:use :cl :ps :sugar-qsp.main :sugar-qsp.js)
@@ -38,7 +46,8 b''
 ;;; QSP library functions and macros
 (defpackage :sugar-qsp.lib
   (:use :cl :ps :sugar-qsp.main :sugar-qsp.js)
-  (:local-nicknames (#:api :sugar-qsp.api))
+  (:local-nicknames (#:api :sugar-qsp.api)
+                    (#:walker :code-walker))
   (:export #:str #:exec #:qspblock #:qspfor #:game #:location
            #:qspcond #:qspvar #:set #:local #:jump
 
@@ -83,17 +92,13 b''
 (setf (ps:ps-package-prefix "SUGAR-QSP.API") "qsp_api_")
 (setf (ps:ps-package-prefix "SUGAR-QSP.LIB") "qsp_lib_")
 
-(defpackage :code-walker
-  (:use :cl)
-  (:export #:deftransform
-           #:walk))
-
 ;;; The compiler
 (defpackage :sugar-qsp
   (:use :cl)
   (:local-nicknames (#:p #:esrap)
                     (#:lib :sugar-qsp.lib)
                     (#:api :sugar-qsp.api)
-                    (#:main :sugar-qsp.main))
+                    (#:main :sugar-qsp.main)
+                    (#:walker :code-walker))
   (:export #:parse-file #:entry-point))
 

src/parser.lisp

@@ -47,7 +47,7 b''
   (destructuring-bind (ws1 operator ws2 operand2)
       list
     (declare (ignore ws1 ws2))
-    (list (intern (string-upcase operator) :lib) operand2)))
+    (list (intern (string-upcase operator) "SUGAR-QSP.LIB") operand2)))
 
 (defun do-binop% (left-op other-ops)
   (if (null other-ops)
@@ -354,8 +354,6 b''
                                block-for-head-step
                                colon spaces?)
   (:lambda (list)
-    (unless (eq (fourth (third list)) :num)
-      (error "For counter variable must be numeric."))
     (list 'lib:qspfor
           (elt list 2)
           (elt list 6)
@@ -594,9 +592,7 b''
                  ((nil) 0)
                  (:last nil)
                  (t idx-raw))))
-      (if (char= #\$ (elt (string id) 0))
-          (list 'lib:qspvar (intern (subseq (string-upcase id) 1) :lib) idx :str)
-          (list 'lib:qspvar id idx :num)))))
+      (list 'lib:qspvar id idx))))
 
 (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\])
   (:lambda (list)

src/ps-macros.lisp

@@ -5,6 +5,14 b''
 ;;;; representation directly compilable by Parenscript
 ;;;; Some utility macros for other .ps sources too.
 
+;;;; Block type | Has own locals | Has labels | async
+;;;  Location   | TRUE           | TRUE       | TRUE
+;;;  Act        | TRUE           | TRUE       | TRUE
+;;;  {}         | TRUE           | TRUE       | TRUE
+;;;  IF         | FALSE          | TRUE       | TRUE
+;;;  FOR        | FALSE          | TRUE       | TRUE
+;;;  
+
 ;;; Utils
 
 ;;; Common
@@ -27,12 +35,41 b''
         (t
          `(& ,@forms))))
 
+(defpsmacro locals-block (&body body)
+  "Includes labels too (through qsp-lambda)"
+  (let ((*locals* nil))
+    (walker:walk 'locals body)
+    `(qsp-lambda
+      (create-locals ,*locals*)
+      ,@(walker:walk 'apply-vars body))))
+
 ;;; 1loc
 
+(defparameter *service-variables*
+  '((usehtml 0)
+    (result 0)
+    ($result "")
+    ($ongload "")
+    ($ongsave "")
+    ($onobjadd "")
+    ($onobjdel "")
+    ($onobjsel "")
+    ($onnewloc "")
+    ($onactsel "")
+    ($counter "")
+    ($usercom "")))
+
 (defpsmacro game ((name) &body body)
+  (setf body (walker:walk 'for-transform body))
+  (setf *globals* *service-variables*)
+  (walker:walk 'globals body)
   `(progn
+     ;; Game object
      (setf (root games ,name)
            (create))
+     ;; Global variables from this game
+     (create-globals ,*globals*)
+     ;; Locations
      ,@(loop :for location :in body
           :collect `(setf (root games ,name ,(caadr location))
                           ,location))))
@@ -40,9 +77,7 b''
 (defpsmacro location ((name) &body body)
   (declare (ignore name))
   "Name is used by the game macro above"
-  `(async-lambda ()
-     (label-block ()
-       ,@body)))
+  `(locals-block ,@body))
 
 (defpsmacro goto% (target &rest args)
   `(progn
@@ -56,12 +91,111 b''
 
 ;;; 2var
 
-(defpsmacro qspvar (name index slot)
-  `(api-call get-var ,(string name) ,index ,slot))
+(defvar *globals* nil)
+(defvar *locals* nil)
+
+(defpsmacro create-globals (globals)
+  `(chain *object
+          (assign (root vars)
+                  (create ,@(loop :for (name index slot)
+                               :in globals
+                               :append `(,(string-upcase name) (api-call new-var ,index)))))))
+
+(walker:deftransform globals qspvar (&rest var)
+  (pushnew var *globals* :test #'equal)
+  (walker:walk-continue))
+
+(walker:deftransform globals local (var &rest expr)
+  (declare (ignore var))
+  (walker:walk 'globals expr))
+
+(defpsmacro create-locals (locals)
+  (when locals
+    `(progn
+       (var locals (create
+                    ,@(loop :for (name index) :in locals
+                         :append `(,(string-upcase name) (api-call new-var))))))))
+
+;; locations, blocks, and acts all have their own locals namespace
+(walker:deftransform-stop locals qspblock)
+(walker:deftransform-stop locals act)
+
+(walker:deftransform locals local (var &optional expr)
+  (declare (ignore expr))
+  (pushnew (rest var) *locals* :test #'equal)
+  nil)
+
+;; index types:
+;; literal number
+;; literal string
+;; variable number
+;; variable string
+;; expression (may be possible to determine if it's a string or a number)
+
+(defun $-var-p (sym)
+  (char= #\$ (elt (string-upcase (symbol-name sym)) 0)))
+
+(defun literal-string-p (form)
+  (and (listp form)
+       (eq 'str (first form))))
+
+(defun variable-number-p (form)
+  (and (listp form)
+       (eq 'qspvar (first form))
+       (not ($-var-p (second form)))))
 
-(defpsmacro set ((var vname vindex vslot) value)
-  (assert (eq var 'qspvar))
-  `(api-call set-var ,(string vname) ,vindex ,vslot ,value))
+(defun variable-string-p (form)
+  (and (listp form)
+       (eq 'qspvar (first form))
+       ($-var-p (second form))))
+
+(walker:deftransform apply-vars set (var expr)
+  (destructuring-bind (qspvar name index)
+      var
+    (declare (ignore qspvar))
+    (let ((slot `(getprop
+                  ,(if (member name *locals* :key #'first)
+                       'locals '(root vars))
+                  ,(string-upcase name))))
+      (cond
+        ((or (numberp index)
+             (variable-number-p index))
+         `(setf (elt ,slot ,index)
+                ,(walker:walk 'apply-vars expr)))
+        ((or (literal-string-p index)
+             (variable-string-p index))
+         `(set-str-element ,slot ,(walker:walk 'apply-vars index)
+                           (walker:walk 'apply-vars ,expr)))
+        (t
+         `(set-any-element ,slot ,index
+                           (walker:walk 'apply-vars ,expr)))))))
+
+(walker:deftransform apply-vars local (var &optional expr)
+  (when expr
+    (walker:walk 'apply-vars (list 'set var expr))))
+
+(walker:deftransform apply-vars qspvar (name index)
+  (let ((slot `(getprop
+                ,(if (member name *locals* :key #'first) 'locals '(root vars))
+                ,(string-upcase name))))
+    (cond
+      ((or (numberp index)
+           (variable-number-p index))
+       `(elt ,slot ,index))
+      ((or (literal-string-p index)
+           (variable-string-p index))
+       `(elt ,slot (@ ,slot :indexes ,index)))
+      (t
+       `(get-element ,slot ,index)))))
+
+(walker:deftransform apply-vars qspblock (&rest block)
+  (declare (ignore block))
+  (walker:whole))
+(walker:deftransform apply-vars act (&rest block)
+  (declare (ignore block))
+  (walker:whole))
+(walker:deftransform apply-vars qspfor (var from to step body)
+  (list* 'qspfor var (mapcar #'walker:walk-continue (list from to step body))))
 
 ;;; 3expr
 
@@ -100,37 +234,72 b''
   `(return-from label-body ,(string-upcase (second target))))
 
 (defpsmacro tagbody (&body body)
-  (let ((funcs (list nil "_nil")))
-    (dolist (form body)
-      (cond ((keywordp form)
-             (setf (first funcs) (reverse (first funcs)))
-             (push (string-upcase form) funcs)
-             (push nil funcs))
-            (t
-             (push form (first funcs)))))
-    (setf (first funcs) (reverse (first funcs)))
-    (setf funcs (reverse funcs))
-    (if (= 2 (length funcs))
-        `(progn
-           ,@body)
-        `(progn
-           (tagbody-blocks ,funcs)
-           (setf _nextblock :_nil)
-           (loop
-              :for _nextblock
-                := :_nil
-                :then (await (funcall (getprop _labels _nextblock)))
-              :while _nextblock)))))
+  (let ((create-locals (if (eq (caar body) 'create-locals)
+                           (list (car body))))
+        (void (if (equal (car (last body)) '(void))
+                  '((void)))))
+    (when create-locals
+      (setf body (cdr body)))
+    (when void
+      (setf body (butlast body)))
+    (let ((funcs (list nil "_nil")))
+      (dolist (form body)
+        (cond ((keywordp form)
+               (setf (first funcs) (reverse (first funcs)))
+               (push (string-upcase form) funcs)
+               (push nil funcs))
+              (t
+               (push form (first funcs)))))
+      (setf (first funcs) (reverse (first funcs)))
+      (setf funcs (reverse funcs))
+      `(progn
+         ,@create-locals
+         ,(if (= 2 (length funcs))
+              `(progn
+                 ,@body)
+              `(progn
+                 (tagbody-blocks ,funcs)
+                 (loop
+                    :for _nextblock
+                      := :_nil
+                    :then (await (funcall (getprop _labels _nextblock)))
+                    :while _nextblock)))
+         ,@void))))
+
+(defvar *current-label*)
+(defvar *has-jump-back*)
+(walker:deftransform optimize-jump jump (target)
+  (cond ((string= (string-upcase (second target)) *current-label*)
+         (setf *has-jump-back* t)
+         '(continue))
+        (t
+         (walker:walk-continue))))
 
 (defpsmacro tagbody-blocks (funcs)
   `(setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr
               :append `((@ _labels ,label)
                         (async-lambda ()
                           (block label-body
-                            ,@code
-                            ,@(if rest-labels
-                                  (list (first rest-labels))
-                                  nil)))))))
+                            (tagbody-block-body ,label ,code
+                                                ,(first rest-labels))))))))
+
+(defpsmacro tagbody-block-body (label code next-label)
+  (let ((*current-label* label)
+        (*has-jump-back* nil))
+    (let ((code (walker:walk 'optimize-jump code)))
+      (if *has-jump-back*
+          `(progn
+             (loop :do (progn
+                         ,@code
+                         (break)))
+             ,@(if next-label
+                   (list next-label)
+                   nil))
+          `(progn
+             ,@code
+             ,@(if next-label
+                   (list next-label)
+                   nil))))))
 
 (defpsmacro exit ()
   '(return-from nil (values)))
@@ -138,6 +307,10 b''
 ;;; 10dynamic
 
 (defpsmacro qspblock (&body body)
+  `(locals-block
+    ,@body))
+
+(defpsmacro qsp-lambda (&body body)
   `(async-lambda (args)
      (label-block ()
        ,@body)))
@@ -146,9 +319,8 b''
 
 (defpsmacro act (name img &body body)
   `(api-call add-act ,name ,img
-             (async-lambda ()
-               (label-block ()
-                 ,@body))))
+             (locals-block
+               ,@body)))
 
 ;;; 12aux
 
@@ -170,19 +342,13 b''
 
 ;;; 21local
 
-(defpsmacro local (var &optional expr)
-  `(progn
-     (api-call new-local ,(string (second var)))
-     ,@(when expr
-         `((set ,var ,expr)))))
-
 ;;; 22for
 
-(defpsmacro qspfor (var from to step &body body)
-  `(,(intern "QSPFOR" "API")
-    ,(string (second var)) ,(third var) ;; name and index
-    ,from ,to ,step
-    (async-lambda ()
-      (block nil
-        ,@body
-        t))))
+;; Transform because it creates a (set ...) hence it has to be processed
+;; before the apply-vars transform. And macros are processed *after* all
+;; the transforms
+(walker:deftransform for-transform qspfor (var from to step &rest body)
+  `(loop :for i :from ,from :to ,to :by ,step
+      :do (set ,var i)
+      :do (block nil
+            ,@(walker:walk-continue body))))

src/walker.lisp

@@ -9,11 +9,34 b''
            (lambda ,args ,@body))
      (list ',transformer-name ',head)))
 
+(defmacro deftransform-stop (transformer-name head)
+  `(progn
+     (setf (gethash (list ',transformer-name ',head) *transformers*)
+           (lambda (&rest args)
+             (declare (ignore args))
+             nil))
+     (list ',transformer-name ',head)))
+
+(defvar *whole*)
+(defvar *transformer-name*)
+
+(defun whole ()
+  *whole*)
+
+(defun walk-continue (&optional subform)
+  (if subform
+      (walk *transformer-name* subform)
+      (mapcar (lambda (subform)
+                (walk *transformer-name* subform))
+              *whole*)))
+
 (defun walk (transformer-name form)
-  (if (listp form)
-      (let ((transformer (gethash (list transformer-name (first form))
-                                  *transformers*)))
-        (if transformer
-            (apply transformer (rest form))
-            (mapcar (lambda (subform) (walk transformer-name subform)) form)))
-      form))
+  (let ((*transformer-name* transformer-name)
+        (*whole* form))
+    (if (listp form)
+        (let ((transformer (gethash (list transformer-name (first form))
+                                    *transformers* nil)))
+          (if transformer
+              (apply transformer (rest form))
+              (walk-continue)))
+        form)))