>From 0cbadaf978dd24e0b904ab62d400e670e2688c79 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Sun, 17 Aug 2014 21:05:54 +0200
Subject: [PATCH 17/19] compiler-modules: Make bindings non-global.

This is a bit of a tricky change.  The reason is that the platform
defines the *default* standard, extended, internal and foldable bindings.
The final extended-bindings and standard-bindings, however, are possibly
overridden through declarations by the compiler.  The compiler takes the
bindings from the default bindings.

In order to make all this work without creating cyclic dependencies
between the backend/platform and the compiler, we've moved the definitions
of *all* bindings to the compiler.  The platform then set!s these to the
correct values.  This creates a new dependency between platform and
compiler, but that's okay (the backend also depends on the compiler, and
it exists at about the same level).  The compiler-syntax also makes use
of these bindings, so it makes sense to define a dependency for
compiler-syntax on the compiler.
---
 batch-driver.scm       |   93 +++++++++++++++++++++++++++++++++++++++++++++
 c-platform.scm         |   16 +++-----
 compiler-namespace.scm |    6 ---
 compiler-syntax.scm    |    4 +-
 compiler.scm           |   11 ++++++
 rules.make             |    7 +++-
 support.scm            |   98 +-----------------------------------------------
 7 files changed, 119 insertions(+), 116 deletions(-)

diff --git a/batch-driver.scm b/batch-driver.scm
index fd52bb9..2eafbe2 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -71,6 +71,99 @@
      (printf ";   known call sites: \t~s\n" sites) 
      (printf ";   database entries: \t~s\n" entries) ) ) )
 
+;;; Initialize analysis database:
+;;
+;; - Simply marks the symbols directly in the plist.
+;; - Does nothing after the first invocation, but we leave it this way to
+;;    have the option to add default entries for each new db.
+
+(define initialize-analysis-database
+  (let ((initial #t))
+    (lambda ()
+      (when initial
+	(for-each
+	 (lambda (s)
+	   (mark-variable s '##compiler#intrinsic 'standard)
+	   (when (memq s foldable-bindings)
+	     (mark-variable s '##compiler#foldable #t)))
+	 standard-bindings)
+	(for-each
+	 (lambda (s)
+	   (mark-variable s '##compiler#intrinsic 'extended)
+	   (when (memq s foldable-bindings)
+	     (mark-variable s '##compiler#foldable #t)))
+	 extended-bindings)
+	(for-each
+	 (lambda (s)
+	   (mark-variable s '##compiler#intrinsic 'internal))
+	 internal-bindings))
+      (set! initial #f))))
+
+;;; Display analysis database:
+
+(define display-analysis-database
+  (let ((names '((captured . cpt) (assigned . set) (boxed . box) (global . glo)
+		 (assigned-locally . stl)
+		 (contractable . con) (standard-binding . stb) (simple . sim)
+		 (inlinable . inl)
+		 (collapsable . col) (removable . rem) (constant . con)
+		 (inline-target . ilt) (inline-transient . itr)
+		 (undefined . und) (replacing . rpg) (unused . uud) (extended-binding . xtb)
+		 (inline-export . ilx) (hidden-refs . hrf)
+		 (value-ref . vvf)
+		 (customizable . cst) (has-unused-parameters . hup) (boxed-rest . bxr) ) ) 
+	(omit #f))
+    (lambda (db)
+      (unless omit
+	(set! omit 
+	  (append default-standard-bindings
+		  default-extended-bindings
+		  internal-bindings) ) )
+      (##sys#hash-table-for-each
+       (lambda (sym plist)
+	 (let ([val #f]
+	       (lval #f)
+	       [pval #f]
+	       [csites '()]
+	       [refs '()] )
+	   (unless (memq sym omit)
+	     (write sym)
+	     (let loop ((es plist))
+	       (if (pair? es)
+		   (begin
+		     (case (caar es)
+		       ((captured assigned boxed global contractable standard-binding assigned-locally
+				  collapsable removable undefined replacing unused simple inlinable inline-export
+				  has-unused-parameters extended-binding customizable constant boxed-rest hidden-refs)
+			(printf "\t~a" (cdr (assq (caar es) names))) )
+		       ((unknown)
+			(set! val 'unknown) )
+		       ((value)
+			(unless (eq? val 'unknown) (set! val (cdar es))) )
+		       ((local-value)
+			(unless (eq? val 'unknown) (set! lval (cdar es))) )
+		       ((potential-value)
+			(set! pval (cdar es)) )
+		       ((replacable home contains contained-in use-expr closure-size rest-parameter
+				    captured-variables explicit-rest)
+			(printf "\t~a=~s" (caar es) (cdar es)) )
+		       ((references)
+			(set! refs (cdar es)) )
+		       ((call-sites)
+			(set! csites (cdar es)) )
+		       (else (bomb "Illegal property" (car es))) )
+		     (loop (cdr es)) ) ) )
+	     (cond [(and val (not (eq? val 'unknown)))
+		    (printf "\tval=~s" (cons (node-class val) (node-parameters val))) ]
+		   [(and lval (not (eq? val 'unknown)))
+		    (printf "\tlval=~s" (cons (node-class lval) (node-parameters lval))) ]
+		   [(and pval (not (eq? val 'unknown)))
+		    (printf "\tpval=~s" (cons (node-class pval) (node-parameters pval)))] )
+	     (when (pair? refs) (printf "\trefs=~s" (length refs)))
+	     (when (pair? csites) (printf "\tcss=~s" (length csites)))
+	     (newline) ) ) )
+       db) ) ) )
+
 ;;; Compile a complete source file:
 
 (define (compile-source-file filename user-suppplied-options . options)
diff --git a/c-platform.scm b/c-platform.scm
index 841375b..edd8b70 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -31,7 +31,7 @@
 (declare
   (unit c-platform)
   (uses srfi-1 data-structures
-	optimizer support))
+	optimizer support compiler))
 
 ;; TODO: Remove these once everything's converted to modules
 (include "private-namespace")
@@ -47,7 +47,7 @@
      parameter-limit small-parameter-limit)
 
 (import chicken scheme srfi-1 data-structures
-	optimizer support)
+	optimizer support compiler)
 
 (include "tweaks")
 
@@ -120,8 +120,7 @@
 
 ;;; Standard and extended bindings:
 
-;; TODO: export this and remove it from compiler-namespace
-(define default-standard-bindings
+(set! default-standard-bindings
   '(not boolean? apply call-with-current-continuation eq? eqv? equal? pair? cons car cdr caar cadr
     cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar
     cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr!
@@ -142,8 +141,7 @@
     list-ref abs char-ready? peek-char list->string string->list
     current-input-port current-output-port) )
 
-;; TODO: export this and remove it from compiler-namespace
-(define default-extended-bindings
+(set! default-extended-bindings
   '(bitwise-and alist-cons xcons
     bitwise-ior bitwise-xor bitwise-not add1 sub1 fx+ fx- fx* fx/
     fx+? fx-? fx*? fx/? fxmod o fp/?
@@ -179,8 +177,7 @@
     current-error-port current-thread
     printf sprintf format fprintf get-keyword) )
 
-;; TODO: export this and remove it from compiler-namespace
-(define internal-bindings
+(set! internal-bindings
   '(##sys#slot ##sys#setslot ##sys#block-ref ##sys#block-set!
     ##sys#call-with-current-continuation ##sys#size ##sys#byte ##sys#setbyte
     ##sys#pointer? ##sys#generic-structure? ##sys#structure? ##sys#check-structure
@@ -234,8 +231,7 @@
     pointer-f32-ref pointer-f32-set!
     pointer-f64-ref pointer-f64-set!))
 
-;; TODO: export this and remove it from compiler-namespace
-(define foldable-bindings
+(set! foldable-bindings
   (lset-difference 
    eq?
    (lset-union eq? default-standard-bindings default-extended-bindings)
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index de57b48..146d478 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -26,11 +26,5 @@
 
 (private
  compiler
- default-extended-bindings
- default-standard-bindings
- extended-bindings
- foldable-bindings
- internal-bindings
  number-type
- standard-bindings
  unsafe) 
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
index e55ec5f..7883497 100644
--- a/compiler-syntax.scm
+++ b/compiler-syntax.scm
@@ -27,7 +27,7 @@
 (declare 
   (unit compiler-syntax)
   (uses srfi-1 data-structures
-	support) )
+	support compiler) )
 
 ;; TODO: Remove these once everything's converted to modules
 (include "private-namespace")
@@ -37,7 +37,7 @@
     (compiler-syntax-statistics)
 
 (import chicken scheme srfi-1 data-structures
-	support)
+	support compiler)
 
 (include "tweaks.scm")
 
diff --git a/compiler.scm b/compiler.scm
index 31d80de..892889d 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -297,10 +297,15 @@
 
      ;; Other, non-boolean, flags set by (batch) driver
      profiled-procedures import-libraries inline-max-size
+     extended-bindings standard-bindings
 
      ;; non-booleans set by the (batch) driver, and read by the (c) backend
      target-heap-size target-stack-size unit-name used-units
 
+     ;; bindings, set by the (c) platform
+     default-extended-bindings default-standard-bindings
+     internal-bindings foldable-bindings
+
      ;; Only read or called by the (c) backend
      foreign-declarations foreign-lambda-stubs foreign-stub-argument-types
      foreign-stub-argument-names foreign-stub-body foreign-stub-callback
@@ -412,6 +417,12 @@
 
 (define unlikely-variables '(unquote unquote-splicing))
 
+;;; Initial bindings.  These are supplied (set!) by the (c-)platform
+(define default-extended-bindings '())
+(define default-standard-bindings '())
+(define internal-bindings '())
+(define foldable-bindings '())
+
 ;;; Initialize globals:
 
 (define (initialize-compiler)
diff --git a/rules.make b/rules.make
index 97e4c58..84f45c8 100644
--- a/rules.make
+++ b/rules.make
@@ -506,7 +506,8 @@ batch-driver.c: batch-driver.scm compiler.scm compiler.import.scm \
 		c-backend.scm c-backend.import.scm \
 		support.scm support.import.scm
 c-platform.c: c-platform.scm optimizer.scm optimizer.import.scm \
-		support.scm support.import.scm
+		support.scm support.import.scm \
+		compiler.scm compiler.import.scm
 c-backend.c: c-backend.scm c-platform.scm c-platform.import.scm \
 		support.scm support.import.scm \
 		compiler.scm compiler.import.scm
@@ -515,7 +516,9 @@ compiler.c: compiler.scm scrutinizer.scm scrutinizer.import.scm \
 optimizer.c: optimizer.scm support.scm support.import.scm
 scrutinizer.c: scrutinizer.scm support.scm support.import.scm
 lfa2.c: lfa2.scm support.scm support.import.scm
-compiler-syntax.c: compiler-syntax.scm support.scm support.import.scm
+compiler-syntax.c: compiler-syntax.scm \
+		support.scm support.import.scm \
+		compiler.scm compiler.import.scm
 
 define profile-flags
 $(if $(filter $(basename $(1)),$(PROFILE_OBJECTS)),-profile)
diff --git a/support.scm b/support.scm
index 69b9d41..e2053ee 100644
--- a/support.scm
+++ b/support.scm
@@ -43,9 +43,8 @@
      constant? collapsable-literal? immediate? basic-literal?
      canonicalize-begin-body string->expr llist-length llist-match?
      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
+     profiling-prelude-exps db-get db-get-all db-put! collect! db-get-list
+     get-line get-line-2 display-line-number-database
      make-node node? node-class node-class-set!
      node-parameters node-parameters-set!
      node-subexpressions node-subexpressions-set! varnode qnode
@@ -407,33 +406,6 @@
 	   profile-lambda-list)))
 
 ;;; Database operations:
-;
-; - 'get' and 'put' shadow the routines in the extras-unit, we use low-level
-;   symbol-keyed hash-tables here.
-; - does currently nothing after the first invocation, but we leave it
-;   this way to have the option to add default entries for each new db.
-
-(define initialize-analysis-database
-  (let ((initial #t))
-    (lambda ()
-      (when initial
-	(for-each
-	 (lambda (s)
-	   (mark-variable s '##compiler#intrinsic 'standard)
-	   (when (memq s foldable-bindings)
-	     (mark-variable s '##compiler#foldable #t)))
-	 standard-bindings)
-	(for-each
-	 (lambda (s)
-	   (mark-variable s '##compiler#intrinsic 'extended)
-	   (when (memq s foldable-bindings)
-	     (mark-variable s '##compiler#foldable #t)))
-	 extended-bindings)
-	(for-each
-	 (lambda (s)
-	   (mark-variable s '##compiler#intrinsic 'internal))
-	 internal-bindings))
-      (set! initial #f))))
 
 (define (db-get db key prop)
   (let ((plist (##sys#hash-table-ref db key)))
@@ -487,72 +459,6 @@
    ##sys#line-number-database) )
 
 
-;;; Display analysis database:
-
-(define display-analysis-database
-  (let ((names '((captured . cpt) (assigned . set) (boxed . box) (global . glo)
-		 (assigned-locally . stl)
-		 (contractable . con) (standard-binding . stb) (simple . sim)
-		 (inlinable . inl)
-		 (collapsable . col) (removable . rem) (constant . con)
-		 (inline-target . ilt) (inline-transient . itr)
-		 (undefined . und) (replacing . rpg) (unused . uud) (extended-binding . xtb)
-		 (inline-export . ilx) (hidden-refs . hrf)
-		 (value-ref . vvf)
-		 (customizable . cst) (has-unused-parameters . hup) (boxed-rest . bxr) ) ) 
-	(omit #f))
-    (lambda (db)
-      (unless omit
-	(set! omit 
-	  (append default-standard-bindings
-		  default-extended-bindings
-		  internal-bindings) ) )
-      (##sys#hash-table-for-each
-       (lambda (sym plist)
-	 (let ([val #f]
-	       (lval #f)
-	       [pval #f]
-	       [csites '()]
-	       [refs '()] )
-	   (unless (memq sym omit)
-	     (write sym)
-	     (let loop ((es plist))
-	       (if (pair? es)
-		   (begin
-		     (case (caar es)
-		       ((captured assigned boxed global contractable standard-binding assigned-locally
-				  collapsable removable undefined replacing unused simple inlinable inline-export
-				  has-unused-parameters extended-binding customizable constant boxed-rest hidden-refs)
-			(printf "\t~a" (cdr (assq (caar es) names))) )
-		       ((unknown)
-			(set! val 'unknown) )
-		       ((value)
-			(unless (eq? val 'unknown) (set! val (cdar es))) )
-		       ((local-value)
-			(unless (eq? val 'unknown) (set! lval (cdar es))) )
-		       ((potential-value)
-			(set! pval (cdar es)) )
-		       ((replacable home contains contained-in use-expr closure-size rest-parameter
-				    captured-variables explicit-rest)
-			(printf "\t~a=~s" (caar es) (cdar es)) )
-		       ((references)
-			(set! refs (cdar es)) )
-		       ((call-sites)
-			(set! csites (cdar es)) )
-		       (else (bomb "Illegal property" (car es))) )
-		     (loop (cdr es)) ) ) )
-	     (cond [(and val (not (eq? val 'unknown)))
-		    (printf "\tval=~s" (cons (node-class val) (node-parameters val))) ]
-		   [(and lval (not (eq? val 'unknown)))
-		    (printf "\tlval=~s" (cons (node-class lval) (node-parameters lval))) ]
-		   [(and pval (not (eq? val 'unknown)))
-		    (printf "\tpval=~s" (cons (node-class pval) (node-parameters pval)))] )
-	     (when (pair? refs) (printf "\trefs=~s" (length refs)))
-	     (when (pair? csites) (printf "\tcss=~s" (length csites)))
-	     (newline) ) ) )
-       db) ) ) )       
-
-
 ;;; Node creation and -manipulation:
 
 ;; Note: much of this stuff will be overridden by the inline-definitions in "tweaks.scm".
-- 
1.7.10.4