From e7a186a1035a0b204360698229f974282c5388e2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 4 Dec 2015 01:33:41 +0100 Subject: [PATCH] elisp: Fix excessive use of map-file We still don't do unmap-file but this should alleviate the problem somewhat since most commands won't actually use map-file. --- elisp/ghc-comp.el | 2 +- elisp/ghc-info.el | 8 +------- elisp/ghc-process.el | 38 ++++++++++++++++++++++---------------- 3 files changed, 24 insertions(+), 24 deletions(-) diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el index 700e8e3..20be9a1 100644 --- a/elisp/ghc-comp.el +++ b/elisp/ghc-comp.el @@ -101,7 +101,7 @@ unloaded modules are loaded") (defun ghc-boot (n) (prog2 (message "Initializing...") - (ghc-sync-process "boot\n" n nil 'skip-map-file) + (ghc-sync-process "boot\n" n) (message "Initializing...done"))) (defun ghc-load-modules (mods) diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el index abe4356..c10e032 100644 --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -111,13 +111,7 @@ (cn (int-to-string (1+ (current-column)))) (file (buffer-file-name)) (cmd (format "type %s %s %s\n" file ln cn))) - (ghc-sync-process cmd nil 'ghc-type-fix-string))) - -(defun ghc-type-fix-string () - (save-excursion - (goto-char (point-min)) - (while (search-forward "[Char]" nil t) - (replace-match "String")))) + (ghc-sync-process cmd nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el index 2a70b27..257a18e 100644 --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -1,3 +1,4 @@ +;;; -*- lexical-binding: t -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ghc-process.el @@ -21,8 +22,6 @@ (defvar-local ghc-process-process-name nil) (defvar-local ghc-process-original-buffer nil) (defvar-local ghc-process-original-file nil) -(defvar-local ghc-process-callback nil) -(defvar-local ghc-process-hook nil) (defvar-local ghc-process-root nil) (defvar ghc-command "ghc-mod") @@ -35,12 +34,12 @@ (defun ghc-get-project-root () (ghc-run-ghc-mod '("root"))) -(defun ghc-with-process (cmd callback &optional hook1 hook2 skip-map-file) +(defun ghc-with-process (cmd async-after-callback &optional sync-before-hook) (unless ghc-process-process-name (setq ghc-process-process-name (ghc-get-project-root))) (when (and ghc-process-process-name (not ghc-process-running)) (setq ghc-process-running t) - (if hook1 (funcall hook1)) + (if sync-before-hook (funcall sync-before-hook)) (let* ((cbuf (current-buffer)) (name ghc-process-process-name) (root (file-name-as-directory ghc-process-process-name)) @@ -52,14 +51,13 @@ (ghc-with-current-buffer buf (setq ghc-process-original-buffer cbuf) (setq ghc-process-original-file file) - (setq ghc-process-hook hook2) (setq ghc-process-root root) (let ((pro (ghc-get-process cpro name buf root)) (map-cmd (format "map-file %s\n" file))) - ;; map-file - (unless skip-map-file +; (unmap-cmd (format "unmap-file %s\n" file))) + (when (buffer-modified-p (current-buffer)) (setq ghc-process-file-mapping t) - (setq ghc-process-callback nil) + (setq ghc-process-async-after-callback nil) (erase-buffer) (when ghc-debug (ghc-with-debug-buffer @@ -79,12 +77,21 @@ (setq ghc-process-running nil) (setq ghc-process-file-mapping nil)))) ;; command - (setq ghc-process-callback callback) + (setq ghc-process-async-after-callback async-after-callback) (erase-buffer) (when ghc-debug (ghc-with-debug-buffer (insert (format "%% %s" cmd)))) (process-send-string pro cmd) + + ;;; this needs to be done asyncrounously after the command actually + ;;; finished, gah + ;; (when do-map-file + ;; (when ghc-debug + ;; (ghc-with-debug-buffer + ;; (insert (format "%% %s" unmap-cmd)))) + ;; (process-send-string pro unmap-cmd)) + pro))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -166,13 +173,12 @@ ((looking-at "^OK$") (delete-region (point) (point-max)) (setq ghc-process-file-mapping nil) - (when ghc-process-callback - (if ghc-process-hook (funcall ghc-process-hook)) + (when ghc-process-async-after-callback (goto-char (point-min)) - (funcall ghc-process-callback 'ok) + (funcall ghc-process-async-after-callback 'ok) (setq ghc-process-running nil))) ((looking-at "^NG ") - (funcall ghc-process-callback 'ng) + (funcall ghc-process-async-after-callback 'ng) (setq ghc-process-running nil))))))) (defun ghc-process-sentinel (_process _event) @@ -185,12 +191,12 @@ (defvar ghc-process-num-of-results nil) (defvar ghc-process-results nil) -(defun ghc-sync-process (cmd &optional n hook skip-map-file) +(defun ghc-sync-process (cmd &optional n) (unless ghc-process-running (setq ghc-process-rendezvous nil) (setq ghc-process-results nil) (setq ghc-process-num-of-results (or n 1)) - (let ((pro (ghc-with-process cmd 'ghc-process-callback nil hook skip-map-file))) + (let ((pro (ghc-with-process cmd 'ghc-sync-process-callback nil))) ;; ghc-process-running is now t. ;; But if the process exits abnormally, it is set to nil. (condition-case nil @@ -201,7 +207,7 @@ (setq ghc-process-running nil)))) ghc-process-results)) -(defun ghc-process-callback (status) +(defun ghc-sync-process-callback (status) (cond ((eq status 'ok) (let* ((n ghc-process-num-of-results)