Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
gendl
gendl
Commits
8b37a818
Commit
8b37a818
authored
Oct 11, 2012
by
Dave Cooper
Browse files
fixed wrong asdf packages. Fixed SBCL memory leak with weak hash tables.
parent
fd499c87
Changes
12
Hide whitespace changes
Inline
Side-by-side
build/source/app.lisp
View file @
8b37a818
...
...
@@ -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
...
...
gdl/base/common/genworks.lisp
View file @
8b37a818
...
...
@@ -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
()
...
...
gdl/base/common/start-gdl.lisp
View file @
8b37a818
...
...
@@ -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
)
...
...
gdl/base/tests/source/base-object-tree.lisp
View file @
8b37a818
...
...
@@ -69,16 +69,16 @@
(
defun
bot-run
()
(
let
(
initial-memory
delta
leaf-count
)
(
setq
initial-memory
(
getf
(
g
w
l:room-report
t
)
:MB-int
))
(
setq
initial-memory
(
getf
(
gl
isp
:room-report
t
)
:MB-int
))
(
setq
*arr*
(
make-obj-array
))
(
setq
delta
(
-
(
getf
(
g
w
l:room-report
t
)
:MB-int
)
initial-memory
))
(
setq
delta
(
-
(
getf
(
gl
isp
: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
(
g
w
l:room-report
3
)
:MB-int
)
initial-memory
))
(
setq
delta
(
-
(
getf
(
gl
isp
: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
(
g
w
l:room-report
t
)
:MB-int
)
initial-memory
))
(
setq
leaf-count
(
length
(
the-object
*obj*
leaves
)))
(
setq
delta
(
-
(
getf
(
gl
isp
: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
(
g
w
l:room-report
3
)
:MB-int
)
initial-memory
))
(
setq
delta
(
-
(
getf
(
gl
isp
: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
(
g
w
l:room-report
t
)
:MB-int
))
(
setq
initial-memory
(
getf
(
gl
isp
: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
(
g
w
l:room-report
t
)
:MB-int
)
initial-memory
))
(
setq
leaf-count
(
length
(
the-object
*obj*
leaves
)))
(
setq
delta
(
-
(
getf
(
gl
isp
: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
(
g
w
l:room-report
3
)
:MB-int
)
initial-memory
))
(
setq
delta
(
-
(
getf
(
gl
isp
:room-report
3
)
:MB-int
)
initial-memory
))
(
format
t
"After clearing *obj*: ~a MB~%"
delta
))))
...
...
gdl/cl-lite/depends-on.isc
View file @
8b37a818
(:gdl-base :cl-fad)
(:gdl-base :cl-fad
:asdf-utils
)
gdl/cl-lite/gdl-cl-lite.asd
View file @
8b37a818
...
...
@@ -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
gdl/cl-lite/source/cl-lite.lisp
View file @
8b37a818
...
...
@@ -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"
...
...
gdl/cl-lite/source/genworks.lisp
View file @
8b37a818
...
...
@@ -100,7 +100,7 @@ and \"..\" entries."
(
defun
file-directory-p
(
file
)
"Returns non-nil if the path is a directory."
(
#-
(
or
allegro
lispworks
)
asdf-util
itie
s:directory-pathname-p
(
#-
(
or
allegro
lispworks
)
asdf-utils:directory-pathname-p
#+
allegro
excl:file-directory-p
#+
lispworks
lw:file-directory-p
file
))
...
...
gdl/geom-base/prereqs/source/genworks.lisp
View file @
8b37a818
...
...
@@ -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
)
...
...
gdl/gwl/gdl-gwl.asd
View file @
8b37a818
...
...
@@ -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"
)
...
...
gdl/gwl/source/genworks.lisp
View file @
8b37a818
...
...
@@ -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
))
gdl/gwl/source/room-report.lisp
deleted
100644 → 0
View file @
fd499c87
;;
;; 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
)))))))))))
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment