X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily.scm;h=e98897fca850ecb62ae1d66f9757de634c61843b;hb=87eedcd59f4082cb0841528ad5bc82cb1d1191e3;hp=48fcc6165775bba84cc2816bbd030f16624f3f13;hpb=c98077f24daa1be35bbf1e075a4bf4ac9e25c7c6;p=lilypond.git

diff --git a/scm/lily.scm b/scm/lily.scm
index 48fcc61657..e98897fca8 100644
--- a/scm/lily.scm
+++ b/scm/lily.scm
@@ -5,6 +5,18 @@
 ;;;; (c) 1998--2006 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
 
+;; Internationalisation: (_i "to be translated") gets an entry in the
+;; POT file (gettext ) must be invoked explicitely to do the actual
+;; "translation".
+;;(define-macro (_i x) x)
+;;(define-macro-public _i (x) x)
+;;(define-public-macro _i (x) x)
+;; Abbrv-PWR!
+(defmacro-public _i (x) x)
+
+(read-enable 'positions)
+(debug-enable 'debug)
+
 
 (define (define-scheme-options)
   (for-each (lambda (x)
@@ -20,48 +32,56 @@
 	      (anti-alias-factor 1 "render at higher resolution and scale down result\nto prevent jaggies in PNG")
 	      (check-internal-types #f "check every property assignment for types")
 	      (clip-systems #f "Generate cut-out snippets of a score")
-	      (debug-gc #f
-			"dump memory debugging statistics")
-	      (debug-midi #f "generate human readable MIDI")
+	      (debug-gc #f "dump memory debugging statistics")
+	      (debug-gc-assert-parsed-dead #f "for memory debugging:
+ensure that all refs to parsed objects are dead.  This is an internal option, and is switched on automatically for -ddebug-gc.") 
+	      (debug-lexer #f "debug the flex lexer")
+	      (debug-parser #f "debug the bison parser")
+	      (debug-skylines #f "debug skylines")
 	      (delete-intermediate-files #f
 					 "delete unusable PostScript files")
-	      (dump-signatures #f "dump output signatures of each system")
-	      (dump-tweaks #f "dump page layout and tweaks for each score having the tweak-key layout property set.")
+	      (dump-profile #f "dump timing information for each file")
+	      (dump-signatures #f "dump output signatures of each system.  Used for regression testing.")
+	      
+	      (eps-box-padding #f "Pad EPS bounding box left edge.  Guarantee alignment between systems in LaTeX.")
 	      (gs-load-fonts #f
 			    "load fonts via Ghostscript.")
+	      (gui #f "running from gui; redirect stderr to log file")
+
 	      (include-book-title-preview #t "include book-titles in preview images.")
 	      (include-eps-fonts #t "Include fonts in separate-system EPS files.")
+	      (job-count #f "Process in parallel") 
+	      (log-file #f "redirect output to log FILE.log")
 
-	      (pad-eps-boxes #f "Pad EPS bounding boxes to guarantee alignment between systems")
-
-	      (gui #f "running from gui; redirect stderr to log file")
-	      
 	      (old-relative #f
 			    "relative for simultaneous music works
 similar to chord syntax")
-	      (object-keys #f
-			   "experimental mechanism for remembering tweaks")
 	      (point-and-click #t "use point & click")
 	      (paper-size "a4" "the default paper size")
+	      (pixmap-format "png16m" "GS format to use for pixel images")
 	      (protected-scheme-parsing #t "continue when finding errors in inline
 scheme are caught in the parser. If off, halt 
 on errors, and print a stack trace.")
 	      (profile-property-accesses #f "keep statistics of get_property() calls.")
 	      
-	      (resolution 101 "resolution for generating bitmaps")
+	      (resolution 101 "resolution for generating PNG bitmaps")
 	      (read-file-list #f "Read files to be processed from command line arguments")
 
 	      (safe #f "Run safely")
-	      (strict-infinity-checking #f "If yes, crash on encountering Inf/NaN")
-
+	      (strict-infinity-checking #f "If yes, crash on encountering Inf/NaN.")
+	      (separate-log-files #f "Output to FILE.log per file.")
+	      (trace-memory-frequency #f "Record Scheme cell usage this many times per second, and dump to file.")
 	      (ttf-verbosity 0
-			   "how much verbosity for TTF font embedding?")
-
+			     "how much verbosity for TTF font embedding?")
 	      (show-available-fonts #f
-				    "List  font names available.")
-
+				    "List font names available.")
 	      (verbose ,(ly:command-line-verbose?) "value for the --verbose flag")
-	      )))
+	      ))
+
+  (map
+   (lambda (x)
+     (ly:set-option (car x) (cdr x))) 
+   (eval-string (ly:command-line-options))))
 
 
 ;; need to do this in the beginning. Other parts of the
@@ -69,27 +89,30 @@ on errors, and print a stack trace.")
 ;;
 (define-scheme-options)
 
+
+
 (debug-set! stack 0)
 
 (if (defined? 'set-debug-cell-accesses!)
     (set-debug-cell-accesses! #f))
 
-;(set-debug-cell-accesses! 1000)
+					;(set-debug-cell-accesses! 1000)
 
 (use-modules (ice-9 regex)
 	     (ice-9 safe)
+	     (ice-9 rdelim)
              (ice-9 optargs)
 	     (oop goops)
 	     (srfi srfi-1)
 	     (srfi srfi-13)
 	     (srfi srfi-14)
 	     (scm clip-region)
-
+	     (scm memory-trace)
 	     )
 
-
 ;; my display
-(define-public (myd k v) (display k) (display ": ") (display v) (display ", "))
+(define-public (myd k v) (display k) (display ": ") (display v) (display ", ")
+  v)
 
 (define-public (print . args)
   (apply format (cons (current-output-port) args)))
@@ -101,6 +124,7 @@ on errors, and print a stack trace.")
 
 (if (ly:get-option 'verbose)
     (begin
+      (ly:set-option 'protected-scheme-parsing #f)
       (debug-enable 'debug)
       (debug-enable 'backtrace)
       (read-enable 'positions)))
@@ -134,7 +158,7 @@ on errors, and print a stack trace.")
     (if (ly:get-option 'verbose)
 	(ly:progress "[~A" file-name))
     (if (not file-name)
-	(ly:error (_ "Can't find ~A" x)))
+	(ly:error (_ "cannot find: ~A") x))
     (primitive-load file-name)
     (if (ly:get-option 'verbose)
 	(ly:progress "]"))))
@@ -171,7 +195,7 @@ on errors, and print a stack trace.")
 	  "//*" "/"
 	  (string-regexp-substitute "\\\\" "/" x))))
    ;; FIXME: this prints a warning.
-  (define-public (ly-getcwd)
+   (define-public (ly-getcwd)
      (slashify (native-getcwd))))
   (else (define-public ly-getcwd getcwd)))
 
@@ -247,16 +271,17 @@ The syntax is the same as `define*-public'."
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; init pitch system
 
-(ly:set-default-scale (ly:make-scale #(0 2 4 5 7 9 11)))
+(ly:set-default-scale (ly:make-scale #(0 1 2 5/2 7/2 9/2 11/2)))
+
 
 
- 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; other files.
 
-(for-each ly:load
-	  ;; load-from-path
-	  '("lily-library.scm"
+
+(define
+  init-scheme-files
+  '("lily-library.scm"
 	    "file-cache.scm"
 	    "define-event-classes.scm"
 	    "define-music-types.scm"
@@ -303,6 +328,11 @@ The syntax is the same as `define*-public'."
 	    "safe-lily.scm"))
 
 
+
+
+(for-each ly:load init-scheme-files)
+
+
 (set! type-p-name-alist
       `(
 	(,boolean-or-symbol? . "boolean or symbol")
@@ -341,10 +371,48 @@ The syntax is the same as `define*-public'."
 	(,symbol? . "symbol")
 	(,vector? . "vector")))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; timing
+
+(define (profile-measurements)
+  (let* ((t (times))
+	 (stats (gc-stats)))
+    
+    (list
+     (- (+ (tms:cutime t)
+	   (tms:utime t))
+	(ly:assoc-get 'gc-time-taken stats))
+     
+     (ly:assoc-get 'total-cells-allocated  stats 0)
+     )))
+
+(define (dump-profile base last this)
+  (let*
+      ((outname (format "~a.profile" (basename base ".ly")))
+       (diff (map (lambda (y) (apply - y)) (zip this last))))
+    
+    (ly:progress "\nWriting timing to ~a..." outname)
+    (format (open-file outname "w")
+	    "time: ~a\ncells: ~a\n"
+	    (car diff)
+	    (cadr diff)
+	    )))
+
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; debug mem leaks
 
+(define gc-dumping #f)
 (define gc-protect-stat-count 0)
+
+(define-public (dump-live-object-stats outfile)
+  (for-each
+   (lambda (x)
+     (format outfile "~a: ~a\n" (car x) (cdr x)))
+   (sort (gc-live-object-stats)
+	 (lambda (x y)
+	   (string<? (car x) (car y))))))
+
 (define-public (dump-gc-protects)
   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
   (let* ((protects (sort
@@ -358,77 +426,209 @@ The syntax is the same as `define*-public'."
 			 ".scm"))
 	 (outfile    (open-file  out-file-name  "w")))
 
-    (display (format "Dumping gc protected objs to ~a...\n" out-file-name))
+    (set! gc-dumping #t)
+    (display (format "Dumping GC statistics ~a...\n" out-file-name))
     (display
      (map (lambda (y)
 	    (let ((x (car y))
 		  (c (cdr y)))
-	      
-	      (string-append
-	       (string-join
-		(map object->string (list (object-address x) c x))
-		" ")
-	       "\n")))
-
+	      (display 
+	       (format "~a (~a) = ~a\n" (object-address x) c x)
+	       outfile)))
 	  (filter
 	   (lambda (x)
 	     (not (symbol? (car x))))
 	   protects))
      outfile)
 
-;    (display (ly:smob-protects))
+    (format outfile "\nprotected symbols: ~a\n"
+	    (length (filter symbol?  (map car protects))))
+    
+	     
+
+    ;; (display (ly:smob-protects))
     (newline outfile)
     (if (defined? 'gc-live-object-stats)
 	(let* ((stats #f))
 	  (display "Live object statistics: GC'ing\n")
+	  (ly:reset-all-fonts)
 	  (gc)
 	  (gc)
-	  
+	  (display "Asserting dead objects\n")
+	  (ly:set-option 'debug-gc-assert-parsed-dead #t)
+	  (gc)
+	  (ly:set-option 'debug-gc-assert-parsed-dead #f)
+
 	  (set! stats (gc-live-object-stats))
 	  (display "Dumping live object statistics.\n")
-	  
-	  (for-each
-	   (lambda (x)
-	     (format outfile "~a: ~a\n" (car x) (cdr x)))
-	   (sort (gc-live-object-stats)
-		 (lambda (x y)
-		   (string<? (car x) (car y)))))))))
+	  (dump-live-object-stats outfile)))
+
+    (newline outfile)
+    (let*
+	((stats (gc-stats)))
+      
+      (for-each
+       (lambda (sym)
+	 (display
+	  (format "~a ~a ~a\n"
+		  gc-protect-stat-count
+		  sym
+		  (let ((sym-stat (assoc sym stats)))
+		    (if sym-stat 
+			(cdr sym-stat)
+			"?")))
+	  outfile))
+       '(protected-objects bytes-malloced cell-heap-size
+			   
+			   )))
+
+    (set! gc-dumping #f)
+    (close-port outfile)
+    
+    ))
+
+
+(define (check-memory)
+  "read /proc/self to check up on memory use." 
+  (define (gulp-file name)
+    (let* ((file (open-input-file name))
+	   (text (read-delimited "" file)))
+      (close file)
+      text))
+  (let*
+      ((stat (gulp-file "/proc/self/status"))
+       (lines (string-split stat #\newline))
+       (interesting (filter identity
+			    (map
+			     (lambda (l)
+			       (string-match "^VmData:[ \t]*([0-9]*) kB" l))
+			     lines)))
+       (mem (string->number (match:substring (car interesting) 1)))
+       )
+
+    
+    (display (format  "VMDATA: ~a\n" mem))
+    (display (gc-stats))
+    (if (> mem 100000)
+	(begin
+	  (dump-gc-protects)
+	  (raise 1)))
+    
+    ))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
+(define (multi-fork count)
+  (define (helper count acc)
+    (if (> count 0)
+      (let*
+	  ((pid  (primitive-fork)))
+	(if (= pid 0)
+	    (1- count)
+	    (helper (1- count) (cons pid acc))))
+      acc))
+  (helper count '()))
+
+
 (define-public (lilypond-main files)
   "Entry point for LilyPond."
-  
+
   (define (no-files-handler)
     (ly:usage)
     (exit 2))
 
+  (eval-string (ly:command-line-code))
+  
   (if (ly:get-option 'gui)
       (gui-main files))
 
   (if (null? files)
       (no-files-handler))
 
+  (if (ly:get-option 'read-file-list)
+      (set! files
+	    (filter (lambda (s)
+		      (> (string-length s) 0))
+		    (apply append
+			   (map (lambda (f) (string-split (ly:gulp-file f) #\nl))
+				files)))
+	    ))
+  
+  (if (and (number? (ly:get-option 'job-count))
+	   (>= (length files) (ly:get-option 'job-count)))
+      
+      (let*
+	  ((count (ly:get-option 'job-count))
+	   (split-todo (split-list files count)) 
+	   (joblist (multi-fork count))
+	   (errors '()))
+
+	(if (not (string-or-symbol? (ly:get-option 'log-file)))
+	    (ly:set-option 'log-file "lilypond-multi-run"))
+	
+	(if (number? joblist)
+	    (begin
+	      (ly:set-option 'log-file (format "~a-~a"
+					       (ly:get-option 'log-file) joblist))
+	      (set! files (vector-ref split-todo joblist)))
+
+	    (begin
+	      (ly:progress "\nForking into jobs:  ~a\n" joblist)
+	      (for-each
+	       (lambda (pid)
+		 (let* ((stat (cdr (waitpid pid))))
+		   
+		   (if (not (= stat 0))
+		       (set! errors (acons (list-element-index joblist pid) stat errors)))))
+	       joblist)
+
+	      (for-each
+	       (lambda (x)
+		 (let* ((job (car x))
+			(state (cdr x))
+			(logfile  (format "~a-~a.log"
+					  (ly:get-option 'log-file) job))
+			(log (ly:gulp-file logfile))
+			(len (string-length log))
+			(tail (substring  log (max 0 (- len 1024)))))
+
+		   (if (status:term-sig state)
+		       (ly:message "\n\n~a\n"
+				   (format (_ "job ~a terminated with signal: ~a")
+					   job
+					   (status:term-sig state)))
+		       (ly:message (_ "logfile ~a (exit ~a):\n~a") logfile (status:exit-val state) tail))))
+
+	       errors)
+
+	      (if (pair? errors)
+		  (ly:error "Children ~a exited with errors." (map car errors)))
+
+	      ;; must overwrite individual entries
+	      (if (ly:get-option 'dump-profile)
+		  (dump-profile "lily-run-total" '(0 0) (profile-measurements)))
+
+	    (exit (if (null? errors) 0 1))))))
+	      
+	   
+  (if (string-or-symbol? (ly:get-option 'log-file))
+      (ly:stderr-redirect (format "~a.log" (ly:get-option 'log-file)) "w"))
+
+  
   (let ((failed (lilypond-all files)))
     (if (pair? failed)
 	(begin
 	  (ly:error (_ "failed files: ~S") (string-join failed))
 	  (exit 1))
 	(begin
+	  (ly:do-atexit)
 	  ;; HACK: be sure to exit with single newline
 	  (ly:message "")
 	  (exit 0)))))
 
 (define-public (lilypond-all files)
-  (if (ly:get-option 'read-file-list)
-      (set! files
-	    (filter (lambda (s)
-		      (> (string-length s) 0))
-		    (apply append
-			   (map (lambda (f) (string-split (ly:gulp-file f) #\nl))
-				files)))
-	    ))
+  
 
   (if (ly:get-option 'show-available-fonts)
       (begin
@@ -437,17 +637,63 @@ The syntax is the same as `define*-public'."
 	))
   
   (let* ((failed '())
+	 (separate-logs (ly:get-option 'separate-log-files))
+	 (do-measurements (ly:get-option 'dump-profile))
 	 (handler (lambda (key failed-file)
 		    (set! failed (append (list failed-file) failed)))))
 
+    (gc)
     (for-each
      (lambda (x)
-       (lilypond-file handler x)
-       (ly:clear-anonymous-modules)
-       (if (ly:get-option 'debug-gc)
-	   (dump-gc-protects)))
-     
+       (let*
+	   ((start-measurements (if do-measurements
+				    (profile-measurements)
+				    #f))
+	    (base (basename x ".ly"))
+	    (all-settings (ly:all-options)))
+
+	 (if separate-logs
+	     (ly:stderr-redirect (format "~a.log" base) "w"))
+	 (if (ly:get-option 'trace-memory-frequency) 
+	     (mtrace:start-trace  (ly:get-option 'trace-memory-frequency)))
+	 
+	 (lilypond-file handler x)
+	 (if start-measurements
+	     (dump-profile x start-measurements (profile-measurements)))
+
+	 (if (ly:get-option 'trace-memory-frequency)
+	     (begin
+	       (mtrace:stop-trace)
+	       (mtrace:dump-results base)))
+	  	 
+	 (for-each
+	  (lambda (s)
+	    (ly:set-option (car s) (cdr s)))
+	  all-settings)
+
+	 (ly:clear-anonymous-modules)
+	 (ly:set-option 'debug-gc-assert-parsed-dead #t)
+	 (gc)
+	 (ly:set-option 'debug-gc-assert-parsed-dead #f)
+
+	 
+	 (if (ly:get-option 'debug-gc)
+	     (dump-gc-protects)
+	     (if (= (random 40) 1)
+		 (ly:reset-all-fonts)))))
+
      files)
+
+    ;; we want the failed-files notice in the aggregrate logfile.
+    (if (ly:get-option 'separate-logs)
+	(ly:stderr-redirect
+	 (if (string-or-symbol? (ly:get-option 'log-file))
+	     (format "~a.log" (ly:get-option 'log-file))
+	     "/dev/tty") "a"))
+
+    (if (ly:get-option 'dump-profile)
+	(dump-profile "lily-run-total" '(0 0) (profile-measurements)))
+
     failed))
 
 (define (lilypond-file handler file-name)
@@ -455,18 +701,19 @@ The syntax is the same as `define*-public'."
 	 (lambda () (ly:parse-file file-name))
 	 (lambda (x . args) (handler x file-name))))
 
-(use-modules (scm editor)
-	     )
+(use-modules (scm editor))
 
 (define-public (gui-main files)
   (if (null? files)
       (gui-no-files-handler))
-  (let* ((base (basename (car files) ".ly"))
-	 (log-name (string-append base ".log")))
-    (if (not (ly:get-option 'gui))
-	(ly:message (_ "Redirecting output to ~a...") log-name))
-    (ly:stderr-redirect log-name "w")
-    (ly:message "# -*-compilation-*-")
+
+  (if (not (string? (ly:get-option 'log-file)))
+      (let* ((base (basename (car files) ".ly"))
+	     (log-name (string-append base ".log")))
+	(if (not (ly:get-option 'gui))
+	    (ly:message (_ "Redirecting output to ~a...") log-name))
+	(ly:stderr-redirect log-name "w")
+	(ly:message "# -*-compilation-*-"))
     
     (let ((failed (lilypond-all files)))
       (if (pair? failed)