Commit 8b37a818 authored by Dave Cooper's avatar Dave Cooper
Browse files

fixed wrong asdf packages. Fixed SBCL memory leak with weak hash tables.

parent fd499c87
......@@ -55,15 +55,15 @@ temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
glisp:*genworks-source-home*))
#+nil
(setf (symbol-value (read-from-string
"asdf-utilities:*central-registry*")) nil)))
"asdf:*central-registry*")) nil)))
(pre-load-form (the load-core-gdl-form))
(post-load-form '(progn (setf (symbol-value (read-from-string
"asdf-utilities:*central-registry*")) nil)
(asdf-utilities:map-systems #'asdf-utilities:clear-system)
(asdf-utilities:clear-output-translations)
(asdf-utilities:disable-output-translations)
"asdf:*central-registry*")) nil)
(asdf:map-systems #'asdf:clear-system)
(asdf:clear-output-translations)
(asdf:disable-output-translations)
))
......@@ -171,11 +171,11 @@ temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
(require :smtp)
(require :ftp)
(load (merge-pathnames "demos/gdl-demos.asd" glisp:*genworks-source-home*))
(asdf-utilities:load-system :gdl-demos)
(asdf:load-system :gdl-demos)
(load (merge-pathnames "../downloads/gdl-downloads.asd" glisp:*genworks-source-home*))
(asdf-utilities:load-system :gdl-downloads)
(asdf:load-system :gdl-downloads)
(load (merge-pathnames "demos/newsite/gdl-newsite.asd" glisp:*genworks-source-home*))
(asdf-utilities:load-system :gdl-newsite)
(asdf:load-system :gdl-newsite)
(setf (symbol-value (read-from-string
"glisp:*genworks-source-home*")) nil))
:destination-directory
......
......@@ -74,7 +74,7 @@
#-(and mswindows allegro) :default)
(defun system-home (system-designator)
(asdf-utilities:system-source-directory system-designator))
(asdf:system-source-directory system-designator))
(defparameter *genworks-source-home*
(let ((gdl-base-home (system-home "gdl-base")))
......@@ -233,7 +233,7 @@
#+allegro :weak-keys #+allegro t
#+allegro :values #+allegro :weak
#+lispworks :weak-kind #+lispworks t
#+sbcl :weakness #+sbcl :key-or-value
#+sbcl :weakness #+sbcl :key-and-value
args))
(defun set-default-float-format ()
......
......@@ -100,7 +100,7 @@
;; FLAG -- pull asdf-specific code into glisp layer
;;
(multiple-value-bind (value error)
(ignore-errors (asdf-utilities:system-definition-pathname :gdl-base))
(ignore-errors (asdf:system-definition-pathname :gdl-base))
(declare (ignore value))
(when error
(warn "
......@@ -109,14 +109,14 @@ asdf has system definitions for non-existent source directories.
You should probably do:
(asdf-utilities:map-systems #'asdf-utilities:clear-system)
(asdf:map-systems #'asdf:clear-system)
And really this should be done in the post-load-form of your build."))
(if error
(setq glisp:*genworks-source-home* nil)
(setq glisp:*genworks-source-home*
(when (asdf-utilities:find-system :gdl-base nil)
(when (asdf:find-system :gdl-base nil)
(let ((gdl-base-home (glisp:system-home :gdl-base)))
(make-pathname :name nil
:type nil
......@@ -148,7 +148,7 @@ And really this should be done in the post-load-form of your build."))
;;(setq ql:*quicklisp-home* (merge-pathnames "quicklisp/" glisp:*gdl-home*))
;;
(asdf-utilities:initialize-output-translations)
(asdf:initialize-output-translations)
(glisp:set-default-package)
(glisp:xref-off)
......
......@@ -69,16 +69,16 @@
(defun bot-run ()
(let (initial-memory delta leaf-count)
(setq initial-memory (getf (gwl:room-report t) :MB-int))
(setq initial-memory (getf (glisp:room-report t) :MB-int))
(setq *arr* (make-obj-array))
(setq delta (- (getf (gwl:room-report t) :MB-int) initial-memory))
(setq delta (- (getf (glisp:room-report t) :MB-int) initial-memory))
(format t "After 97656 standalone objects in array: ~a MB~%" delta)
(setq *arr* nil)
1 2 3 4 5
(setq delta (- (getf (gwl:room-report 3) :MB-int) initial-memory))
(setq delta (- (getf (glisp:room-report 3) :MB-int) initial-memory))
(format t "After clearing *arr*: ~a MB~%" delta)
......@@ -87,26 +87,26 @@
;;(maptree *obj* #'(lambda(obj) (declare (ignore obj)) (incf object-count)))
;;(format t "~a total nodes.~%" object-count)
(format t "Demanding leaves with dep tracking...~%")
(setq leaf-count (length (the-object *obj* leaves-uncached)))
(setq delta (- (getf (gwl:room-report t) :MB-int) initial-memory))
(setq leaf-count (length (the-object *obj* leaves)))
(setq delta (- (getf (glisp:room-report t) :MB-int) initial-memory))
(format t "After ~a leaves with dep tracking: ~a MB~%" leaf-count delta)
(setq *obj* nil)
1 2 3 4 5
(setq delta (- (getf (gwl:room-report 3) :MB-int) initial-memory))
(setq delta (- (getf (glisp:room-report 3) :MB-int) initial-memory))
(format t "After clearing *obj*: ~a MB~%" delta)
(let ((*run-with-dependency-tracking?* nil))
(setq *obj* (make-object 'base-object-tree))
(setq initial-memory (getf (gwl:room-report t) :MB-int))
(setq initial-memory (getf (glisp:room-report t) :MB-int))
;;(maptree *obj* #'(lambda(obj) (declare (ignore obj)) (incf object-count)))
;;(format t "~a total nodes.~%" object-count)
(format t "Demanding leaves without dep tracking...~%")
(setq leaf-count (length (the-object *obj* leaves-uncached)))
(setq delta (- (getf (gwl:room-report t) :MB-int) initial-memory))
(setq leaf-count (length (the-object *obj* leaves)))
(setq delta (- (getf (glisp:room-report t) :MB-int) initial-memory))
(format t "After ~a leaves without dep tracking: ~a MB~%" leaf-count delta)
(setq *obj* nil)
(setq delta (- (getf (gwl:room-report 3) :MB-int) initial-memory))
(setq delta (- (getf (glisp:room-report 3) :MB-int) initial-memory))
(format t "After clearing *obj*: ~a MB~%" delta))))
......
(:gdl-base :cl-fad)
(:gdl-base :cl-fad :asdf-utils)
......@@ -4,6 +4,6 @@
:author
"Genworks and Dave Cooper unless otherwise indicated"
:license "AGPL unless otherwise indicated" :serial t
:version "2011111700" :depends-on (:gdl-base :cl-fad)
:version "2011111700" :depends-on (:gdl-base :cl-fad :asdf-utils)
:components
((:file "source/genworks") (:file "source/cl-lite")))
\ No newline at end of file
......@@ -253,7 +253,7 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all
(asdf-system-list
(let ((binaries (the compile-and-load)))
(append `(asdf-utilities:defsystem ,(read-from-string (format nil "#:~a" (pathname-name (the asd-file))))
(append `(asdf:defsystem ,(read-from-string (format nil "#:~a" (pathname-name (the asd-file))))
:description "Auto-generated asdf defsys from Genworks GDL cl-lite."
:author "Genworks and Dave Cooper unless otherwise indicated"
:license "AGPL unless otherwise indicated"
......
......@@ -100,7 +100,7 @@ and \"..\" entries."
(defun file-directory-p (file)
"Returns non-nil if the path is a directory."
(#-(or allegro lispworks) asdf-utilities:directory-pathname-p
(#-(or allegro lispworks) asdf-utils:directory-pathname-p
#+allegro excl:file-directory-p
#+lispworks lw:file-directory-p file))
......
......@@ -24,7 +24,7 @@
(defun run-gs (command)
"Shell out a ghostscript command and handle errors."
#-allegro
(let ((result (asdf-utilities:run-shell-command command)))
(let ((result (asdf:run-shell-command command)))
(unless (zerop result) (error "Ghostscript threw error")))
#+allegro
(multiple-value-bind (output error return)
......@@ -40,7 +40,7 @@ return: ~a"
;;
;; FLAG -- add specific keyword args e.g. for hide-window?
;;
(apply #'asdf-utilities:run-shell-command command args))
(apply #'asdf:run-shell-command command args))
(defun set-gs-path (&optional gs-path)
......
......@@ -26,7 +26,6 @@
(:file "source/crawler") (:file "source/log-utils")
(:file "source/new-urls") (:file "source/publish")
(:file "source/remote-object")
(:file "source/room-report")
(:file "source/security-check-failed")
(:file "ajax/source/parameters")
(:file "ajax/source/ajax")
......
......@@ -15,6 +15,7 @@
#:process-run-function
#:remote-host
#:replace-regexp
#:room-report
#:slot-definition-name
#:socket-bytes-written
#:split-regexp
......@@ -88,6 +89,108 @@ the \"current\" error."
(defun replace-regexp (string regexp to-string)
(cl-ppcre:regex-replace-all regexp string to-string))
(defun room-report (&optional (gc? t))
"Plist with keys :new-free-cons, :new-used-cons, :new-free-other, :new-used-other, :old-free-cons, :old-used-cons, :old-free-other, :old-used-other.
This is the main output from this object and gives a general overview of memory state. The especially
noteworthy values are usually the :free-used-other and :old-used-other.
:&optional ((gc nil) \"Determines whether to do a full gc before probing the room data.\")
"
(when gc?
(if (integerp gc?) (dotimes (n gc?) (glisp:gc-full)) (glisp:gc-full))) ;; future: (glisp:gc-full)
(let ((gdl:self (gdl:make-object 'room-report))) (gdl:the room-data)))
#+sbcl
(gdl:define-object room-report ()
:computed-slots
((room-string (with-output-to-string (*standard-output*) (room)))
(room-lines (with-input-from-string (in (gdl:the room-string))
(let (lines)
(do ((report-line (read-line in nil) (read-line in nil)))
((null report-line) (nreverse lines))
(push report-line lines)))))
(new-data (list :new-free-cons 0 :new-used-cons 0 :new-free-other 0 :new-used-other 0))
(old-data (list :old-free-cons 0 :old-used-cons (gdl:the cons-bytes) :old-used-other (- (gdl:the space-total) (gdl:the cons-bytes))))
(cons-bytes (gdl:the (parse-line-data "cons objects.")))
(space-total (gdl:the (parse-line-data "space total.")))
("Plist with keys :new-free-cons, :new-used-cons, :new-free-other, :new-used-other,
:old-free-cons, :old-used-cons, :old-free-other, :old-used-other. This is the main
output from this object and gives a general overview of memory state. The especially
noteworthy values are usually the :free-used-other and :old-used-other."
room-data (let* ((data (append (gdl:the new-data) (gdl:the old-data)))
(total (+ (getf data :new-used-cons)
(getf data :old-used-cons)
(getf data :new-used-other)
(getf data :old-used-other))))
(let ((mb (/ (gdl:round-to-nearest total 1000000) 1000000)))
(append data (list :total total
:MB-int mb
:MB (format nil "~a MB" mb)))))))
:functions ((parse-line-data
(report-label)
(let ((line (find report-label (gdl:the room-lines) :test #'search)))
(parse-integer (glisp:replace-regexp (first (glisp:split-regexp "\\s" (string-trim (list #\space) line))) "," ""))))))
#+allegro
(gdl:define-object room-report ()
:computed-slots
((room-string (with-output-to-string (*standard-output*) (room)))
(room-lines (with-input-from-string (in (gdl:the room-string))
(let (lines)
(do ((report-line (read-line in nil) (read-line in nil)))
((null report-line) (nreverse lines))
(push report-line lines)))))
(new-data (gdl:the (parse-line-data "New")))
(old-data (gdl:the (parse-line-data "OTot")))
("Plist with keys :new-free-cons, :new-used-cons, :new-free-other, :new-used-other,
:old-free-cons, :old-used-cons, :old-free-other, :old-used-other. This is the main
output from this object and gives a general overview of memory state. The especially
noteworthy values are usually the :free-used-other and :old-used-other."
room-data (append (gdl:the new-data) (gdl:the old-data))))
:functions ((parse-line-data
(report-label)
(let ((prefix (cond ((string-equal report-label "New") "new")
((string-equal report-label "OTot") "old"))))
(let ((report-line (find t (gdl:the room-lines)
:test #'(lambda(item report-line)
(declare (ignore item))
(and (search report-label report-line)
(not (search "-----" report-line)))))))
(let ((fields (remove "" (glisp:split-regexp "\\s" report-line) :test #'string-equal)))
(let ((cons (third fields))
(other (fourth fields)))
(append
(destructuring-bind (free used)
(glisp:split-regexp ":" cons)
(list (make-keyword (format nil "~a-free-cons" prefix)) (parse-integer free)
(make-keyword (format nil "~a-used-cons" prefix)) (parse-integer used)))
(destructuring-bind (free used)
(glisp:split-regexp ":" other)
(list (make-keyword (format nil "~a-free-other" prefix)) (parse-integer free)
(make-keyword (format nil "~a-used-other" prefix)) (parse-integer used)))))))))))
(defun slot-definition-name (slot-definition)
#-(or allegro lispworks sbcl) (error "Need implementation for slot-definition-name for currently running lisp.~%")
(#+allegro mop:slot-definition-name
......@@ -158,7 +261,7 @@ please find implementation for the currently running lisp.~%")
(in-package :net.aserve)
#-allegro (eval-when (compile load eval) (glisp:begin-redefinitions-ok))
#-allegro (eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
#-allegro
(defclass http-request (http-header-mixin)
......@@ -438,7 +541,12 @@ please find implementation for the currently running lisp.~%")
;; This is fixed in original-allegroserve - octets-to-string wrapped
;; around comment -- try to propogate into portableallegroserve.
;;
#-allegro
;;
;; FLAG -- not currently needed in any non-Allegro CL installations, commenting out for now
;; because for example we don't have portable schedule-finalization yet (should be from trivial-garbage?)
;;
;;#-allegro
#+nil
(defun proxy-request (req ent &key pcache-ent (respond t)
(level *browser-level*))
;; a request has come in with an http scheme given in uri
......@@ -922,4 +1030,11 @@ cached connection = ~s~%" cond cached-connection))
(mp:unschedule-timer timer)
(setf unsheduled? t))))))
#-allegro (eval-when (compile load eval) (glisp:end-redefinitions-ok))
#-allegro (eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
;;
;; Copyright 2012 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gwl)
;;
;; FLAG -- move this to glisp package and implement for known Lisp implementations.
;;
#+allegro
(defun room-report (&optional gc?)
"Plist with keys :new-free-cons, :new-used-cons, :new-free-other, :new-used-other, :old-free-cons, :old-used-cons, :old-free-other, :old-used-other.
This is the main output from this object and gives a general overview of memory state. The especially
noteworthy values are usually the :free-used-other and :old-used-other.
:&optional ((gc nil) \"Determines whether to do a full gc before probing the room data.\")
"
(when gc?
(if (integerp gc?) (dotimes (n gc?) (excl:gc t)) (excl:gc t))) ;; future: (glisp:gc-full)
(let ((self (make-object 'room-report)))
(let* ((data (the room-data))
(total (+ (* 8 (getf data :new-used-cons))
(* 8 (getf data :old-used-cons))
(getf data :new-used-other)
(getf data :old-used-other))))
(let ((mb (/ (round-to-nearest total 1000000) 1000000)))
(append data (list :total total
:MB-int mb
:MB (format nil "~a MB" mb)))))))
#+allegro
(define-object room-report ()
:computed-slots
((room-string (with-output-to-string (*standard-output*) (room)))
(room-lines (with-input-from-string (in (the room-string))
(let (lines)
(do ((report-line (read-line in nil) (read-line in nil)))
((null report-line) (nreverse lines))
(push report-line lines)))))
(new-data (the (parse-line-data "New")))
(old-data (the (parse-line-data "OTot")))
("Plist with keys :new-free-cons, :new-used-cons, :new-free-other, :new-used-other,
:old-free-cons, :old-used-cons, :old-free-other, :old-used-other. This is the main
output from this object and gives a general overview of memory state. The especially
noteworthy values are usually the :free-used-other and :old-used-other."
room-data (append (the new-data) (the old-data))))
:functions ((parse-line-data
(report-label)
(let ((prefix (cond ((string-equal report-label "New") "new")
((string-equal report-label "OTot") "old"))))
(let ((report-line (find t (the room-lines)
:test #'(lambda(item report-line)
(declare (ignore item))
(and (search report-label report-line)
(not (search "-----" report-line)))))))
(let ((fields (remove "" (glisp:split-regexp "\\s" report-line) :test #'string-equal)))
(let ((cons (third fields))
(other (fourth fields)))
(append
(destructuring-bind (free used)
(glisp:split-regexp ":" cons)
(list (make-keyword (format nil "~a-free-cons" prefix)) (parse-integer free)
(make-keyword (format nil "~a-used-cons" prefix)) (parse-integer used)))
(destructuring-bind (free used)
(glisp:split-regexp ":" other)
(list (make-keyword (format nil "~a-free-other" prefix)) (parse-integer free)
(make-keyword (format nil "~a-used-other" prefix)) (parse-integer used)))))))))))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment