From 6860285b07c3611f539a5e1112beccce102a7704 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 6 Dec 2008 04:34:25 +0100 Subject: [PATCH 01/15] FUEL 0.0 : all factor.el functionality in place, plus evaluation. --- extra/fuel/authors.txt | 2 + extra/fuel/fuel-tests.factor | 4 + extra/fuel/fuel.factor | 119 +++++++++++++++ misc/fuel/README | 60 ++++++++ misc/fuel/factor-mode.el | 239 +++++++++++++++++++++++++++++ misc/fuel/fu.el | 26 ++++ misc/fuel/fuel-base.el | 63 ++++++++ misc/fuel/fuel-eval.el | 112 ++++++++++++++ misc/fuel/fuel-font-lock.el | 88 +++++++++++ misc/fuel/fuel-help.el | 208 ++++++++++++++++++++++++++ misc/fuel/fuel-listener.el | 120 +++++++++++++++ misc/fuel/fuel-mode.el | 106 +++++++++++++ misc/fuel/fuel-syntax.el | 281 +++++++++++++++++++++++++++++++++++ 13 files changed, 1428 insertions(+) create mode 100644 extra/fuel/authors.txt create mode 100644 extra/fuel/fuel-tests.factor create mode 100644 extra/fuel/fuel.factor create mode 100644 misc/fuel/README create mode 100644 misc/fuel/factor-mode.el create mode 100644 misc/fuel/fu.el create mode 100644 misc/fuel/fuel-base.el create mode 100644 misc/fuel/fuel-eval.el create mode 100644 misc/fuel/fuel-font-lock.el create mode 100644 misc/fuel/fuel-help.el create mode 100644 misc/fuel/fuel-listener.el create mode 100644 misc/fuel/fuel-mode.el create mode 100644 misc/fuel/fuel-syntax.el diff --git a/extra/fuel/authors.txt b/extra/fuel/authors.txt new file mode 100644 index 0000000000..6acd9d5b04 --- /dev/null +++ b/extra/fuel/authors.txt @@ -0,0 +1,2 @@ +Jose Antonio Ortega Ruiz +Eduardo Cavazos diff --git a/extra/fuel/fuel-tests.factor b/extra/fuel/fuel-tests.factor new file mode 100644 index 0000000000..74bc5d4d45 --- /dev/null +++ b/extra/fuel/fuel-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2008 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test fuel ; +IN: fuel.tests diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor new file mode 100644 index 0000000000..9203f0fcdd --- /dev/null +++ b/extra/fuel/fuel.factor @@ -0,0 +1,119 @@ +! Copyright (C) 2008 Jose Antonio Ortega Ruiz. +! See http://factorcode.org/license.txt for BSD license. + +USING: accessors arrays classes.tuple compiler.units continuations debugger +eval io io.streams.string kernel listener listener.private +make math namespaces parser prettyprint quotations sequences strings +vectors vocabs.loader ; + +IN: fuel + +! > in set ] + [ use>> clone use set ] + [ ds?>> display-stacks? swap [ on ] [ off ] if ] tri + ] unless ; + +SYMBOL: fuel-eval-result +f clone fuel-eval-result set-global + +SYMBOL: fuel-eval-output +f clone fuel-eval-result set-global + +! PRIVATE> + +GENERIC: fuel-pprint ( obj -- ) + +M: object fuel-pprint pprint ; + +M: f fuel-pprint drop "nil" write ; + +M: integer fuel-pprint pprint ; + +M: string fuel-pprint pprint ; + +M: sequence fuel-pprint + dup empty? [ drop f fuel-pprint ] [ + "(" write + [ " " write ] [ fuel-pprint ] interleave + ")" write + ] if ; + +M: tuple fuel-pprint tuple>array fuel-pprint ; + +M: continuation fuel-pprint drop "~continuation~" write ; + +: fuel-eval-set-result ( obj -- ) + clone fuel-eval-result set-global ; + +: fuel-retort ( -- ) + error get + fuel-eval-result get-global + fuel-eval-output get-global + 3array fuel-pprint ; + +: fuel-forget-error ( -- ) + f error set-global ; + +: (fuel-begin-eval) ( -- ) + push-fuel-status + display-stacks? off + fuel-forget-error + f fuel-eval-result set-global + f fuel-eval-output set-global ; + +: (fuel-end-eval) ( quot -- ) + with-string-writer fuel-eval-output set-global + fuel-retort + pop-fuel-status ; + +: (fuel-eval) ( lines -- ) + [ [ parse-lines ] with-compilation-unit call ] curry [ drop ] recover ; + +: (fuel-eval-each) ( lines -- ) + [ 1vector (fuel-eval) ] each ; + +: (fuel-eval-usings) ( usings -- ) + [ "USING: " prepend " ;" append ] map + (fuel-eval-each) fuel-forget-error ; + +: (fuel-eval-in) ( in -- ) + [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; + +: fuel-eval-in-context ( lines in usings -- ) + (fuel-begin-eval) [ + (fuel-eval-usings) + (fuel-eval-in) + (fuel-eval) + ] (fuel-end-eval) ; + +: fuel-begin-eval ( in -- ) + (fuel-begin-eval) + (fuel-eval-in) + fuel-retort ; + +: fuel-eval ( lines -- ) + (fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ; + +: fuel-end-eval ( -- ) + [ ] (fuel-end-eval) ; + + +: fuel-startup ( -- ) + "listener" run ; + +MAIN: fuel-startup diff --git a/misc/fuel/README b/misc/fuel/README new file mode 100644 index 0000000000..b98a23e92a --- /dev/null +++ b/misc/fuel/README @@ -0,0 +1,60 @@ +FUEL, Factor's Ultimate Emacs Library +------------------------------------- + +FUEL provides a complete environment for your Factor coding pleasure +inside Emacs, including source code edition and interaction with a +Factor listener instance running within Emacs. + +FUEL was started by Jose A Ortega as an extension to Ed Cavazos' +original factor.el code. + +Installation +------------ + +FUEL comes bundled with Factor's distribution. The folder misc/fuel +contains Elisp code, and there's a fuel vocabulary in extras/fuel. + +To install FUEL, either add this line to your Emacs initialisation: + + (load-file "/misc/fuel/fu.el") + +or + + (add-to-list load-path "/fuel") + (require 'fuel) + +If all you want is a major mode for editing Factor code with pretty +font colors and indentation, without running the factor listener +inside Emacs, you can use instead: + + (add-to-list load-path "/fuel") + (setq factor-mode-use-fuel nil) + (require 'factor-mode) + +Basic usage +----------- + +If you're using the default factor binary and images locations inside +the Factor's source tree, that should be enough to start using FUEL. +Editing any file with the extension .factor will put you in +factor-mode; try C-hm for a summary of available commands. + +To start the listener, try M-x run-factor. + +Many aspects of the environment can be customized: +M-x customize-group fuel will show you how many. + +Quick key reference +------------------- + + - C-cz : switch to listener + - C-co : cycle between code, tests and docs factor files + + - C-M-x, C-cC-ed : eval definition around point + + - C-cC-da : toggle autodoc mode + - C-cC-dd : help for word at point + - C-cC-ds : short help word at point + +Chords ending in a single letter accept also C- (e.g. C-cC-z is +the same as C-cz). diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el new file mode 100644 index 0000000000..d79930bb22 --- /dev/null +++ b/misc/fuel/factor-mode.el @@ -0,0 +1,239 @@ +;;; factor-mode.el -- mode for editing Factor source + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Tue Dec 02, 2008 21:32 + +;;; Comentary: + +;; Definition of factor-mode, a major Emacs for editing Factor source +;; code. + +;;; Code: + +(require 'fuel-base) +(require 'fuel-syntax) +(require 'fuel-font-lock) + +(require 'ring) + + +;;; Customization: + +(defgroup factor-mode nil + "Major mode for Factor source code" + :group 'fuel) + +(defcustom factor-mode-use-fuel t + "Whether to use the full FUEL facilities in factor mode. + +Set this variable to nil if you just want to use Emacs as the +external editor of your Factor environment, e.g., by putting +these lines in your .emacs: + + (add-to-list 'load-path \"/path/to/factor/misc/fuel\") + (setq factor-mode-use-fuel nil) + (require 'factor-mode) +" + :type 'boolean + :group 'factor-mode) + +(defcustom factor-mode-default-indent-width 4 + "Default indentation width for factor-mode. + +This value will be used for the local variable +`factor-mode-indent-width' in new factor buffers. For existing +code, we first check if `factor-mode-indent-width' is set +explicitly in a local variable section or line (e.g. +'! -*- factor-mode-indent-witdth: 2 -*-'). If that's not the case, +`factor-mode' tries to infer its correct value from the existing +code in the buffer." + :type 'integer + :group 'fuel) + +(defcustom factor-mode-hook nil + "Hook run when entering Factor mode." + :type 'hook + :group 'factor-mode) + + +;;; Syntax table: + +(defun factor-mode--syntax-setup () + (set-syntax-table fuel-syntax--syntax-table) + (set (make-local-variable 'beginning-of-defun-function) + 'fuel-syntax--beginning-of-defun) + (set (make-local-variable 'end-of-defun-function) 'fuel-syntax--end-of-defun) + (set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil) + (fuel-syntax--enable-usings)) + + +;;; Indentation: + +(make-variable-buffer-local + (defvar factor-mode-indent-width factor-mode-default-indent-width + "Indentation width in factor buffers. A local variable.")) + +(defun factor-mode--guess-indent-width () + "Chooses an indentation value from existing code." + (let ((word-cont "^ +[^ ]") + (iw)) + (save-excursion + (beginning-of-buffer) + (while (not iw) + (if (not (re-search-forward fuel-syntax--definition-start-regex nil t)) + (setq iw factor-mode-default-indent-width) + (forward-line) + (when (looking-at word-cont) + (setq iw (current-indentation)))))) + iw)) + +(defun factor-mode--indent-in-brackets () + (save-excursion + (beginning-of-line) + (when (> (fuel-syntax--brackets-depth) 0) + (let ((op (fuel-syntax--brackets-start)) + (cl (fuel-syntax--brackets-end)) + (ln (line-number-at-pos))) + (when (> ln (line-number-at-pos op)) + (if (and (> cl 0) (= ln (line-number-at-pos cl))) + (fuel-syntax--indentation-at op) + (fuel-syntax--increased-indentation (fuel-syntax--indentation-at op)))))))) + +(defun factor-mode--indent-definition () + (save-excursion + (beginning-of-line) + (when (fuel-syntax--at-begin-of-def) 0))) + +(defun factor-mode--indent-setter-line () + (when (fuel-syntax--at-setter-line) + (save-excursion + (let ((indent (and (fuel-syntax--at-constructor-line) (current-indentation)))) + (while (not (or indent + (bobp) + (fuel-syntax--at-begin-of-def) + (fuel-syntax--at-end-of-def))) + (if (fuel-syntax--at-constructor-line) + (setq indent (fuel-syntax--increased-indentation)) + (forward-line -1))) + indent)))) + +(defun factor-mode--indent-continuation () + (save-excursion + (forward-line -1) + (while (and (not (bobp)) + (fuel-syntax--looking-at-emptiness)) + (forward-line -1)) + (cond ((or (fuel-syntax--at-end-of-def) + (fuel-syntax--at-setter-line)) + (fuel-syntax--decreased-indentation)) + ((and (fuel-syntax--at-begin-of-def) + (not (fuel-syntax--at-using))) + (fuel-syntax--increased-indentation)) + (t (current-indentation))))) + +(defun factor-mode--calculate-indentation () + "Calculate Factor indentation for line at point." + (or (and (bobp) 0) + (factor-mode--indent-definition) + (factor-mode--indent-in-brackets) + (factor-mode--indent-setter-line) + (factor-mode--indent-continuation) + 0)) + +(defun factor-mode--indent-line () + "Indent current line as Factor code" + (let ((target (factor-mode--calculate-indentation)) + (pos (- (point-max) (point)))) + (if (= target (current-indentation)) + (if (< (current-column) (current-indentation)) + (back-to-indentation)) + (beginning-of-line) + (delete-horizontal-space) + (indent-to target) + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos)))))) + +(defun factor-mode--indentation-setup () + (set (make-local-variable 'indent-line-function) 'factor-mode--indent-line) + (setq factor-indent-width (factor-mode--guess-indent-width)) + (setq indent-tabs-mode nil)) + + +;;; Buffer cycling: + +(defconst factor-mode--cycle-endings + '(".factor" "-tests.factor" "-docs.factor")) + +(defconst factor-mode--regex-cycle-endings + (format "\\(.*?\\)\\(%s\\)$" + (regexp-opt factor-mode--cycle-endings))) + +(defconst factor-mode--cycle-endings-ring + (let ((ring (make-ring (length factor-mode--cycle-endings)))) + (dolist (e factor-mode--cycle-endings ring) + (ring-insert ring e)))) + +(defun factor-mode--cycle-next (file) + (let* ((match (string-match factor-mode--regex-cycle-endings file)) + (base (and match (match-string-no-properties 1 file))) + (ending (and match (match-string-no-properties 2 file))) + (idx (and ending (ring-member factor-mode--cycle-endings-ring ending))) + (gfl (lambda (i) (concat base (ring-ref factor-mode--cycle-endings-ring i))))) + (if (not idx) file + (let ((l (length factor-mode--cycle-endings)) (i 1) next) + (while (and (not next) (< i l)) + (when (file-exists-p (funcall gfl (+ idx i))) + (setq next (+ idx i))) + (setq i (1+ i))) + (funcall gfl (or next idx)))))) + +(defun factor-mode-visit-other-file (&optional file) + "Cycle between code, tests and docs factor files." + (interactive) + (find-file (factor-mode--cycle-next (or file (buffer-file-name))))) + + +;;; Keymap: + +(defun factor-mode-insert-and-indent (n) + (interactive "p") + (self-insert-command n) + (indent-for-tab-command)) + +(defvar factor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [?\]] 'factor-mode-insert-and-indent) + (define-key map [?}] 'factor-mode-insert-and-indent) + (define-key map "\C-m" 'newline-and-indent) + (define-key map "\C-co" 'factor-mode-visit-other-file) + (define-key map "\C-c\C-o" 'factor-mode-visit-other-file) + map)) + +(defun factor-mode--keymap-setup () + (use-local-map factor-mode-map)) + + +;;; Factor mode: + +;;;###autoload +(defun factor-mode () + "A mode for editing programs written in the Factor programming language. +\\{factor-mode-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'factor-mode) + (setq mode-name "Factor") + (fuel-font-lock--font-lock-setup) + (factor-mode--keymap-setup) + (factor-mode--indentation-setup) + (factor-mode--syntax-setup) + (when factor-mode-use-fuel (require 'fuel-mode) (fuel-mode)) + (run-hooks 'factor-mode-hook)) + + +(provide 'factor-mode) +;;; factor-mode.el ends here diff --git a/misc/fuel/fu.el b/misc/fuel/fu.el new file mode 100644 index 0000000000..508d7ef3a4 --- /dev/null +++ b/misc/fuel/fu.el @@ -0,0 +1,26 @@ +;;; fu.el --- Startup file for FUEL + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages + +;;; Code: + +(add-to-list 'load-path (file-name-directory load-file-name)) + +(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) +(autoload 'factor-mode "factor-mode.el" + "Major mode for editing Factor source." t) + +(autoload 'run-factor "fuel-listener.el" + "Start a Factor listener, or switch to a running one." t) + +(autoload 'fuel-autodoc-mode "fuel-help.el" + "Minor mode showing in the minibuffer a synopsis of Factor word at point." + t) + + + +;;; fu.el ends here diff --git a/misc/fuel/fuel-base.el b/misc/fuel/fuel-base.el new file mode 100644 index 0000000000..a62d16cb32 --- /dev/null +++ b/misc/fuel/fuel-base.el @@ -0,0 +1,63 @@ +;;; fuel-base.el --- Basic FUEL support code + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages + +;;; Commentary: + +;; Basic definitions likely to be used by all FUEL modules. + +;;; Code: + +(defconst fuel-version "1.0") + +;;;###autoload +(defsubst fuel-version () + "Echoes FUEL's version." + (interactive) + (message "FUEL %s" fuel-version)) + + +;;; Customization: + +;;;###autoload +(defgroup fuel nil + "Factor's Ultimate Emacs Library" + :group 'language) + + +;;; Emacs compatibility: + +(eval-after-load "ring" + '(when (not (fboundp 'ring-member)) + (defun ring-member (ring item) + (catch 'found + (dotimes (ind (ring-length ring) nil) + (when (equal item (ring-ref ring ind)) + (throw 'found ind))))))) + + +;;; Utilities + +(defun fuel--shorten-str (str len) + (let ((sl (length str))) + (if (<= sl len) str + (let* ((sep " ... ") + (sepl (length sep)) + (segl (/ (- len sepl) 2))) + (format "%s%s%s" + (substring str 0 segl) + sep + (substring str (- sl segl))))))) + +(defun fuel--shorten-region (begin end len) + (fuel--shorten-str (mapconcat 'identity + (split-string (buffer-substring begin end) nil t) + " ") + len)) + +(provide 'fuel-base) +;;; fuel-base.el ends here diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el new file mode 100644 index 0000000000..c92d8a8831 --- /dev/null +++ b/misc/fuel/fuel-eval.el @@ -0,0 +1,112 @@ +;;; fuel-eval.el --- utilities for communication with fuel-listener + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages +;; Start date: Tue Dec 02, 2008 + +;;; Commentary: + +;; Protocols for handling communications via a comint buffer running a +;; factor listener. + +;;; Code: + +(require 'fuel-base) +(require 'fuel-syntax) + + +;;; Syncronous string sending: + +(defvar fuel-eval-log-max-length 16000) + +(defvar fuel-eval--default-proc-function nil) +(defsubst fuel-eval--default-proc () + (and fuel-eval--default-proc-function + (funcall fuel-eval--default-proc-function))) + +(defvar fuel-eval--proc nil) +(defvar fuel-eval--log t) + +(defun fuel-eval--send-string (str) + (let ((proc (or fuel-eval--proc (fuel-eval--default-proc)))) + (when proc + (with-current-buffer (get-buffer-create "*factor messages*") + (goto-char (point-max)) + (when (and (> fuel-eval-log-max-length 0) + (> (point) fuel-eval-log-max-length)) + (erase-buffer)) + (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 75) "\n")) + (let ((beg (point))) + (comint-redirect-send-command-to-process str (current-buffer) proc nil t) + (with-current-buffer (process-buffer proc) + (while (not comint-redirect-completed) (sleep-for 0 1))) + (goto-char beg) + (current-buffer)))))) + + +;;; Evaluation protocol + +(defsubst fuel-eval--retort-make (err result &optional output) + (list err result output)) + +(defsubst fuel-eval--retort-error (ret) (nth 0 ret)) +(defsubst fuel-eval--retort-result (ret) (nth 1 ret)) +(defsubst fuel-eval--retort-output (ret) (nth 2 ret)) + +(defsubst fuel-eval--retort-p (ret) (listp ret)) + +(defsubst fuel-eval--error-name (err) (car err)) + +(defsubst fuel-eval--make-parse-error-retort (str) + (fuel-eval--retort-make 'parse-retort-error nil str)) + +(defun fuel-eval--parse-retort (buffer) + (save-current-buffer + (set-buffer buffer) + (condition-case nil + (read (current-buffer)) + (error (fuel-eval--make-parse-error-retort + (buffer-substring-no-properties (point) (point-max))))))) + +(defsubst fuel-eval--send/retort (str) + (fuel-eval--parse-retort (fuel-eval--send-string str))) + +(defsubst fuel-eval--eval-begin () + (fuel-eval--send/retort "fuel-begin-eval")) + +(defsubst fuel-eval--eval-end () + (fuel-eval--send/retort "fuel-begin-eval")) + +(defsubst fuel-eval--factor-array (strs) + (format "V{ %S }" (mapconcat 'identity strs " "))) + +(defsubst fuel-eval--eval-strings (strs) + (let ((str (format "%s fuel-eval" (fuel-eval--factor-array strs)))) + (fuel-eval--send/retort str))) + +(defsubst fuel-eval--eval-string (str) + (fuel-eval--eval-strings (list str))) + +(defun fuel-eval--eval-strings/context (strs) + (let ((usings (fuel-syntax--usings-update))) + (fuel-eval--send/retort + (format "%s %S %s fuel-eval-in-context" + (fuel-eval--factor-array strs) + (or fuel-syntax--current-vocab "f") + (if usings (fuel-eval--factor-array usings) "f"))))) + +(defsubst fuel-eval--eval-string/context (str) + (fuel-eval--eval-strings/context (list str))) + +(defun fuel-eval--eval-region/context (begin end) + (let ((lines (split-string (buffer-substring-no-properties begin end) + "[\f\n\r\v]+" t))) + (when (> (length lines) 0) + (fuel-eval--eval-strings/context lines)))) + + +(provide 'fuel-eval) +;;; fuel-eval.el ends here diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el new file mode 100644 index 0000000000..c8673f742b --- /dev/null +++ b/misc/fuel/fuel-font-lock.el @@ -0,0 +1,88 @@ +;;; fuel-font-lock.el -- font lock for factor code + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Wed Dec 03, 2008 21:40 + +;;; Comentary: + +;; Font lock setup for highlighting Factor code. + +;;; Code: + +(require 'fuel-base) +(require 'fuel-syntax) + +(require 'font-lock) + + +;;; Faces: + +(defmacro fuel-font-lock--face (face def doc) + (let ((face (intern (format "factor-font-lock-%s" (symbol-name face)))) + (def (intern (format "font-lock-%s-face" (symbol-name def))))) + `(defface ,face (face-default-spec ,def) + ,(format "Face for %s." doc) + :group 'factor-mode + :group 'faces))) + +(defmacro fuel-font-lock--faces-setup () + (cons 'progn + (mapcar (lambda (f) (cons 'fuel-font-lock--face f)) + '((comment comment "comments") + (constructor type "constructors ()") + (declaration keyword "declaration words") + (parsing-word keyword "parsing words") + (setter-word function-name "setter words (>>foo)") + (stack-effect comment "stack effect specifications") + (string string "strings") + (symbol variable-name "name of symbol being defined") + (type-name type "type names") + (vocabulary-name constant "vocabulary names") + (word function-name "word, generic or method being defined"))))) + +(fuel-font-lock--faces-setup) + + +;;; Font lock: + +(defconst fuel-font-lock--parsing-lock-keywords + (cons '("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word) + (mapcar (lambda (w) `(,(format "\\(^\\| \\)\\(%s\\)\\($\\| \\)" w) + 2 'factor-font-lock-parsing-word)) + fuel-syntax--parsing-words))) + +(defconst fuel-font-lock--font-lock-keywords + `(,@fuel-font-lock--parsing-lock-keywords + (,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect) + (,fuel-syntax--parsing-words-ext-regex . 'factor-font-lock-parsing-word) + (,fuel-syntax--declaration-words-regex 1 'factor-font-lock-declaration) + (,fuel-syntax--word-definition-regex 2 'factor-font-lock-word) + (,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name) + (,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name) + (2 'factor-font-lock-word)) + (,fuel-syntax--parent-type-regex 1 'factor-font-lock-type) + (,fuel-syntax--constructor-regex . 'factor-font-lock-constructor) + (,fuel-syntax--setter-regex . 'factor-font-lock-setter-word) + (,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol) + (,fuel-syntax--use-line-regex 1 'factor-font-lock-vocabulary-name)) + "Font lock keywords definition for Factor mode.") + +(defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax) + (set (make-local-variable 'comment-start) "! ") + (set (make-local-variable 'parse-sexp-lookup-properties) t) + (set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment) + (set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string) + (set (make-local-variable 'font-lock-defaults) + `(,(or keywords 'fuel-font-lock--font-lock-keywords) + nil nil nil nil + ,@(if no-syntax nil + (list (cons 'font-lock-syntactic-keywords + fuel-syntax--syntactic-keywords)))))) + + +(provide 'fuel-font-lock) +;;; fuel-font-lock.el ends here diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el new file mode 100644 index 0000000000..dcf17d2716 --- /dev/null +++ b/misc/fuel/fuel-help.el @@ -0,0 +1,208 @@ +;;; fuel-help.el -- accessing Factor's help system + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Wed Dec 03, 2008 21:41 + +;;; Comentary: + +;; Modes and functions interfacing Factor's 'see' and 'help' +;; utilities, as well as an ElDoc-based autodoc mode. + +;;; Code: + +(require 'fuel-base) +(require 'fuel-font-lock) +(require 'fuel-eval) + + +;;; Customization: + +(defgroup fuel-help nil + "Options controlling FUEL's help system" + :group 'fuel) + +(defcustom fuel-help-minibuffer-font-lock t + "Whether to use font lock for info messages in the minibuffer." + :group 'fuel-help + :type 'boolean) + +(defcustom fuel-help-always-ask t + "When enabled, always ask for confirmation in help prompts." + :type 'boolean + :group 'fuel-help) + +(defcustom fuel-help-use-minibuffer t + "When enabled, use the minibuffer for short help messages." + :type 'boolean + :group 'fuel-help) + +(defcustom fuel-help-mode-hook nil + "Hook run by `factor-help-mode'." + :type 'hook + :group 'fuel-help) + +(defface fuel-help-font-lock-headlines '((t (:bold t :weight bold))) + "Face for headlines in help buffers." + :group 'fuel-help + :group 'faces) + + +;;; Autodoc mode: + +(defvar fuel-help--font-lock-buffer + (let ((buffer (get-buffer-create " *fuel help minibuffer messages*"))) + (set-buffer buffer) + (fuel-font-lock--font-lock-setup) + buffer)) + +(defun fuel-help--font-lock-str (str) + (set-buffer fuel-help--font-lock-buffer) + (erase-buffer) + (insert str) + (let ((font-lock-verbose nil)) (font-lock-fontify-buffer)) + (buffer-string)) + +(defun fuel-help--word-synopsis (&optional word) + (let ((word (or word (fuel-syntax-symbol-at-point))) + (fuel-eval--log nil)) + (when word + (let ((ret (fuel-eval--eval-string/context + (format "\\ %s synopsis fuel-eval-set-result" word)))) + (when (not (fuel-eval--retort-error ret)) + (if fuel-help-minibuffer-font-lock + (fuel-help--font-lock-str (fuel-eval--retort-result ret)) + (fuel-eval--retort-result ret))))))) + +(make-variable-buffer-local + (defvar fuel-autodoc-mode-string " A" + "Modeline indicator for fuel-autodoc-mode")) + +(define-minor-mode fuel-autodoc-mode + "Toggle Fuel's Autodoc mode. +With no argument, this command toggles the mode. +Non-null prefix argument turns on the mode. +Null prefix argument turns off the mode. + +When Autodoc mode is enabled, a synopsis of the word at point is +displayed in the minibuffer." + :init-value nil + :lighter fuel-autodoc-mode-string + :group 'fuel + + (set (make-local-variable 'eldoc-documentation-function) + (when fuel-autodoc-mode 'fuel-help--word-synopsis)) + (set (make-local-variable 'eldoc-minor-mode-string) nil) + (eldoc-mode fuel-autodoc-mode) + (message "Fuel Autodoc %s" (if fuel-autodoc-mode "enabled" "disabled"))) + + +;;;; Factor help mode: + +(defvar fuel-help-mode-map (make-sparse-keymap) + "Keymap for Factor help mode.") + +(define-key fuel-help-mode-map [(return)] 'fuel-help) + +(defconst fuel-help--headlines + (regexp-opt '("Class description" + "Definition" + "Examples" + "Generic word contract" + "Inputs and outputs" + "Methods" + "Notes" + "Parent topics:" + "See also" + "Syntax" + "Vocabulary" + "Warning" + "Word description") + t)) + +(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines)) + +(defconst fuel-help--font-lock-keywords + `(,@fuel-font-lock--font-lock-keywords + (,fuel-help--headlines-regexp . 'fuel-help-font-lock-headlines))) + +(defun fuel-help-mode () + "Major mode for displaying Factor documentation. +\\{fuel-help-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map fuel-help-mode-map) + (setq mode-name "Factor Help") + (setq major-mode 'fuel-help-mode) + + (fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t) + + (set (make-local-variable 'view-no-disable-on-exit) t) + (view-mode) + (setq view-exit-action + (lambda (buffer) + ;; Use `with-current-buffer' to make sure that `bury-buffer' + ;; also removes BUFFER from the selected window. + (with-current-buffer buffer + (bury-buffer)))) + + (setq fuel-autodoc-mode-string "") + (fuel-autodoc-mode) + (run-mode-hooks 'fuel-help-mode-hook)) + +(defun fuel-help--help-buffer () + (with-current-buffer (get-buffer-create "*fuel-help*") + (fuel-help-mode) + (current-buffer))) + +(defvar fuel-help--history nil) + +(defun fuel-help--show-help (&optional see) + (let* ((def (fuel-syntax-symbol-at-point)) + (prompt (format "See%s help on%s: " (if see " short" "") + (if def (format " (%s)" def) ""))) + (ask (or (not (memq major-mode '(factor-mode fuel-help-mode))) + (not def) + fuel-help-always-ask)) + (def (if ask (read-string prompt nil 'fuel-help--history def) def)) + (cmd (format "\\ %s %s" def (if see "see" "help"))) + (fuel-eval--log nil) + (ret (fuel-eval--eval-string/context cmd)) + (out (fuel-eval--retort-output ret))) + (if (or (fuel-eval--retort-error ret) (empty-string-p out)) + (message "No help for '%s'" def) + (let ((hb (fuel-help--help-buffer)) + (inhibit-read-only t) + (font-lock-verbose nil)) + (set-buffer hb) + (erase-buffer) + (insert out) + (set-buffer-modified-p nil) + (pop-to-buffer hb) + (goto-char (point-min)))))) + + +;;; Interface: see/help commands + +(defun fuel-help-short (&optional arg) + "See a help summary of symbol at point. +By default, the information is shown in the minibuffer. When +called with a prefix argument, the information is displayed in a +separate help buffer." + (interactive "P") + (if (if fuel-help-use-minibuffer (not arg) arg) + (fuel-help--word-synopsis) + (fuel-help--show-help t))) + +(defun fuel-help () + "Show extended help about the symbol at point, using a help +buffer." + (interactive) + (fuel-help--show-help)) + + +(provide 'fuel-help) +;;; fuel-help.el ends here diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el new file mode 100644 index 0000000000..958c589220 --- /dev/null +++ b/misc/fuel/fuel-listener.el @@ -0,0 +1,120 @@ +;;; fuel-listener.el --- starting the fuel listener + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages + +;;; Commentary: + +;; Utilities to maintain and switch to a factor listener comint +;; buffer, with an accompanying major fuel-listener-mode. + +;;; Code: + +(require 'fuel-eval) +(require 'fuel-base) +(require 'comint) + + +;;; Customization: + +(defgroup fuel-listener nil + "Interacting with a Factor listener inside Emacs" + :group 'fuel) + +(defcustom fuel-listener-factor-binary "~/factor/factor" + "Full path to the factor executable to use when starting a listener." + :type '(file :must-match t) + :group 'fuel-listener) + +(defcustom fuel-listener-factor-image "~/factor/factor.image" + "Full path to the factor image to use when starting a listener." + :type '(file :must-match t) + :group 'fuel-listener) + +(defcustom fuel-listener-use-other-window t + "Use a window other than the current buffer's when switching to +the factor-listener buffer." + :type 'boolean + :group 'fuel-listener) + +(defcustom fuel-listener-window-allow-split t + "Allow window splitting when switching to the fuel listener +buffer." + :type 'boolean + :group 'fuel-listener) + + +;;; Fuel listener buffer/process: + +(defvar fuel-listener-buffer nil + "The buffer in which the Factor listener is running.") + +(defun fuel-listener--start-process () + (let ((factor (expand-file-name fuel-listener-factor-binary)) + (image (expand-file-name fuel-listener-factor-image))) + (unless (file-executable-p factor) + (error "Could not run factor: %s is not executable" factor)) + (unless (file-readable-p image) + (error "Could not run factor: image file %s not readable" image)) + (setq fuel-listener-buffer + (make-comint "fuel listener" factor nil "-run=fuel" (format "-i=%s" image))) + (with-current-buffer fuel-listener-buffer + (fuel-listener-mode)))) + +(defun fuel-listener--process (&optional start) + (or (and (buffer-live-p fuel-listener-buffer) + (get-buffer-process fuel-listener-buffer)) + (if (not start) + (error "No running factor listener (try M-x run-factor)") + (fuel-listener--start-process) + (fuel-listener--process)))) + +(setq fuel-eval--default-proc-function 'fuel-listener--process) + + +;;; Interface: starting fuel listener + +(defalias 'switch-to-factor 'run-factor) +(defalias 'switch-to-fuel-listener 'run-factor) +;;;###autoload +(defun run-factor (&optional arg) + "Show the fuel-listener buffer, starting the process if needed." + (interactive) + (let ((buf (process-buffer (fuel-listener--process t))) + (pop-up-windows fuel-listener-window-allow-split)) + (if fuel-listener-use-other-window + (pop-to-buffer buf) + (switch-to-buffer buf)))) + + +;;; Fuel listener mode: + +(defconst fuel-listener--prompt-regex "( [^)]* ) ") + +(defun fuel-listener--wait-for-prompt (&optional timeout) + (let ((proc (fuel-listener--process))) + (with-current-buffer fuel-listener-buffer + (goto-char comint-last-input-end) + (while (not (or (re-search-forward comint-prompt-regexp nil t) + (not (accept-process-output proc timeout)))) + (goto-char comint-last-input-end)) + (goto-char (point-max))))) + +(defun fuel-listener--startup () + (fuel-listener--wait-for-prompt) + (fuel-eval--send-string "USE: fuel") + (message "FUEL listener up and running!")) + +(define-derived-mode fuel-listener-mode comint-mode "Fuel Listener" + "Major mode for interacting with an inferior Factor listener process. +\\{fuel-listener-mode-map}" + (set (make-local-variable 'comint-prompt-regexp) + fuel-listener--prompt-regex) + (fuel-listener--startup)) + + +(provide 'fuel-listener) +;;; fuel-listener.el ends here diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el new file mode 100644 index 0000000000..5a3206698e --- /dev/null +++ b/misc/fuel/fuel-mode.el @@ -0,0 +1,106 @@ +;;; fuel-mode.el -- Minor mode enabling FUEL niceties + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Sat Dec 06, 2008 00:52 + +;;; Comentary: + +;; Enhancements to vanilla factor-mode (notably, listener interaction) +;; enabled by means of a minor mode. + +;;; Code: + +(require 'factor-mode) +(require 'fuel-base) +(require 'fuel-syntax) +(require 'fuel-font-lock) +(require 'fuel-help) +(require 'fuel-eval) +(require 'fuel-listener) + + +;;; Customization: + +(defgroup fuel-mode nil + "Mode enabling FUEL's ultimate abilities." + :group 'fuel) + +(defcustom fuel-mode-autodoc-p t + "Whether `fuel-autodoc-mode' gets enable by default in fuel buffers." + :group 'fuel-mode + :type 'boolean) + + +;;; User commands + +(defun fuel-eval-definition (&optional arg) + "Sends definition around point to Fuel's listener for evaluation. +With prefix, switchs the the listener's buffer." + (interactive "P") + (save-excursion + (mark-defun) + (let* ((begin (point)) + (end (mark))) + (unless (< begin end) (error "No evaluable definition around point")) + (let* ((msg (match-string 0)) + (ret (fuel-eval--eval-region/context begin end)) + (err (fuel-eval--retort-error ret))) + (when err (error "%s" err)) + (message "%s" (fuel--shorten-region begin end 70))))) + (when arg (pop-to-buffer fuel-listener-buffer))) + + +;;; Minor mode definition: + +(make-variable-buffer-local + (defvar fuel-mode-string " F" + "Modeline indicator for fuel-mode")) + +(defvar fuel-mode-map (make-sparse-keymap) + "Key map for fuel-mode") + +(define-minor-mode fuel-mode + "Toggle Fuel's mode. +With no argument, this command toggles the mode. +Non-null prefix argument turns on the mode. +Null prefix argument turns off the mode. + +When Fuel mode is enabled, a host of nice utilities for +interacting with a factor listener is at your disposal. +\\{fuel-mode-map}" + :init-value nil + :lighter fuel-mode-string + :group 'fuel + :keymap fuel-mode-map + + (setq fuel-autodoc-mode-string "/A") + (when fuel-mode-autodoc-p (fuel-autodoc-mode fuel-mode))) + + +;;; Keys: + +(defun fuel-mode--key-1 (k c) + (define-key fuel-mode-map (vector '(control ?c) k) c) + (define-key fuel-mode-map (vector '(control ?c) `(control ,k)) c)) + +(defun fuel-mode--key (p k c) + (define-key fuel-mode-map (vector '(control ?c) `(control ,p) k) c) + (define-key fuel-mode-map (vector '(control ?c) `(control ,p) `(control ,k)) c)) + +(fuel-mode--key-1 ?z 'run-factor) + +(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition) + +(fuel-mode--key ?e ?d 'fuel-eval-definition) + +(fuel-mode--key ?d ?a 'fuel-autodoc-mode) +(fuel-mode--key ?d ?d 'fuel-help) +(fuel-mode--key ?d ?s 'fuel-help-short) + + +(provide 'fuel-mode) +;;; fuel-mode.el ends here diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el new file mode 100644 index 0000000000..a0485f9183 --- /dev/null +++ b/misc/fuel/fuel-syntax.el @@ -0,0 +1,281 @@ +;;; fuel-syntax.el --- auxiliar definitions for factor code navigation. + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages + +;;; Commentary: + +;; Auxiliar constants and functions to parse factor code. + +;;; Code: + +(require 'thingatpt) + + +;;; Thing-at-point support for factor symbols: + +(defun fuel-syntax--beginning-of-symbol () + "Move point to the beginning of the current symbol." + (while (eq (char-before) ?:) (backward-char)) + (skip-syntax-backward "w_")) + +(defun fuel-syntax--end-of-symbol () + "Move point to the end of the current symbol." + (skip-syntax-forward "w_") + (while (looking-at ":") (forward-char))) + +(put 'factor-symbol 'end-op 'fuel-syntax--end-of-symbol) +(put 'factor-symbol 'beginning-op 'fuel-syntax--beginning-of-symbol) + +(defsubst fuel-syntax-symbol-at-point () + (let ((s (substring-no-properties (thing-at-point 'factor-symbol)))) + (and (> (length s) 0) s))) + + +;;; Regexps galore: + +(defconst fuel-syntax--parsing-words + '("{" "}" "^:" "^::" ";" "<<" ">" + "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{" + "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:" + "GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{" + "IN:" "INSTANCE:" "INTERSECTION:" + "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:" + "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:" + "REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:" + "TUPLE:" "T{" "t\\??" "TYPEDEF:" + "UNION:" "USE:" "USING:" "V{" "VARS:" "W{")) + +(defconst fuel-syntax--parsing-words-ext-regex + (regexp-opt '("B" "call-next-method" "delimiter" "f" "initial:" "read-only") + 'words)) + +(defconst fuel-syntax--declaration-words + '("flushable" "foldable" "inline" "parsing" "recursive")) + +(defconst fuel-syntax--declaration-words-regex + (regexp-opt fuel-syntax--declaration-words 'words)) + +(defsubst fuel-syntax--second-word-regex (prefixes) + (format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t))) + +(defconst fuel-syntax--method-definition-regex + "^M: +\\([^ ]+\\) +\\([^ ]+\\)") + +(defconst fuel-syntax--word-definition-regex + (fuel-syntax--second-word-regex '(":" "::" "GENERIC:"))) + +(defconst fuel-syntax--type-definition-regex + (fuel-syntax--second-word-regex '("TUPLE:" "SINGLETON:"))) + +(defconst fuel-syntax--parent-type-regex "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)") + +(defconst fuel-syntax--constructor-regex "<[^ >]+>") + +(defconst fuel-syntax--setter-regex "\\W>>[^ ]+\\b") + +(defconst fuel-syntax--symbol-definition-regex + (fuel-syntax--second-word-regex '("SYMBOL:" "VAR:"))) + +(defconst fuel-syntax--stack-effect-regex " ( .* )") + +(defconst fuel-syntax--using-lines-regex "^USING: +\\([^;]+\\);") + +(defconst fuel-syntax--use-line-regex "^USE: +\\(.*\\)$") + +(defconst fuel-syntax--current-vocab-regex "^IN: +\\([^ \r\n\f]+\\)") + +(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$") + +(defconst fuel-syntax--definition-starters-regex + (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" ":" ""))) + +(defconst fuel-syntax--definition-start-regex + (format "^\\(%s:\\) " fuel-syntax--definition-starters-regex)) + +(defconst fuel-syntax--definition-end-regex + (format "\\(\\(^\\| +\\);\\( +%s\\)*\\($\\| +\\)\\)" + fuel-syntax--declaration-words-regex)) + +(defconst fuel-syntax--single-liner-regex + (format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:" + "PRIVATE>" "" table) + + ;; Parenthesis + (modify-syntax-entry ?\[ "(] " table) + (modify-syntax-entry ?\] ")[ " table) + (modify-syntax-entry ?{ "(} " table) + (modify-syntax-entry ?} "){ " table) + + (modify-syntax-entry ?\( "()" table) + (modify-syntax-entry ?\) ")(" table) + + ;; Strings + (modify-syntax-entry ?\" "\"" table) + (modify-syntax-entry ?\\ "/" table) + table) + "Syntax table used while in Factor mode.") + +(defconst fuel-syntax--syntactic-keywords + `(("\\(#!\\)" (1 "<")) + (" \\(!\\)" (1 "<")) + ("^\\(!\\)" (1 "<")) + ("\\(!(\\) .* \\()\\)" (1 "<") (2 ">")) + ("\\([[({]\\)\\([^ \"\n]\\)" (1 "_") (2 "_")) + ("\\([^ \"\n]\\)\\([])}]\\)" (1 "_") (2 "_")))) + + +;;; Source code analysis: + +(defsubst fuel-syntax--brackets-depth () + (nth 0 (syntax-ppss))) + +(defsubst fuel-syntax--brackets-start () + (nth 1 (syntax-ppss))) + +(defun fuel-syntax--brackets-end () + (save-excursion + (goto-char (fuel-syntax--brackets-start)) + (condition-case nil + (progn (forward-sexp) + (1- (point))) + (error -1)))) + +(defsubst fuel-syntax--indentation-at (pos) + (save-excursion (goto-char pos) (current-indentation))) + +(defsubst fuel-syntax--increased-indentation (&optional i) + (+ (or i (current-indentation)) factor-indent-width)) +(defsubst fuel-syntax--decreased-indentation (&optional i) + (- (or i (current-indentation)) factor-indent-width)) + +(defsubst fuel-syntax--at-begin-of-def () + (looking-at fuel-syntax--begin-of-def-regex)) + +(defsubst fuel-syntax--at-end-of-def () + (looking-at fuel-syntax--end-of-def-regex)) + +(defsubst fuel-syntax--looking-at-emptiness () + (looking-at "^[ \t]*$")) + +(defun fuel-syntax--at-setter-line () + (save-excursion + (beginning-of-line) + (if (not (fuel-syntax--looking-at-emptiness)) + (re-search-forward fuel-syntax--setter-regex (line-end-position) t) + (forward-line -1) + (or (fuel-syntax--at-constructor-line) + (fuel-syntax--at-setter-line))))) + +(defun fuel-syntax--at-constructor-line () + (save-excursion + (beginning-of-line) + (re-search-forward fuel-syntax--constructor-regex (line-end-position) t))) + +(defsubst fuel-syntax--at-using () + (looking-at fuel-syntax--using-lines-regex)) + +(defsubst fuel-syntax--beginning-of-defun (&optional times) + (re-search-backward fuel-syntax--begin-of-def-regex nil t times)) + +(defsubst fuel-syntax--end-of-defun () + (re-search-forward fuel-syntax--end-of-def-regex nil t)) + + +;;; USING/IN: + +(make-variable-buffer-local + (defvar fuel-syntax--current-vocab nil)) + +(make-variable-buffer-local + (defvar fuel-syntax--usings nil)) + +(defun fuel-syntax--current-vocab () + (let ((ip + (save-excursion + (when (re-search-backward fuel-syntax--current-vocab-regex nil t) + (setq fuel-syntax--current-vocab (match-string-no-properties 1)) + (point))))) + (when ip + (let ((pp (save-excursion + (when (re-search-backward fuel-syntax--sub-vocab-regex ip t) + (point))))) + (when (and pp (> pp ip)) + (let ((sub (match-string-no-properties 1))) + (unless (save-excursion (search-backward (format "%s>" sub) pp t)) + (setq fuel-syntax--current-vocab + (format "%s.%s" fuel-syntax--current-vocab (downcase sub))))))))) + fuel-syntax--current-vocab) + +(defun fuel-syntax--usings-update () + (save-excursion + (setq fuel-syntax--usings (list (fuel-syntax--current-vocab))) + (while (re-search-backward fuel-syntax--using-lines-regex nil t) + (dolist (u (split-string (match-string-no-properties 1) nil t)) + (push u fuel-syntax--usings))) + fuel-syntax--usings)) + +(defsubst fuel-syntax--usings-update-hook () + (fuel-syntax--usings-update) + nil) + +(defun fuel-syntax--enable-usings () + (add-hook 'before-save-hook 'fuel-syntax--usings-update-hook nil t) + (fuel-syntax--usings-update)) + +(defsubst fuel-syntax--usings () + (or fuel-syntax--usings (fuel-syntax--usings-update))) + + +(provide 'fuel-syntax) +;;; fuel-syntax.el ends here From f48653c47a59fb78bd639807cedc67e08deaa103 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Dec 2008 23:51:34 -0600 Subject: [PATCH 02/15] Fix compile error --- basis/compiler/codegen/codegen.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 96db72c6ea..21db464079 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -451,7 +451,7 @@ M: ##alien-indirect generate-insn TUPLE: callback-context ; -: current-callback 2 getenv ; +: current-callback ( -- id ) 2 getenv ; : wait-to-return ( token -- ) dup current-callback eq? [ From 044e2867d54d3c4006b973e555c618fbaf43bac1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Dec 2008 23:51:58 -0600 Subject: [PATCH 03/15] Teach compiler about string-nth range --- .../tree/propagation/known-words/known-words.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 59e2c0b9db..c98ec24ea8 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -5,7 +5,7 @@ math.partial-dispatch math.intervals math.parser math.order layouts words sequences sequences.private arrays assocs classes classes.algebra combinators generic.math splitting fry locals classes.tuple alien.accessors classes.tuple.private slots.private -definitions +definitions strings.private stack-checker.state compiler.tree.comparisons compiler.tree.propagation.info @@ -242,6 +242,10 @@ generic-comparison-ops [ ] "custom-inlining" set-word-prop ] each +\ string-nth [ + 2drop fixnum 0 23 2^ [a,b] +] "outputs" set-word-prop + { alien-signed-1 alien-unsigned-1 From 82cf6530c61e2b30180d6309cd0dcf185a4e48fa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Dec 2008 23:52:09 -0600 Subject: [PATCH 04/15] set-string-nth-fast intrinsic was busted --- basis/cpu/x86/x86.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index d7234eb389..8dac1efed6 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -391,7 +391,7 @@ M:: x86 %string-nth ( dst src index temp -- ) ] with-small-register ; M:: x86 %set-string-nth-fast ( ch str index temp -- ) - ch { index str } [| new-ch | + ch { index str temp } [| new-ch | new-ch ch ?MOV temp str index [+] LEA temp string-offset [+] new-ch 1 small-reg MOV From 6ee523f48f512554b806f62ce4c6df41178885b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Dec 2008 23:52:47 -0600 Subject: [PATCH 05/15] Eliminate conditional branch from -fast variant of TR: map; 5% improvement on reverse-complement --- basis/tr/tr.factor | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/basis/tr/tr.factor b/basis/tr/tr.factor index 30d0efb28b..66d8df7d44 100644 --- a/basis/tr/tr.factor +++ b/basis/tr/tr.factor @@ -1,13 +1,25 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays strings sequences sequences.private -fry kernel words parser lexer assocs math.order ; +fry kernel words parser lexer assocs math math.order summary ; IN: tr +ERROR: bad-tr ; + +M: bad-tr summary + drop "TR: can only be used with ASCII characters" ; + : TR: scan parse-definition unclip-last [ unclip-last ] dip compute-tr + [ check-tr ] [ [ create-tr ] dip define-tr ] - [ [ "-fast" append create-tr ] dip define-fast-tr ] 2bi ; + [ [ "-fast" append create-tr ] dip define-fast-tr ] 2tri ; parsing From 3673a3e7c7c8da13012842b7952c54fce2c9fd67 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 5 Dec 2008 23:53:16 -0600 Subject: [PATCH 06/15] Use stack effect literals instead of in PEG, and don't use smart combinators --- basis/peg/peg.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 1fb5909bcf..8a62365f53 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -4,8 +4,7 @@ USING: kernel sequences strings fry namespaces make math assocs debugger io vectors arrays math.parser math.order vectors combinators classes sets unicode.categories compiler.units parser words quotations effects memoize accessors -locals effects splitting combinators.short-circuit -combinators.short-circuit.smart generalizations ; +locals effects splitting combinators.short-circuit generalizations ; IN: peg USE: prettyprint @@ -278,7 +277,8 @@ GENERIC: (compile) ( peg -- quot ) : parser-body ( parser -- quot ) #! Return the body of the word that is the compiled version #! of the parser. - gensym 2dup swap peg>> (compile) 0 1 define-declared swap dupd id>> "peg-id" set-word-prop + gensym 2dup swap peg>> (compile) (( -- result )) define-declared + swap dupd id>> "peg-id" set-word-prop [ execute-parser ] curry ; : preset-parser-word ( parser -- parser word ) @@ -306,7 +306,7 @@ SYMBOL: delayed #! Work through all delayed parsers and recompile their #! words to have the correct bodies. delayed get [ - call compile-parser 1quotation 0 1 define-declared + call compile-parser 1quotation (( -- result )) define-declared ] assoc-each ; : compile ( parser -- word ) @@ -421,7 +421,7 @@ M: seq-parser (compile) ( peg -- quot ) [ parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry , [ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each - ] { } make , \ && , + ] { } make , \ 1&& , ] [ ] make ; TUPLE: choice-parser parsers ; @@ -431,7 +431,7 @@ M: choice-parser (compile) ( peg -- quot ) [ parsers>> [ compile-parser ] map unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each - ] { } make , \ || , + ] { } make , \ 0|| , ] [ ] make ; TUPLE: repeat0-parser p1 ; From eb43cddb33d0eaaf279599b95cf66836a195dd5c Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 6 Dec 2008 07:01:12 +0100 Subject: [PATCH 07/15] FUEL: fuel-edit-word-at-point, fuel-eval-region, fuel-eval-extended-region. --- extra/fuel/fuel.factor | 2 ++ misc/fuel/README | 6 ++++- misc/fuel/fuel-eval.el | 2 +- misc/fuel/fuel-mode.el | 58 ++++++++++++++++++++++++++++++++++++------ 4 files changed, 58 insertions(+), 10 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 9203f0fcdd..357e7508f4 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -112,6 +112,8 @@ M: continuation fuel-pprint drop "~continuation~" write ; : fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; +: fuel-get-edit-location ( defspec -- ) + where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ] when* ; : fuel-startup ( -- ) "listener" run ; diff --git a/misc/fuel/README b/misc/fuel/README index b98a23e92a..817695f626 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -50,7 +50,11 @@ Quick key reference - C-cz : switch to listener - C-co : cycle between code, tests and docs factor files - - C-M-x, C-cC-ed : eval definition around point + - M-. : edit word at point in Emacs + + - C-C-r, C-cC-er : eval region + - C-M-r, C-cC-ee : eval region, extending it to definition boundaries + - C-M-x, C-cC-ex : eval definition around point - C-cC-da : toggle autodoc mode - C-cC-dd : help for word at point diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el index c92d8a8831..bef7171f6f 100644 --- a/misc/fuel/fuel-eval.el +++ b/misc/fuel/fuel-eval.el @@ -38,7 +38,7 @@ (when (and (> fuel-eval-log-max-length 0) (> (point) fuel-eval-log-max-length)) (erase-buffer)) - (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 75) "\n")) + (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256) "\n")) (let ((beg (point))) (comint-redirect-send-command-to-process str (current-buffer) proc nil t) (with-current-buffer (process-buffer proc) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 5a3206698e..bd9b127c7d 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -37,21 +37,56 @@ ;;; User commands +(defun fuel-eval-region (begin end &optional arg) + "Sends region to Fuel's listener for evaluation. +With prefix, switchs to the listener's buffer afterwards." + (interactive "r\nP") + (let* ((ret (fuel-eval--eval-region/context begin end)) + (err (fuel-eval--retort-error ret))) + (message "%s" (or err (fuel--shorten-region begin end 70)))) + (when arg (pop-to-buffer fuel-listener-buffer))) + +(defun fuel-eval-extended-region (begin end &optional arg) + "Sends region extended outwards to nearest definitions, +to Fuel's listener for evaluation. With prefix, switchs to the +listener's buffer afterwards." + (interactive "r\nP") + (fuel-eval-region (save-excursion (goto-char begin) (mark-defun) (point)) + (save-excursion (goto-char end) (mark-defun) (mark)))) + (defun fuel-eval-definition (&optional arg) "Sends definition around point to Fuel's listener for evaluation. -With prefix, switchs the the listener's buffer." +With prefix, switchs to the listener's buffer afterwards." (interactive "P") (save-excursion (mark-defun) (let* ((begin (point)) (end (mark))) (unless (< begin end) (error "No evaluable definition around point")) - (let* ((msg (match-string 0)) - (ret (fuel-eval--eval-region/context begin end)) - (err (fuel-eval--retort-error ret))) - (when err (error "%s" err)) - (message "%s" (fuel--shorten-region begin end 70))))) - (when arg (pop-to-buffer fuel-listener-buffer))) + (fuel-eval-region begin end)))) + +(defun fuel-edit-word-at-point (&optional arg) + "Opens a new window visiting the definition of the word at point. +With prefix, asks for the word to edit." + (interactive "P") + (let* ((word (fuel-syntax-symbol-at-point)) + (ask (or arg (not word))) + (word (if ask + (read-string nil + (format "Edit word%s: " + (if word (format " (%s)" word) "")) + word) + word))) + (let* ((ret (fuel-eval--eval-string/context + (format "\\ %s fuel-get-edit-location" word))) + (err (fuel-eval--retort-error ret)) + (loc (fuel-eval--retort-result ret))) + (when (or err (not loc) (not (listp loc)) (not (stringp (car loc)))) + (error "Couldn't find edit location for '%s'" word)) + (unless (file-readable-p (car loc)) + (error "Couldn't open '%s' for read" (car loc))) + (find-file-other-window (car loc)) + (goto-line (if (numberp (cadr loc)) (cadr loc) 1))))) ;;; Minor mode definition: @@ -94,8 +129,15 @@ interacting with a factor listener is at your disposal. (fuel-mode--key-1 ?z 'run-factor) (define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition) +(fuel-mode--key ?e ?x 'fuel-eval-definition) -(fuel-mode--key ?e ?d 'fuel-eval-definition) +(fuel-mode--key-1 ?r 'fuel-eval-region) +(fuel-mode--key ?e ?r 'fuel-eval-region) + +(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region) +(fuel-mode--key ?e ?e 'fuel-eval-extended-region) + +(define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point) (fuel-mode--key ?d ?a 'fuel-autodoc-mode) (fuel-mode--key ?d ?d 'fuel-help) From b06cfc622525db32117375f467eec9f4026b2067 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 00:12:07 -0600 Subject: [PATCH 08/15] Update ppc backend for recent string intrinsic changes --- basis/cpu/ppc/ppc.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 6b51585750..46986dc5e6 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -139,9 +139,9 @@ M:: ppc %string-nth ( dst src index temp -- ) "end" define-label temp src index ADD dst temp string-offset LBZ + 0 dst HEX: 80 CMPI + "end" get BLT temp src string-aux-offset LWZ - 0 temp \ f tag-number CMPI - "end" get BEQ temp temp index ADD temp temp index ADD temp temp byte-array-offset LHZ @@ -150,6 +150,10 @@ M:: ppc %string-nth ( dst src index temp -- ) "end" resolve-label ] with-scope ; +M:: ppc %set-string-nth-fast ( ch obj index temp -- ) + temp obj index ADD + ch temp string-offset STB ; + M: ppc %add ADD ; M: ppc %add-imm ADDI ; M: ppc %sub swap SUBF ; From c41a0cf6a226300a24c88a4ea9f1ebc81925a5d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 00:20:49 -0600 Subject: [PATCH 09/15] Add new words to tools.annotations to annotate words with timing code --- .../tools/annotations/annotations-docs.factor | 18 +++++++++++ .../annotations/annotations-tests.factor | 2 +- basis/tools/annotations/annotations.factor | 30 +++++++++++++++---- 3 files changed, 44 insertions(+), 6 deletions(-) diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor index c61b4547a9..acb6d6dd2a 100644 --- a/basis/tools/annotations/annotations-docs.factor +++ b/basis/tools/annotations/annotations-docs.factor @@ -4,9 +4,17 @@ IN: tools.annotations ARTICLE: "tools.annotations" "Word annotations" "The word annotation feature modifies word definitions to add debugging code. You can restore the old definition by calling " { $link reset } " on the word in question." +$nl +"Printing messages when a word is called or returns:" { $subsection watch } +{ $subsection watch-vars } +"Starting the walker when a word is called:" { $subsection breakpoint } { $subsection breakpoint-if } +"Timing words:" +{ $subsection reset-word-timing } +{ $subsection add-timing } +{ $subsection word-timing. } "All of the above words are implemented using a single combinator which applies a quotation to a word definition to yield a new definition:" { $subsection annotate } ; @@ -63,3 +71,13 @@ HELP: word-inputs { "seq" sequence } } { $description "Makes a sequence of the inputs to a word by counting the number of inputs in the stack effect and saving that many items from the datastack." } ; +HELP: add-timing +{ $values { "word" word } } +{ $description "Adds timing code to a word, which records its total running time, including that of words it calls, on every invocation." } +{ $see-also "tools.time" } ; + +HELP: reset-word-timing +{ $description "Resets the word timing table." } ; + +HELP: word-timing. +{ $description "Prints the word timing table." } ; diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index 1e1eccb8b5..1e766e3dec 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test tools.annotations math parser eval +USING: tools.test tools.annotations tools.time math parser eval io.streams.string kernel ; IN: tools.annotations.tests diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 9847b16bc2..e5f6af2267 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel words parser io summary quotations -sequences prettyprint continuations effects definitions -compiler.units namespaces assocs tools.walker generic -inspector fry ; +USING: accessors kernel math sorting words parser io summary +quotations sequences prettyprint continuations effects +definitions compiler.units namespaces assocs tools.walker +tools.time generic inspector fry ; IN: tools.annotations GENERIC: reset ( word -- ) @@ -20,9 +20,11 @@ M: word reset f "unannotated-def" set-word-prop ] [ drop ] if ; +ERROR: cannot-annotate-twice word ; + : annotate ( word quot -- ) over "unannotated-def" word-prop [ - "Cannot annotate a word twice" throw + over cannot-annotate-twice ] when [ over dup def>> "unannotated-def" set-word-prop @@ -82,3 +84,21 @@ M: word annotate-methods : breakpoint-if ( word quot -- ) '[ [ _ [ [ break ] when ] ] dip 3append ] annotate-methods ; + +SYMBOL: word-timing + +H{ } clone word-timing set-global + +: reset-word-timing ( -- ) + word-timing get clear-assoc ; + +: (add-timing) ( def word -- def' ) + '[ _ benchmark _ word-timing get at+ ] ; + +: add-timing ( word -- ) + dup '[ _ (add-timing) ] annotate ; + +: word-timing. ( -- ) + word-timing get + >alist [ 1000000 /f ] assoc-map sort-values + simple-table. ; From 731361d07a1bb48347e2aa970b54260eb1f9f871 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 6 Dec 2008 07:34:11 +0100 Subject: [PATCH 10/15] FUEL: Oops, fix previous patch. --- extra/fuel/fuel.factor | 2 +- misc/fuel/README | 2 +- misc/fuel/fuel-listener.el | 4 ++++ 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 357e7508f4..d8a363ca71 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays classes.tuple compiler.units continuations debugger -eval io io.streams.string kernel listener listener.private +definitions eval io io.files io.streams.string kernel listener listener.private make math namespaces parser prettyprint quotations sequences strings vectors vocabs.loader ; diff --git a/misc/fuel/README b/misc/fuel/README index 817695f626..078490abfd 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -52,7 +52,7 @@ Quick key reference - M-. : edit word at point in Emacs - - C-C-r, C-cC-er : eval region + - C-cr, C-cC-er : eval region - C-M-r, C-cC-ee : eval region, extending it to definition boundaries - C-M-x, C-cC-ex : eval definition around point diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index 958c589220..c741a77a5d 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -113,8 +113,12 @@ buffer." \\{fuel-listener-mode-map}" (set (make-local-variable 'comint-prompt-regexp) fuel-listener--prompt-regex) + (set (make-local-variable 'comint-prompt-read-only) t) (fuel-listener--startup)) +;; (define-key fuel-listener-mode-map "\C-w" 'comint-kill-region) +;; (define-key fuel-listener-mode-map "\C-k" 'comint-kill-whole-line) + (provide 'fuel-listener) ;;; fuel-listener.el ends here From 735e47fb555a48104bcaa29ef9b9e4140f10cb5d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 01:36:25 -0600 Subject: [PATCH 11/15] Oops, off by 10 --- basis/tools/annotations/annotations.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index e5f6af2267..ecf3ba0a76 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -87,7 +87,7 @@ M: word annotate-methods SYMBOL: word-timing -H{ } clone word-timing set-global +word-timing global [ H{ } clone or ] change-at : reset-word-timing ( -- ) word-timing get clear-assoc ; From d7d7f5c9586adf4f8cd392137981d2a5dfaf68fa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 03:47:10 -0600 Subject: [PATCH 12/15] Fix FUEL authors.txt --- extra/fuel/authors.txt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/fuel/authors.txt b/extra/fuel/authors.txt index 6acd9d5b04..ecfb757fd2 100644 --- a/extra/fuel/authors.txt +++ b/extra/fuel/authors.txt @@ -1,2 +1,2 @@ -Jose Antonio Ortega Ruiz -Eduardo Cavazos +Jose Antonio Ortega Ruiz +Eduardo Cavazos From e95bda8144058c374215fb7ac9ad29305f7d03c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 03:47:17 -0600 Subject: [PATCH 13/15] Fix help lint warning --- basis/tools/annotations/annotations-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor index acb6d6dd2a..c88e959b8e 100644 --- a/basis/tools/annotations/annotations-docs.factor +++ b/basis/tools/annotations/annotations-docs.factor @@ -74,7 +74,7 @@ HELP: word-inputs HELP: add-timing { $values { "word" word } } { $description "Adds timing code to a word, which records its total running time, including that of words it calls, on every invocation." } -{ $see-also "tools.time" } ; +{ $see-also "timing" "profiling" } ; HELP: reset-word-timing { $description "Resets the word timing table." } ; From a56d480aa69e74465d64fc0b37b381a24e2fa9f3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 09:16:29 -0600 Subject: [PATCH 14/15] Various optimizations leading to a 10% speedup on compiling empty EBNF parser: - open-code getenv primitive - inline tuple predicates in finalization - faster partial dispatch - faster built-in type predicates - faster tuple predicates - faster lo-tag dispatch - compile V{ } clone and H{ } clone more efficiently - add fixnum fast-path to =; avoid indirect branch if two fixnums not eq - faster >alist on hashtables --- .../cfg/alias-analysis/alias-analysis.factor | 7 +- basis/compiler/cfg/hats/hats.factor | 1 + .../cfg/instructions/instructions.factor | 2 + .../cfg/intrinsics/fixnum/fixnum.factor | 3 +- .../compiler/cfg/intrinsics/intrinsics.factor | 3 + .../compiler/cfg/intrinsics/misc/misc.factor | 16 ++++ .../cfg/intrinsics/slots/slots.factor | 3 - basis/compiler/codegen/codegen.factor | 4 + .../tree/finalization/finalization.factor | 27 ++++--- .../tree/propagation/inlining/inlining.factor | 21 +++--- .../known-words/known-words.factor | 16 +++- basis/cpu/architecture/architecture.factor | 2 + basis/cpu/x86/32/32.factor | 2 - basis/cpu/x86/64/64.factor | 3 - basis/cpu/x86/bootstrap.factor | 4 +- basis/cpu/x86/x86.factor | 14 ++-- .../partial-dispatch/partial-dispatch.factor | 74 ++++++++++--------- .../known-words/known-words.factor | 2 +- core/bootstrap/primitives.factor | 7 +- core/classes/builtin/builtin.factor | 32 +++++--- core/classes/tuple/tuple.factor | 15 ++-- core/generic/math/math.factor | 2 +- core/generic/standard/engines/tag/tag.factor | 18 +++-- core/hashtables/hashtables.factor | 2 +- core/kernel/kernel.factor | 5 +- 25 files changed, 180 insertions(+), 105 deletions(-) create mode 100644 basis/compiler/cfg/intrinsics/misc/misc.factor diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 98569d868c..90227bb5da 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math namespaces assocs hashtables sequences +USING: kernel math namespaces assocs hashtables sequences arrays accessors vectors combinators sets classes compiler.cfg compiler.cfg.registers compiler.cfg.instructions compiler.cfg.copy-prop ; @@ -194,6 +194,7 @@ M: ##slot insn-slot# slot>> constant ; M: ##slot-imm insn-slot# slot>> ; M: ##set-slot insn-slot# slot>> constant ; M: ##set-slot-imm insn-slot# slot>> ; +M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ; M: ##peek insn-object loc>> class ; M: ##replace insn-object loc>> class ; @@ -201,6 +202,7 @@ M: ##slot insn-object obj>> resolve ; M: ##slot-imm insn-object obj>> resolve ; M: ##set-slot insn-object obj>> resolve ; M: ##set-slot-imm insn-object obj>> resolve ; +M: ##alien-global insn-object drop \ ##alien-global ; : init-alias-analysis ( -- ) H{ } clone histories set @@ -224,6 +226,9 @@ M: ##load-immediate analyze-aliases* M: ##load-indirect analyze-aliases* dup dst>> set-heap-ac ; +M: ##alien-global analyze-aliases* + dup dst>> set-heap-ac ; + M: ##allot analyze-aliases* #! A freshly allocated object is distinct from any other #! object. diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 4b98ccb0ae..ca793de1b7 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -65,6 +65,7 @@ IN: compiler.cfg.hats : ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline : ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline : ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline +: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline : ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline : ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline : ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 2e7e044739..b34e5f8232 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -161,6 +161,8 @@ INSN: ##set-alien-double < ##alien-setter ; INSN: ##allot < ##flushable size class { temp vreg } ; INSN: ##write-barrier < ##effect card# table ; +INSN: ##alien-global < ##read symbol library ; + ! FFI INSN: ##alien-invoke params ; INSN: ##alien-indirect params ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 68ee7489f8..69cd5e5669 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -12,8 +12,7 @@ compiler.cfg.registers ; IN: compiler.cfg.intrinsics.fixnum : emit-both-fixnums? ( -- ) - D 0 ^^peek - D 1 ^^peek + 2inputs ^^or tag-mask get ^^and-imm 0 cc= ^^compare-imm diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index cfc04fa036..41f4bf47a5 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -9,6 +9,7 @@ compiler.cfg.intrinsics.allot compiler.cfg.intrinsics.fixnum compiler.cfg.intrinsics.float compiler.cfg.intrinsics.slots +compiler.cfg.intrinsics.misc compiler.cfg.iterator ; QUALIFIED: kernel QUALIFIED: arrays @@ -23,6 +24,7 @@ IN: compiler.cfg.intrinsics { kernel.private:tag + kernel.private:getenv math.private:both-fixnums? math.private:fixnum+ math.private:fixnum- @@ -94,6 +96,7 @@ IN: compiler.cfg.intrinsics : emit-intrinsic ( node word -- node/f ) { { \ kernel.private:tag [ drop emit-tag iterate-next ] } + { \ kernel.private:getenv [ emit-getenv iterate-next ] } { \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] } { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] } { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] } diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor new file mode 100644 index 0000000000..f9f2182a4e --- /dev/null +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces layouts sequences kernel +accessors compiler.tree.propagation.info +compiler.cfg.stacks compiler.cfg.hats +compiler.cfg.instructions compiler.cfg.utilities ; +IN: compiler.cfg.intrinsics.misc + +: emit-tag ( -- ) + ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; + +: emit-getenv ( node -- ) + "userenv" f ^^alien-global + swap node-input-infos first literal>> + [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if* + ds-push ; diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index 60ae1d2d0a..bc46e6149c 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -6,9 +6,6 @@ compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions compiler.cfg.utilities ; IN: compiler.cfg.intrinsics.slots -: emit-tag ( -- ) - ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; - : value-tag ( info -- n ) class>> class-tag ; inline : (emit-slot) ( infos -- dst ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 21db464079..fe3da93130 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -236,6 +236,10 @@ M: _gc generate-insn drop %gc ; M: ##loop-entry generate-insn drop %loop-entry ; +M: ##alien-global generate-insn + [ dst>> register ] [ symbol>> ] [ library>> ] tri + %alien-global ; + ! ##alien-invoke GENERIC: reg-size ( register-class -- n ) diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index 16a27e020a..ecd5429baf 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences words memoize classes.builtin +USING: kernel accessors sequences words memoize combinators +classes classes.builtin classes.tuple math.partial-dispatch fry assocs compiler.tree compiler.tree.combinators @@ -12,7 +13,7 @@ IN: compiler.tree.finalization ! See the comment in compiler.tree.late-optimizations. ! This pass runs after propagation, so that it can expand -! built-in type predicates; these cannot be expanded before +! type predicates; these cannot be expanded before ! propagation since we need to see 'fixnum?' instead of ! 'tag 0 eq?' and so on, for semantic reasoning. @@ -33,16 +34,24 @@ M: #shuffle finalize* [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ] bi and [ drop f ] when ; -: builtin-predicate? ( #call -- ? ) - word>> "predicating" word-prop builtin-class? ; - -MEMO: builtin-predicate-expansion ( word -- nodes ) +MEMO: cached-expansion ( word -- nodes ) def>> splice-final ; -: expand-builtin-predicate ( #call -- nodes ) - word>> builtin-predicate-expansion ; +GENERIC: finalize-word ( #call word -- nodes ) + +M: predicate finalize-word + "predicating" word-prop { + { [ dup builtin-class? ] [ drop word>> cached-expansion ] } + { [ dup tuple-class? ] [ drop word>> def>> splice-final ] } + [ drop ] + } cond ; + +! M: math-partial finalize-word +! dup primitive? [ drop ] [ nip cached-expansion ] if ; + +M: word finalize-word drop ; M: #call finalize* - dup builtin-predicate? [ expand-builtin-predicate ] when ; + dup word>> finalize-word ; M: node finalize* ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 87a908041e..0e3b8431a6 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -193,13 +193,14 @@ SYMBOL: history #! of bounds value. This case comes up if a parsing word #! calls the compiler at parse time (doing so is #! discouraged, but it should still work.) - { - { [ dup deferred? ] [ 2drop f ] } - { [ dup custom-inlining? ] [ inline-custom ] } - { [ dup \ instance? eq? ] [ inline-instance-check ] } - { [ dup always-inline-word? ] [ inline-word ] } - { [ dup standard-generic? ] [ inline-standard-method ] } - { [ dup math-generic? ] [ inline-math-method ] } - { [ dup method-body? ] [ inline-method-body ] } - [ 2drop f ] - } cond ; + dup custom-inlining? [ 2dup inline-custom ] [ f ] if [ 2drop f ] [ + { + { [ dup deferred? ] [ 2drop f ] } + { [ dup \ instance? eq? ] [ inline-instance-check ] } + { [ dup always-inline-word? ] [ inline-word ] } + { [ dup standard-generic? ] [ inline-standard-method ] } + { [ dup math-generic? ] [ inline-math-method ] } + { [ dup method-body? ] [ inline-method-body ] } + [ 2drop f ] + } cond + ] if ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index c98ec24ea8..8242311287 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -5,7 +5,7 @@ math.partial-dispatch math.intervals math.parser math.order layouts words sequences sequences.private arrays assocs classes classes.algebra combinators generic.math splitting fry locals classes.tuple alien.accessors classes.tuple.private slots.private -definitions strings.private +definitions strings.private vectors hashtables stack-checker.state compiler.tree.comparisons compiler.tree.propagation.info @@ -194,6 +194,11 @@ generic-comparison-ops [ 2bi and maybe-or-never ] "outputs" set-word-prop +\ both-fixnums? [ + [ class>> fixnum classes-intersect? not ] either? + f object-info ? +] "outputs" set-word-prop + { { >fixnum fixnum } { bignum>fixnum fixnum } @@ -287,6 +292,15 @@ generic-comparison-ops [ "outputs" set-word-prop ] each +! Generate more efficient code for common idiom +\ clone [ + in-d>> first value-info literal>> { + { V{ } [ [ drop { } 0 vector boa ] ] } + { H{ } [ [ drop hashtable new ] ] } + [ drop f ] + } case +] "custom-inlining" set-word-prop + \ slot [ dup literal?>> [ literal>> swap value-info-slot ] [ 2drop object-info ] if diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index eb93a8dbb5..836385574d 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -120,6 +120,8 @@ HOOK: %set-alien-cell cpu ( ptr value -- ) HOOK: %set-alien-float cpu ( ptr value -- ) HOOK: %set-alien-double cpu ( ptr value -- ) +HOOK: %alien-global cpu ( dst symbol library -- ) + HOOK: %allot cpu ( dst size class temp -- ) HOOK: %write-barrier cpu ( src card# table -- ) HOOK: %gc cpu ( -- ) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 3df072208d..5e06e72118 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -44,8 +44,6 @@ M: x86.32 param-reg-2 EDX ; M: x86.32 reserved-area-size 0 ; -M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ; - M: x86.32 %alien-invoke (CALL) rel-dlsym ; M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 6472ec0edf..2077f51e0a 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -158,9 +158,6 @@ M: x86.64 %prepare-box-struct ( -- ) M: x86.64 %prepare-var-args RAX RAX XOR ; -M: x86.64 %alien-global - [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ; - M: x86.64 %alien-invoke R11 0 MOV rc-absolute-cell rel-dlsym diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 42df1c8437..597a2c9d31 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -381,8 +381,8 @@ big-endian off [ arg0 ds-reg [] MOV - arg0 ds-reg bootstrap-cell neg [+] OR - ds-reg bootstrap-cell ADD + ds-reg bootstrap-cell SUB + arg0 ds-reg [] OR arg0 tag-mask get AND arg0 \ f tag-number MOV arg1 1 tag-fixnum MOV diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 8dac1efed6..c477e98aa7 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -458,19 +458,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- ) dst class store-tagged nursery-ptr size inc-allot-ptr ; -HOOK: %alien-global cpu ( symbol dll register -- ) - M:: x86 %write-barrier ( src card# table -- ) #! Mark the card pointed to by vreg. ! Mark the card card# src MOV card# card-bits SHR - "cards_offset" f table %alien-global + table "cards_offset" f %alien-global + table table [] MOV table card# [+] card-mark MOV ! Mark the card deck card# deck-bits card-bits - SHR - "decks_offset" f table %alien-global + table "decks_offset" f %alien-global + table table [] MOV table card# [+] card-mark MOV ; M: x86 %gc ( -- ) @@ -485,6 +485,9 @@ M: x86 %gc ( -- ) "minor_gc" f %alien-invoke "end" resolve-label ; +M: x86 %alien-global + [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ; + HOOK: stack-reg cpu ( -- reg ) : decr-stack-reg ( n -- ) @@ -595,7 +598,8 @@ M: x86 %prepare-alien-invoke #! Save Factor stack pointers in case the C code calls a #! callback which does a GC, which must reliably trace #! all roots. - "stack_chain" f temp-reg-1 %alien-global + temp-reg-1 "stack_chain" f %alien-global + temp-reg-1 temp-reg-1 [] MOV temp-reg-1 [] stack-reg MOV temp-reg-1 [] cell SUB temp-reg-1 2 cells [+] ds-reg MOV diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 56da09ccdd..bfa127e7e0 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -3,7 +3,7 @@ USING: accessors kernel kernel.private math math.private words sequences parser namespaces make assocs quotations arrays locals generic generic.math hashtables effects compiler.units -classes.algebra ; +classes.algebra fry combinators ; IN: math.partial-dispatch PREDICATE: math-partial < word @@ -45,60 +45,62 @@ M: word integer-op-input-classes { bitnot fixnum-bitnot } } at swap or ; -:: fixnum-integer-op ( a b fix-word big-word -- c ) - b tag 0 eq? [ - a b fix-word execute - ] [ - a fixnum>bignum b big-word execute - ] if ; inline - -:: integer-fixnum-op ( a b fix-word big-word -- c ) - a tag 0 eq? [ - a b fix-word execute - ] [ - a b fixnum>bignum big-word execute - ] if ; inline - -:: integer-integer-op ( a b fix-word big-word -- c ) - b tag 0 eq? [ - a b fix-word big-word integer-fixnum-op - ] [ - a dup tag 0 eq? [ fixnum>bignum ] when - b big-word execute - ] if ; inline - -: integer-op-combinator ( triple -- word ) +:: integer-fixnum-op-quot ( fix-word big-word -- quot ) [ - [ second name>> % "-" % ] - [ third name>> % "-op" % ] - bi - ] "" make "math.partial-dispatch" lookup ; + [ over fixnum? ] % + fix-word '[ _ execute ] , + big-word '[ fixnum>bignum _ execute ] , + \ if , + ] [ ] make ; + +:: fixnum-integer-op-quot ( fix-word big-word -- quot ) + [ + [ dup fixnum? ] % + fix-word '[ _ execute ] , + big-word '[ [ fixnum>bignum ] dip _ execute ] , + \ if , + ] [ ] make ; + +:: integer-integer-op-quot ( fix-word big-word -- quot ) + [ + [ dup fixnum? ] % + fix-word big-word integer-fixnum-op-quot , + [ + [ over fixnum? [ [ fixnum>bignum ] dip ] when ] % + big-word , + ] [ ] make , + \ if , + ] [ ] make ; : integer-op-word ( triple -- word ) [ name>> ] map "-" join "math.partial-dispatch" create ; -: integer-op-quot ( triple fix-word big-word -- quot ) - rot integer-op-combinator 1quotation 2curry ; +: integer-op-quot ( fix-word big-word triple -- quot ) + [ second ] [ third ] bi 2array { + { { fixnum integer } [ fixnum-integer-op-quot ] } + { { integer fixnum } [ integer-fixnum-op-quot ] } + { { integer integer } [ integer-integer-op-quot ] } + } case ; -: define-integer-op-word ( triple fix-word big-word -- ) +: define-integer-op-word ( fix-word big-word triple -- ) [ - [ 2drop integer-op-word ] [ integer-op-quot ] 3bi + [ 2nip integer-op-word ] [ integer-op-quot ] 3bi (( x y -- z )) define-declared ] [ - 2drop + 2nip [ integer-op-word ] keep "derived-from" set-word-prop ] 3bi ; : define-integer-op-words ( triples fix-word big-word -- ) - [ define-integer-op-word ] 2curry each ; + '[ [ _ _ ] dip define-integer-op-word ] each ; : integer-op-triples ( word -- triples ) { { fixnum integer } { integer fixnum } { integer integer } - } swap [ prefix ] curry map ; + } swap '[ _ prefix ] map ; : define-integer-ops ( word fix-word big-word -- ) [ @@ -138,7 +140,7 @@ SYMBOL: fast-math-ops [ drop math-class-max swap specific-method >boolean ] if ; : (derived-ops) ( word assoc -- words ) - swap [ rot first eq? nip ] curry assoc-filter ; + swap '[ swap first _ eq? nip ] assoc-filter ; : derived-ops ( word -- words ) [ 1array ] [ math-ops get (derived-ops) values ] bi append ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 2cb3d1f006..94a434f31b 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -307,7 +307,7 @@ M: object infer-call* \ { real real } { complex } define-primitive \ make-foldable -\ both-fixnums? { object object } { object object object } define-primitive +\ both-fixnums? { object object } { object } define-primitive \ fixnum+ { fixnum fixnum } { integer } define-primitive \ fixnum+ make-foldable diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 0a7e5fe233..f90ba23999 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -109,9 +109,6 @@ bootstrapping? on } [ create-vocab drop ] each ! Builtin classes -: define-builtin-predicate ( class -- ) - dup class>type [ builtin-instance? ] curry define-predicate ; - : lookup-type-number ( word -- n ) global [ target-word ] bind type-number ; @@ -192,6 +189,10 @@ define-union-class ] [ ] make define-predicate-class +"array-capacity" "sequences.private" lookup +[ >fixnum ] bootstrap-max-array-capacity [ fixnum-bitand ] curry append +"coercer" set-word-prop + ! Catch-all class for providing a default method. "object" "kernel" create [ f f { } intersection-class define-class ] diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index ee687c2939..0e4a3b56fd 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors classes classes.algebra words kernel kernel.private namespaces sequences math math.private -combinators assocs ; +combinators assocs quotations ; IN: classes.builtin SYMBOL: builtins @@ -10,10 +10,14 @@ SYMBOL: builtins PREDICATE: builtin-class < class "metaclass" word-prop builtin-class eq? ; -: type>class ( n -- class ) builtins get-global nth ; - : class>type ( class -- n ) "type" word-prop ; foldable +PREDICATE: lo-tag-class < builtin-class class>type 7 <= ; + +PREDICATE: hi-tag-class < builtin-class class>type 7 > ; + +: type>class ( n -- class ) builtins get-global nth ; + : bootstrap-type>class ( n -- class ) builtins get nth ; M: hi-tag class hi-tag type>class ; @@ -22,16 +26,20 @@ M: object class tag type>class ; M: builtin-class rank-class drop 0 ; -: builtin-instance? ( object n -- ? ) - #! 7 == tag-mask get - #! 3 == hi-tag tag-number - dup 7 fixnum<= [ swap tag eq? ] [ - swap dup tag 3 eq? - [ hi-tag eq? ] [ 2drop f ] if - ] if ; inline +GENERIC: define-builtin-predicate ( class -- ) -M: builtin-class instance? - class>type builtin-instance? ; +M: lo-tag-class define-builtin-predicate + dup class>type [ eq? ] curry [ tag ] prepend define-predicate ; + +M: hi-tag-class define-builtin-predicate + dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation + [ dup tag 3 eq? ] [ [ drop f ] if ] surround + define-predicate ; + +M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ; + +M: hi-tag-class instance? + over tag 3 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ; M: builtin-class (flatten-class) dup set ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 6f8021f733..9d748d665d 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -90,10 +90,10 @@ ERROR: bad-superclass class ; 2drop f ] if ; inline -: tuple-instance-1? ( object class -- ? ) - swap dup tuple? [ - layout-of 7 slot eq? - ] [ 2drop f ] if ; inline +: tuple-predicate-quot/1 ( class -- quot ) + #! Fast path for tuples with no superclass + [ ] curry [ layout-of 7 slot ] [ eq? ] surround 1quotation + [ dup tuple? ] [ [ drop f ] if ] surround ; : tuple-instance? ( object class offset -- ? ) rot dup tuple? [ @@ -105,13 +105,16 @@ ERROR: bad-superclass class ; : layout-class-offset ( echelon -- n ) 2 * 5 + ; +: tuple-predicate-quot ( class echelon -- quot ) + layout-class-offset [ tuple-instance? ] 2curry ; + : echelon-of ( class -- n ) tuple-layout third ; : define-tuple-predicate ( class -- ) dup dup echelon-of { - { 1 [ [ tuple-instance-1? ] curry ] } - [ layout-class-offset [ tuple-instance? ] 2curry ] + { 1 [ tuple-predicate-quot/1 ] } + [ tuple-predicate-quot ] } case define-predicate ; : class-size ( class -- n ) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 0acbdac8f8..63043b50b9 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -83,7 +83,7 @@ M: math-combination perform-combination drop dup [ - \ both-fixnums? , + [ 2dup both-fixnums? ] % dup fixnum bootstrap-word dup math-method , \ over [ dup math-class? [ diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index dbdc6e0742..5ed33009c0 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -3,7 +3,7 @@ USING: classes.private generic.standard.engines namespaces make arrays assocs sequences.private quotations kernel.private math slots.private math.private kernel accessors words -layouts sorting sequences ; +layouts sorting sequences combinators ; IN: generic.standard.engines.tag TUPLE: lo-tag-dispatch-engine methods ; @@ -24,15 +24,21 @@ C: lo-tag-dispatch-engine : sort-tags ( assoc -- alist ) >alist sort-keys reverse ; +: tag-dispatch-test ( tag# -- quot ) + picker [ tag ] append swap [ eq? ] curry append ; + +: tag-dispatch-quot ( alist -- quot ) + [ default get ] dip + [ [ tag-dispatch-test ] dip ] assoc-map + alist>quot ; + M: lo-tag-dispatch-engine engine>quot methods>> engines>quots* [ [ lo-tag-number ] dip ] assoc-map [ - picker % [ tag ] % [ - sort-tags linear-dispatch-quot - ] [ - num-tags get direct-dispatch-quot - ] if-small? % + [ sort-tags tag-dispatch-quot ] + [ picker % [ tag ] % num-tags get direct-dispatch-quot ] + if-small? % ] [ ] make ; TUPLE: hi-tag-dispatch-engine methods ; diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 474cf4c9d6..a52ac65d18 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -133,7 +133,7 @@ M: hashtable set-at ( value key hash -- ) : push-unsafe ( elt seq -- ) [ length ] keep [ underlying>> set-array-nth ] - [ [ 1+ ] dip (>>length) ] + [ [ 1 fixnum+fast { array-capacity } declare ] dip (>>length) ] 2bi ; inline PRIVATE> diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 98dc0e50fa..564600d322 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -154,8 +154,11 @@ TUPLE: identity-tuple ; M: identity-tuple equal? 2drop f ; +USE: math.private : = ( obj1 obj2 -- ? ) - 2dup eq? [ 2drop t ] [ equal? ] if ; inline + 2dup eq? [ 2drop t ] [ + 2dup both-fixnums? [ 2drop f ] [ equal? ] if + ] if ; inline GENERIC: clone ( obj -- cloned ) From 145b635eb60a265cf10cc6b88326108e95165e44 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 11:17:19 -0600 Subject: [PATCH 15/15] More optimization intended to reduce compile time. Another 10% speedup on compiling empty PEG parser - new map-flat combinator replaces usages of 'map flatten' in compiler - compiler.tree.def-use.simplified uses an explicit accumulator instead of flatten - compiler.tree.tuple-unboxing uses an explicit accumulator instead of flatten - fix inlining regression from last time: custom inlining results would sometimes be discarded - compiler.tree's 3each and 3map combinators rewritten to not use flip - rewrite math.partial-dispatch without locals (purely stylistic, no performance increase) - hand-optimize flip for common arrays-of-arrays case - don't run escape analysis and tuple unboxing if there are no allocations in the IR --- basis/bootstrap/compiler/compiler.factor | 2 +- .../cfg/two-operand/two-operand.factor | 4 +-- basis/compiler/tree/cleanup/cleanup.factor | 5 +-- .../tree/combinators/combinators.factor | 13 +++---- .../tree/dead-code/liveness/liveness.factor | 4 +-- .../tree/def-use/simplified/simplified.factor | 20 +++++------ .../escape-analysis/branches/branches.factor | 2 +- .../tree/escape-analysis/check/check.factor | 23 ++++++++++++ .../tree/normalization/normalization.factor | 7 ++-- .../compiler/tree/optimizer/optimizer.factor | 7 ++-- .../tree/propagation/branches/branches.factor | 7 ++-- .../tree/propagation/copy/copy.factor | 2 +- .../tree/propagation/inlining/inlining.factor | 29 ++++++++------- .../tree/propagation/propagation-tests.factor | 7 +++- .../tree/tuple-unboxing/tuple-unboxing.factor | 16 ++++++--- basis/compiler/utilities/utilities.factor | 31 ++++++++++++++++ .../partial-dispatch/partial-dispatch.factor | 20 +++++------ core/sequences/sequences.factor | 35 +++++++++++++++---- 18 files changed, 164 insertions(+), 70 deletions(-) create mode 100644 basis/compiler/tree/escape-analysis/check/check.factor create mode 100644 basis/compiler/utilities/utilities.factor diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index dabdeea741..9968af4330 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -60,7 +60,7 @@ nl "." write flush { - new-sequence nth push pop peek + new-sequence nth push pop peek flip } compile-uncompiled "." write flush diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index e943fb4828..dabecaeec4 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel sequences sequences.deep +USING: accessors arrays kernel sequences compiler.utilities compiler.cfg.instructions cpu.architecture ; IN: compiler.cfg.two-operand @@ -55,6 +55,6 @@ M: insn convert-two-operand* ; : convert-two-operand ( mr -- mr' ) [ two-operand? [ - [ convert-two-operand* ] map flatten + [ convert-two-operand* ] map-flat ] when ] change-instructions ; diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index becac01cd5..1b0343faa9 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences sequences.deep combinators fry +USING: kernel accessors sequences combinators fry classes.algebra namespaces assocs words math math.private math.partial-dispatch math.intervals classes classes.tuple classes.tuple.private layouts definitions stack-checker.state stack-checker.branches +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -33,7 +34,7 @@ GENERIC: cleanup* ( node -- node/nodes ) : cleanup ( nodes -- nodes' ) #! We don't recurse into children here, instead the methods #! do it since the logic is a bit more involved - [ cleanup* ] map flatten ; + [ cleanup* ] map-flat ; : cleanup-folding? ( #call -- ? ) node-output-infos diff --git a/basis/compiler/tree/combinators/combinators.factor b/basis/compiler/tree/combinators/combinators.factor index 40bbf81a03..030df8484f 100644 --- a/basis/compiler/tree/combinators/combinators.factor +++ b/basis/compiler/tree/combinators/combinators.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs fry kernel accessors sequences sequences.deep arrays -stack-checker.inlining namespaces compiler.tree ; +USING: assocs fry kernel accessors sequences compiler.utilities +arrays stack-checker.inlining namespaces compiler.tree +math.order ; IN: compiler.tree.combinators : each-node ( nodes quot: ( node -- ) -- ) @@ -27,7 +28,7 @@ IN: compiler.tree.combinators [ _ map-nodes ] change-child ] when ] if - ] map flatten ; inline recursive + ] map-flat ; inline recursive : contains-node? ( nodes quot: ( node -- ? ) -- ? ) dup dup '[ @@ -48,12 +49,6 @@ IN: compiler.tree.combinators : sift-children ( seq flags -- seq' ) zip [ nip ] assoc-filter keys ; -: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline - -: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline - -: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline - : until-fixed-point ( #recursive quot: ( node -- ) -- ) over label>> t >>fixed-point drop [ with-scope ] 2keep diff --git a/basis/compiler/tree/dead-code/liveness/liveness.factor b/basis/compiler/tree/dead-code/liveness/liveness.factor index 44b71935c8..9ece5d340b 100644 --- a/basis/compiler/tree/dead-code/liveness/liveness.factor +++ b/basis/compiler/tree/dead-code/liveness/liveness.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors namespaces assocs deques search-deques -dlists kernel sequences sequences.deep words sets +dlists kernel sequences compiler.utilities words sets stack-checker.branches compiler.tree compiler.tree.def-use compiler.tree.combinators ; IN: compiler.tree.dead-code.liveness @@ -49,4 +49,4 @@ GENERIC: remove-dead-code* ( node -- node' ) M: node remove-dead-code* ; : (remove-dead-code) ( nodes -- nodes' ) - [ remove-dead-code* ] map flatten ; + [ remove-dead-code* ] map-flat ; diff --git a/basis/compiler/tree/def-use/simplified/simplified.factor b/basis/compiler/tree/def-use/simplified/simplified.factor index edfe633057..9b2a2038da 100644 --- a/basis/compiler/tree/def-use/simplified/simplified.factor +++ b/basis/compiler/tree/def-use/simplified/simplified.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences sequences.deep kernel +USING: sequences kernel fry vectors compiler.tree compiler.tree.def-use ; IN: compiler.tree.def-use.simplified @@ -9,8 +9,6 @@ IN: compiler.tree.def-use.simplified ! A 'real' usage is a usage of a value that is not a #renaming. TUPLE: real-usage value node ; -GENERIC: actually-used-by* ( value node -- real-usages ) - ! Def GENERIC: actually-defined-by* ( value node -- real-usage ) @@ -25,16 +23,18 @@ M: #return-recursive actually-defined-by* real-usage boa ; M: node actually-defined-by* real-usage boa ; ! Use -: (actually-used-by) ( value -- real-usages ) - dup used-by [ actually-used-by* ] with map ; +GENERIC# actually-used-by* 1 ( value node accum -- ) + +: (actually-used-by) ( value accum -- ) + [ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ; M: #renaming actually-used-by* - inputs/outputs [ indices ] dip nths - [ (actually-used-by) ] map ; + [ inputs/outputs [ indices ] dip nths ] dip + '[ _ (actually-used-by) ] each ; -M: #return-recursive actually-used-by* real-usage boa ; +M: #return-recursive actually-used-by* [ real-usage boa ] dip push ; -M: node actually-used-by* real-usage boa ; +M: node actually-used-by* [ real-usage boa ] dip push ; : actually-used-by ( value -- real-usages ) - (actually-used-by) flatten ; + 10 [ (actually-used-by) ] keep ; diff --git a/basis/compiler/tree/escape-analysis/branches/branches.factor b/basis/compiler/tree/escape-analysis/branches/branches.factor index b728e9a1ba..2eee3e698b 100644 --- a/basis/compiler/tree/escape-analysis/branches/branches.factor +++ b/basis/compiler/tree/escape-analysis/branches/branches.factor @@ -33,4 +33,4 @@ M: #branch escape-analysis* 2bi ; M: #phi escape-analysis* - [ phi-in-d>> ] [ out-d>> ] bi merge-allocations ; + [ phi-in-d>> flip ] [ out-d>> ] bi merge-allocations ; diff --git a/basis/compiler/tree/escape-analysis/check/check.factor b/basis/compiler/tree/escape-analysis/check/check.factor new file mode 100644 index 0000000000..333b3fa636 --- /dev/null +++ b/basis/compiler/tree/escape-analysis/check/check.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: classes classes.tuple math math.private accessors +combinators kernel compiler.tree compiler.tree.combinators +compiler.tree.propagation.info ; +IN: compiler.tree.escape-analysis.check + +GENERIC: run-escape-analysis* ( node -- ? ) + +M: #push run-escape-analysis* + literal>> [ class immutable-tuple-class? ] [ complex? ] bi or ; + +M: #call run-escape-analysis* + { + { [ dup word>> \ eq? ] [ t ] } + { [ dup immutable-tuple-boa? ] [ t ] } + [ f ] + } cond nip ; + +M: node run-escape-analysis* drop f ; + +: run-escape-analysis? ( nodes -- ? ) + [ run-escape-analysis* ] contains-node? ; diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index bebe2e91b6..8c13de296a 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry namespaces sequences math accessors kernel arrays -combinators sequences.deep assocs +combinators compiler.utilities assocs stack-checker.backend stack-checker.branches stack-checker.inlining +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.normalization.introductions @@ -46,7 +47,7 @@ M: #branch normalize* [ [ [ - [ normalize* ] map flatten + [ normalize* ] map-flat introduction-stack get 2array ] with-scope @@ -70,7 +71,7 @@ M: #phi normalize* : (normalize) ( nodes introductions -- nodes ) introduction-stack [ - [ normalize* ] map flatten + [ normalize* ] map-flat ] with-variable ; M: #recursive normalize* diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index e37323a2ec..54c6c2c117 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -6,6 +6,7 @@ compiler.tree.normalization compiler.tree.propagation compiler.tree.cleanup compiler.tree.escape-analysis +compiler.tree.escape-analysis.check compiler.tree.tuple-unboxing compiler.tree.identities compiler.tree.def-use @@ -22,8 +23,10 @@ SYMBOL: check-optimizer? normalize propagate cleanup - escape-analysis - unbox-tuples + dup run-escape-analysis? [ + escape-analysis + unbox-tuples + ] when apply-identities compute-def-use remove-dead-code diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor index 424cd8a01c..f2613022fc 100644 --- a/basis/compiler/tree/propagation/branches/branches.factor +++ b/basis/compiler/tree/propagation/branches/branches.factor @@ -3,6 +3,7 @@ USING: fry kernel sequences assocs accessors namespaces math.intervals arrays classes.algebra combinators columns stack-checker.branches +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -78,7 +79,7 @@ SYMBOL: condition-value M: #phi propagate-before ( #phi -- ) [ annotate-phi-inputs ] - [ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ] + [ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ] bi ; : branch-phi-constraints ( output values booleans -- ) @@ -137,8 +138,8 @@ M: #phi propagate-before ( #phi -- ) M: #phi propagate-after ( #phi -- ) condition-value get [ [ out-d>> ] - [ phi-in-d>> ] - [ phi-info-d>> ] tri + [ phi-in-d>> flip ] + [ phi-info-d>> flip ] tri [ [ possible-boolean-values ] map branch-phi-constraints diff --git a/basis/compiler/tree/propagation/copy/copy.factor b/basis/compiler/tree/propagation/copy/copy.factor index 2452aba4aa..53b7d17326 100644 --- a/basis/compiler/tree/propagation/copy/copy.factor +++ b/basis/compiler/tree/propagation/copy/copy.factor @@ -49,7 +49,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ; ] 2each ; M: #phi compute-copy-equiv* - [ phi-in-d>> ] [ out-d>> ] bi compute-phi-equiv ; + [ phi-in-d>> flip ] [ out-d>> ] bi compute-phi-equiv ; M: node compute-copy-equiv* drop ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 0e3b8431a6..fcc3b01dc0 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -184,7 +184,7 @@ SYMBOL: history over in-d>> second value-info literal>> dup class? [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ; -: do-inlining ( #call word -- ? ) +: (do-inlining) ( #call word -- ? ) #! If the generic was defined in an outer compilation unit, #! then it doesn't have a definition yet; the definition #! is built at the end of the compilation unit. We do not @@ -193,14 +193,19 @@ SYMBOL: history #! of bounds value. This case comes up if a parsing word #! calls the compiler at parse time (doing so is #! discouraged, but it should still work.) - dup custom-inlining? [ 2dup inline-custom ] [ f ] if [ 2drop f ] [ - { - { [ dup deferred? ] [ 2drop f ] } - { [ dup \ instance? eq? ] [ inline-instance-check ] } - { [ dup always-inline-word? ] [ inline-word ] } - { [ dup standard-generic? ] [ inline-standard-method ] } - { [ dup math-generic? ] [ inline-math-method ] } - { [ dup method-body? ] [ inline-method-body ] } - [ 2drop f ] - } cond - ] if ; + { + { [ dup deferred? ] [ 2drop f ] } + { [ dup \ instance? eq? ] [ inline-instance-check ] } + { [ dup always-inline-word? ] [ inline-word ] } + { [ dup standard-generic? ] [ inline-standard-method ] } + { [ dup math-generic? ] [ inline-math-method ] } + { [ dup method-body? ] [ inline-method-body ] } + [ 2drop f ] + } cond ; + +: do-inlining ( #call word -- ? ) + #! Note the logic here: if there's a custom inlining hook, + #! it is permitted to return f, which means that we try the + #! normal inlining heuristic. + dup custom-inlining? [ 2dup inline-custom ] [ f ] if + [ 2drop t ] [ (do-inlining) ] if ; diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 2c4769abe0..aa04b58de7 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -8,7 +8,8 @@ math.functions math.private strings layouts compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals -specialized-arrays.double system sorting math.libm ; +specialized-arrays.double system sorting math.libm +math.intervals ; IN: compiler.tree.propagation.tests \ propagate must-infer @@ -599,6 +600,10 @@ MIXIN: empty-mixin [ V{ t } ] [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test +[ T{ interval f { 0 t } { 127 t } } ] [ + [ { integer } declare 127 bitand ] final-info first interval>> +] unit-test + ! [ V{ string } ] [ ! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes ! ] unit-test diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 52903fce8d..f6726e4404 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs accessors kernel combinators -classes.algebra sequences sequences.deep slots.private +classes.algebra sequences slots.private fry vectors classes.tuple.private math math.private arrays stack-checker.branches +compiler.utilities compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -21,7 +22,7 @@ GENERIC: unbox-tuples* ( node -- node/nodes ) : (expand-#push) ( object value -- nodes ) dup unboxed-allocation dup [ [ object-slots ] [ drop ] [ ] tri* - [ (expand-#push) ] 2map + [ (expand-#push) ] 2map-flat ] [ drop #push ] if ; @@ -38,11 +39,16 @@ M: #push unbox-tuples* ( #push -- nodes ) : unbox- ( #call -- nodes ) dup unbox-output? [ drop { } ] when ; -: (flatten-values) ( values -- values' ) - [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ; +: (flatten-values) ( values accum -- ) + dup '[ + dup unboxed-allocation + [ _ (flatten-values) ] [ _ push ] ?if + ] each ; : flatten-values ( values -- values' ) - dup empty? [ (flatten-values) flatten ] unless ; + dup empty? [ + 10 [ (flatten-values) ] keep + ] unless ; : prepare-slot-access ( #call -- tuple-values outputs slot-values ) [ in-d>> flatten-values ] diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor new file mode 100644 index 0000000000..1f488b3dde --- /dev/null +++ b/basis/compiler/utilities/utilities.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences sequences.private arrays vectors fry +math.order ; +IN: compiler.utilities + +: flattener ( seq quot -- seq vector quot' ) + over length [ + dup + '[ + @ [ + dup array? + [ _ push-all ] [ _ push ] if + ] when* + ] + ] keep ; inline + +: flattening ( seq quot combinator -- seq' ) + [ flattener ] dip dip { } like ; inline + +: map-flat ( seq quot -- seq' ) [ each ] flattening ; inline + +: 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline + +: (3each) ( seq1 seq2 seq3 quot -- n quot' ) + [ [ [ length ] tri@ min min ] 3keep ] dip + '[ [ _ nth-unsafe ] [ _ nth-unsafe ] [ _ nth-unsafe ] tri @ ] ; inline + +: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline + +: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index bfa127e7e0..19715357ee 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel kernel.private math math.private words -sequences parser namespaces make assocs quotations arrays locals +sequences parser namespaces make assocs quotations arrays generic generic.math hashtables effects compiler.units classes.algebra fry combinators ; IN: math.partial-dispatch @@ -45,29 +45,29 @@ M: word integer-op-input-classes { bitnot fixnum-bitnot } } at swap or ; -:: integer-fixnum-op-quot ( fix-word big-word -- quot ) +: integer-fixnum-op-quot ( fix-word big-word -- quot ) [ [ over fixnum? ] % - fix-word '[ _ execute ] , - big-word '[ fixnum>bignum _ execute ] , + [ '[ _ execute ] , ] + [ '[ fixnum>bignum _ execute ] , ] bi* \ if , ] [ ] make ; -:: fixnum-integer-op-quot ( fix-word big-word -- quot ) +: fixnum-integer-op-quot ( fix-word big-word -- quot ) [ [ dup fixnum? ] % - fix-word '[ _ execute ] , - big-word '[ [ fixnum>bignum ] dip _ execute ] , + [ '[ _ execute ] , ] + [ '[ [ fixnum>bignum ] dip _ execute ] , ] bi* \ if , ] [ ] make ; -:: integer-integer-op-quot ( fix-word big-word -- quot ) +: integer-integer-op-quot ( fix-word big-word -- quot ) [ [ dup fixnum? ] % - fix-word big-word integer-fixnum-op-quot , + 2dup integer-fixnum-op-quot , [ [ over fixnum? [ [ fixnum>bignum ] dip ] when ] % - big-word , + nip , ] [ ] make , \ if , ] [ ] make ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 3461266081..995a8bba4c 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -835,12 +835,35 @@ PRIVATE> : supremum ( seq -- n ) dup first [ max ] reduce ; -: flip ( matrix -- newmatrix ) - dup empty? [ - dup [ length ] map infimum - swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as - ] unless ; - : sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline : count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline + +! We hand-optimize flip to such a degree because type hints +! cannot express that an array is an array of arrays yet, and +! this word happens to be performance-critical since the compiler +! itself uses it. Optimizing it like this reduced compile time. +> ; + +: array-flip ( matrix -- newmatrix ) + [ dup first array-length [ array-length min ] reduce ] keep + [ [ array-nth ] with { } map-as ] curry { } map-as ; + +PRIVATE> + +: flip ( matrix -- newmatrix ) + dup empty? [ + dup array? [ + dup [ array? ] all? + [ array-flip ] [ generic-flip ] if + ] [ generic-flip ] if + ] unless ;