[Sketch] OS-level tracing

.gitignore

@@ -33,3 +33,5 @@ lisp-kernel/darwinx8664/mach_exc_server.c
 lisp-kernel/darwinx8664/probes.h
 lisp-kernel/static-linuxppc/external-functions.h
 
+lisp-kernel/linuxx8664/probes.h
+lisp-kernel/linuxx8632/probes.h

lib/ccl-export-syms.lisp

@@ -482,6 +482,7 @@
      set-gc-notification-threshold
      *pending-gc-notification-hook*
      current-time-in-nanoseconds
+     create-perf-map
 
      population
      make-population

lib/perf-help.lisp

@@ -0,0 +1,78 @@
+;;; Copyright 2009 Clozure Associates
+;;; This file is part of Clozure CL.
+;;;
+;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU
+;;; Public License , known as the LLGPL and distributed with Clozure
+;;; CL as the file "LICENSE".  The LLGPL consists of a preamble and
+;;; the LGPL, which is distributed with Clozure CL as the file "LGPL".
+;;; Where these conflict, the preamble takes precedence.
+;;;
+;;; Clozure CL is referenced in the preamble as the "LIBRARY."
+;;;
+;;; The LLGPL is also available online at
+;;; http://opensource.franz.com/preamble.html
+
+(in-package "CCL")
+
+(defloadvar *readonly-remapped-p* nil)
+
+(defun %remap-readonly-area ()
+  (unless *readonly-remapped-p*
+    (impurify)
+    (let* ((a (do-consing-areas (a)
+                (when (eql (%fixnum-ref a target::area.code)
+                           ccl::area-readonly)
+                  (return a))))
+           (low (%int-to-ptr (ash (%fixnum-ref a target::area.low) target::fixnumshift)))
+           (active (ash (%fixnum-ref a target::area.active) target::fixnumshift))
+           (high (ash (%fixnum-ref a target::area.active) target::fixnumshift))
+           (tsize (- high (%ptr-to-int low)))
+           (lsize (- active (%ptr-to-int low)))
+           (p (#_malloc lsize)))
+      (#_memcpy p low lsize)
+      (#_munmap low tsize)
+      (#_mmap low
+              tsize
+              (logior #$PROT_READ #$PROT_WRITE #$PROT_EXEC)
+              (logior #$MAP_FIXED #$MAP_ANONYMOUS #$MAP_PRIVATE)
+              -1
+              0)
+      (#_memcpy low p lsize)
+      (#_mprotect low tsize (logior #$PROT_READ  #$PROT_EXEC))
+      (#_free p)
+      (setq *readonly-remapped-p* t))))
+
+(defun perf-lisp-function-name (f)
+  (let* ((name (function-name f)))
+    (if (and (symbolp name)
+	     (eq f (fboundp name)))
+      (with-standard-io-syntax
+	(format nil "~s" name))
+      (let ((str (format nil "~s" f)))
+	(subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space str)) 1)))))
+
+#+x86-target
+(defun collect-pure-functions ()
+  (purify)
+  (collect ((functions))
+    (%map-areas (lambda (o)
+                  (when (typep o
+                               #+x8664-target 'function-vector
+                               #-x8664-target 'function)
+                    (functions (function-vector-to-function o))))
+                :readonly)
+    (functions)))
+
+(defun write-perf-map (stream)
+  (dolist (f (collect-pure-functions))
+    (format stream "~16,'0x ~x ~a~%"
+            (logandc2 (%address-of f) target::fulltagmask)
+            (1+ (ash (1- (%function-code-words f)) target::word-shift))
+            (perf-lisp-function-name f))))
+
+(defun create-perf-map (&key path)
+  (let* ((pid (getpid))
+         (path (or path (format nil "/tmp/perf-~d.map" pid))))
+    (%remap-readonly-area)
+    (with-open-file (out path :direction :output :if-exists :supersede)
+      (write-perf-map out))))

lib/systems.lisp

@@ -229,6 +229,7 @@
     (dominance        "ccl:bin;dominance"        ("ccl:library;dominance.lisp"))
     (swank-loader     "ccl:bin;swank-loader"     ("ccl:library;swank-loader.lisp"))    
     (remote-lisp      "ccl:bin;remote-lisp"      ("ccl:library;remote-lisp.lisp" "ccl:lib;swink.lisp"))
+    (perf-help      "ccl:bin;perf-help"          ("ccl:library;perf-help.lisp"))
 
     (prepare-mcl-environment "ccl:bin;prepare-mcl-environment" ("ccl:lib;prepare-mcl-environment.lisp"))
     (defsystem        "ccl:tools;defsystem"      ("ccl:tools;defsystem.lisp"))

lisp-kernel/linuxx8632/Makefile

@@ -21,7 +21,7 @@ AS = as
 M4 = m4
 ASFLAGS = --32
 M4FLAGS = -DLINUX -DX86 -DX8632 -DHAVE_TLS
-CDEFINES = -DLINUX -D_REENTRANT -DX86 -DX8632 -D_GNU_SOURCE -DHAVE_TLS -DSVN_REVISION=$(SVN_REVISION) # -DGC_INTEGRITY_CHECKING -DDISABLE_EGC
+CDEFINES = -DLINUX -D_REENTRANT -DX86 -DX8632 -D_GNU_SOURCE -DHAVE_TLS -DSVN_REVISION=$(SVN_REVISION) -DUSE_DTRACE # -DGC_INTEGRITY_CHECKING -DDISABLE_EGC
 CDEBUG = -g
 COPT = -O2
 # Once in a while, -Wformat says something useful.  The odds are against that,
@@ -43,7 +43,7 @@ endif
 .s.o:
 	$(M4) $(M4FLAGS) -I../ $< | $(AS)  $(ASFLAGS) -o $@
 .c.o:
-	$(CC) -include ../$(PLATFORM_H) -c $< $(CDEFINES) $(CDEBUG) $(COPT) $(WFORMAT) -m32 -o $@
+	$(CC) -include ../$(PLATFORM_H) -c $< $(CDEFINES) $(CDEBUG) $(COPT) $(WFORMAT) -I. -m32 -o $@
 
 SPOBJ = pad.o x86-spjump32.o x86-spentry32.o x86-subprims32.o
 ASMOBJ = x86-asmutils32.o imports.o
@@ -53,7 +53,7 @@ COBJ  = pmcl-kernel.o gc-common.o x86-gc.o bits.o  x86-exceptions.o \
 	image.o thread_manager.o lisp-debug.o memory.o unix-calls.o
 
 DEBUGOBJ = lispdcmd.o plprint.o plsym.o xlbt.o x86_print.o
-KERNELOBJ= $(COBJ) x86-asmutils32.o  imports.o
+KERNELOBJ= $(COBJ) x86-asmutils32.o  imports.o probes.o
 
 SPINC =	lisp.s m4macros.m4 x86-constants.s x86-macros.s errors.s x86-uuo.s \
 	x86-constants32.s lisp_globals.s
@@ -79,12 +79,16 @@ USE_LINK_SCRIPT = # -T $(LINK_SCRIPT)
 
 $(SPOBJ): $(SPINC)
 $(ASMOBJ): $(SPINC)
-$(COBJ): $(CHEADERS)
+$(COBJ): $(CHEADERS) probes.h
 $(DEBUGOBJ): $(CHEADERS) lispdcmd.h
 
+probes.h: probes.d
+	dtrace -h -s $<
+probes.o: probes.d
+	dtrace -G -s $<
 
 cclean:
-	$(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../lx86cl
+	$(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../lx86cl probes.h
 
 clean:	cclean
 	$(RM) -f $(SPOBJ)

lisp-kernel/linuxx8664/Makefile

@@ -21,7 +21,7 @@ AS = as
 M4 = m4
 ASFLAGS = --64
 M4FLAGS = -DLINUX -DX86 -DX8664 -DHAVE_TLS
-CDEFINES = -DLINUX -D_REENTRANT -DX86 -DX8664 -D_GNU_SOURCE -DHAVE_TLS  -DSVN_REVISION=$(SVN_REVISION) #-DDISABLE_EGC -DUSE_FUTEX
+CDEFINES = -DLINUX -D_REENTRANT -DX86 -DX8664 -D_GNU_SOURCE -DHAVE_TLS  -DSVN_REVISION=$(SVN_REVISION) -DUSE_DTRACE #-DDISABLE_EGC -DUSE_FUTEX
 CDEBUG = -g
 COPT = -O2
 # Once in a while, -Wformat says something useful.  The odds are against that,
@@ -43,7 +43,7 @@ endif
 .s.o:
 	$(M4) $(M4FLAGS) -I../ $< | $(AS)  $(ASFLAGS) -o $@
 .c.o:
-	$(CC) -include ../$(PLATFORM_H) -c $< $(CDEFINES) $(CDEBUG) $(COPT) $(WFORMAT) -m64 -o $@
+	$(CC) -include ../$(PLATFORM_H) -c $< $(CDEFINES) $(CDEBUG) $(COPT) $(WFORMAT) -I. -m64 -o $@
 
 SPOBJ = pad.o x86-spjump64.o x86-spentry64.o x86-subprims64.o
 ASMOBJ = x86-asmutils64.o imports.o
@@ -53,7 +53,7 @@ COBJ  = pmcl-kernel.o gc-common.o x86-gc.o bits.o  x86-exceptions.o \
 	image.o thread_manager.o lisp-debug.o memory.o unix-calls.o
 
 DEBUGOBJ = lispdcmd.o plprint.o plsym.o xlbt.o x86_print.o
-KERNELOBJ= $(COBJ) x86-asmutils64.o  imports.o
+KERNELOBJ= $(COBJ) x86-asmutils64.o  imports.o probes.o
 
 SPINC =	lisp.s m4macros.m4 x86-constants.s x86-macros.s errors.s x86-uuo.s \
 	x86-constants64.s lisp_globals.s
@@ -79,12 +79,16 @@ USE_LINK_MAP = # -T ./elf_x86_64.x
 
 $(SPOBJ): $(SPINC)
 $(ASMOBJ): $(SPINC)
-$(COBJ): $(CHEADERS)
+$(COBJ): $(CHEADERS) probes.h
 $(DEBUGOBJ): $(CHEADERS) lispdcmd.h
 
+probes.h: probes.d
+	dtrace -h -s $<
+probes.o: probes.d
+	dtrace -G -s $<
 
 cclean:
-	$(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../lx86cl64
+	$(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../lx86cl64 probes.h
 
 clean:	cclean
 	$(RM) -f $(SPOBJ)

lisp-kernel/os-linux.h

@@ -22,3 +22,7 @@
 #define SIG_SUSPEND_THREAD (SIGRTMIN+6)
 #define SIG_KILL_THREAD (SIGRTMIN+7)
 #endif
+
+#ifdef USE_DTRACE
+#include "probes.h"
+#endif