>From 63bdf6b8a6c46f192829358c59878c7e38335a77 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Sun, 17 Aug 2014 16:51:45 +0200
Subject: [PATCH 14/19] compiler-modules: Move all profiling support code to
 support unit.

The declaration of the variables profile-info-vector-name and
profile-lambda-list were moved from compiler to support.
Initialisation of the profiling vector's name has been moved
into a new procedure: reset-profiler-info-vector-name!, which is
exported by support.  The code which generates the prelude to
initialise the profiling vector accessed these variables directly,
so to make things a little cleaner this code has been moved to
a single new procedure: profiling-prelude-exps.

There was an unused gensym call in batch-driver, probably originally
used to determine the profile vector's name.  This has been removed,
which caused one test to fail due to overly specific reliance on
gensymed names.  The scrutiny.expected file has been tweaked accordingly.
---
 batch-driver.scm        |   19 ++++---------------
 compiler-namespace.scm  |    2 --
 compiler.scm            |    4 +---
 support.scm             |   22 ++++++++++++++++++++--
 tests/scrutiny.expected |    2 +-
 5 files changed, 26 insertions(+), 23 deletions(-)

diff --git a/batch-driver.scm b/batch-driver.scm
index 8db9c14..e951e3c 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -475,29 +475,18 @@
 						     (import scheme chicken)
 						     ,@forms))
 				    forms))))
-		  [pvec (gensym)]
-		  [plen (length profile-lambda-list)]
-		  [exps (append
+		  (exps (append
 			 (map (lambda (ic) `(set! ,(cdr ic) ',(car ic))) immutable-constants)
 			 (map (lambda (n) `(##core#callunit ,n)) used-units)
 			 (if emit-profile
-			     `((set! ,profile-info-vector-name 
-				 (##sys#register-profile-info
-				  ',plen
-				  ',(and (not unit-name)
-					 (or profile-name #t)))))
+			     (profiling-prelude-exps (and (not unit-name)
+							  (or profile-name #t)))
 			     '() )
-			 (map (lambda (pl)
-				`(##sys#set-profile-info-vector!
-				  ,profile-info-vector-name
-				  ',(car pl)
-				  ',(cdr pl) ) )
-			      profile-lambda-list)
 			 exps0
 			 (if (and (not unit-name) (not dynamic))
 			     cleanup-forms
 			     '() )
-			 '((##core#undefined))) ] )
+			 '((##core#undefined))) ) )
 
 	     (when (pair? compiler-syntax-statistics)
 	       (with-debugging-output
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 317efbe..a07df6b 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -44,8 +44,6 @@
  inline-substitutions-enabled
  internal-bindings
  number-type
- profile-info-vector-name
- profile-lambda-list
  standard-bindings
  strict-variable-types
  unsafe) 
diff --git a/compiler.scm b/compiler.scm
index 7c5835d..74ad41a 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -403,8 +403,6 @@
 (define foreign-lambda-stubs '())
 (define foreign-callback-stubs '())
 (define external-variables '())
-(define profile-lambda-list '())
-(define profile-info-vector-name #f)
 (define external-to-pointer '())
 (define location-pointer-map '())
 (define pending-canonicalizations '())
@@ -428,7 +426,7 @@
   (if constant-table
       (vector-fill! constant-table '())
       (set! constant-table (make-vector constant-table-size '())) )
-  (set! profile-info-vector-name (make-random-name 'profile-info))
+  (reset-profile-info-vector-name!)
   (clear-real-name-table!)
   (if file-requirements
       (vector-fill! file-requirements '())
diff --git a/support.scm b/support.scm
index 13c04e4..215ee3c 100644
--- a/support.scm
+++ b/support.scm
@@ -42,8 +42,9 @@
      check-and-open-input-file close-checked-input-file fold-inner
      constant? collapsable-literal? immediate? basic-literal?
      canonicalize-begin-body string->expr llist-length llist-match?
-     expand-profile-lambda initialize-analysis-database db-get db-get-all
-     db-put! collect! db-get-list get-line get-line-2
+     expand-profile-lambda reset-profile-info-vector-name!
+     profiling-prelude-exps initialize-analysis-database
+     db-get db-get-all db-put! collect! db-get-list get-line get-line-2
      display-line-number-database display-analysis-database
      make-node node? node-class node-class-set!
      node-parameters node-parameters-set!
@@ -368,6 +369,11 @@
 
 
 ;;; Profiling instrumentation:
+(define profile-info-vector-name #f)
+(define (reset-profile-info-vector-name!)
+  (set! profile-info-vector-name (make-random-name 'profile-info)))
+
+(define profile-lambda-list '())
 (define profile-lambda-index 0)
 
 (define (expand-profile-lambda name llist body)
@@ -381,6 +387,18 @@
 	(##core#lambda () (##sys#apply (##core#lambda ,llist ,body) ,args))
 	(##core#lambda () (##sys#profile-exit ',index ,profile-info-vector-name)) ) ) ) )
 
+;; Get expressions which initialize and populate the profiling vector
+(define (profiling-prelude-exps profile-name)
+  `((set! ,profile-info-vector-name 
+      (##sys#register-profile-info
+       ',(length profile-lambda-list)
+       ',profile-name))
+    ,@(map (lambda (pl)
+	     `(##sys#set-profile-info-vector!
+	       ,profile-info-vector-name
+	       ',(car pl)
+	       ',(cdr pl) ) )
+	   profile-lambda-list)))
 
 ;;; Database operations:
 ;
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index f9df9f8..9752226 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -34,7 +34,7 @@ Warning: at toplevel:
   (scrutiny-tests.scm:25) in procedure call to `+', expected argument #2 of type `number', but was given an argument of type `symbol'
 
 Warning: at toplevel:
-  assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a158) (procedure car ((pair a158 *)) a158))'
+  assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a157) (procedure car ((pair a157 *)) a157))'
 
 Warning: at toplevel:
   expected in `let' binding of `g8' a single result, but were given 2 results
-- 
1.7.10.4