Merge branch 'procloc' of github.com:mflatt/ChezScheme

original commit: 84394bd01eb6bfe950ef426f17c6529b6fb90e94

LOG

@@ -993,3 +993,7 @@
     cmacros.ss, cpnanopass.ss, interpret.ss, library.ss,
     primdata.ss, prims.ss, gc.c, objects.stex, release_notes.stex
     misc.ms, mats/patch*, mats/root*
+- add generate-procedure-source-information
+    cmacros.ss, compile.ss, cpnanopass.ss, inspect.ss,
+    primdata.ss, prims.ss, misc.ms,
+    system.stex, release_notes.tex

csug/system.stex

@@ -1108,6 +1108,7 @@ cp0-effort-limit
 cp0-score-limit
 cp0-outer-unroll-limit
 generate-inspector-information
+generate-procedure-source-information
 compile-profile
 generate-interrupt-trap
 enable-cross-library-optimization
@@ -2393,6 +2394,21 @@ For example, if:
 is included in a file, generation of inspector information will be
 disabled only for the remainder of that particular file.
 
+%----------------------------------------------------------------------------
+\entryheader\label{desc:generate-procedure-source-information}
+\formdef{generate-procedure-source-information}{\categorythreadparameter}{generate-procedure-source-information}
+\listlibraries
+\endentryheader
+
+\noindent
+When \scheme{generate-inspector-information} is set to \scheme{#f} and
+this parameter is set to \scheme{#t}, then a source location is preserved
+for a procedure, even though other inspector information is not preserved.
+Source information provides a small amount of debugging support at a
+much lower cost in memory and object-file size than full inspector information.
+If this parameter is changed during the compilation of a file, the
+original value will be restored.
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{enable-cross-library-optimization}{\categorythreadparameter}{enable-cross-library-optimization}

mats/misc.ms

@@ -2015,6 +2015,30 @@
   (eqv? (profile-clear) (void))
 )
 
+(mat generate-procedure-source-information
+  (begin
+    (define the-source
+      (let ([sfd (make-source-file-descriptor "the-source.ss" (open-bytevector-input-port '#vu8()))])
+        (make-source-object sfd 10 20)))
+    (define (make-proc full-inspect?)
+      (parameterize ([generate-inspector-information full-inspect?]
+                     [generate-procedure-source-information #t])
+        (let ([e '(lambda (x) x)])
+          (compile (make-annotation e the-source e)))))
+    (define proc-i (make-proc #t))
+    (define proc-n (make-proc #f))
+    (and (procedure? proc-i)
+         (procedure? proc-n)))
+  (equal? (((inspect/object proc-i) 'code) 'source-object)
+          the-source)
+  (equal? (((inspect/object proc-n) 'code) 'source-object)
+          the-source)
+  (equal? ((((inspect/object proc-i) 'code) 'source) 'value)
+          '(lambda (x) x))
+  (equal? (((inspect/object proc-n) 'code) 'source)
+          #f)
+)
+
 (mat strip-fasl-file
   (error?
     (fasl-strip-options ratfink profile-source))

release_notes/release_notes.stex

@@ -58,6 +58,13 @@ Online versions of both books can be found at
 %-----------------------------------------------------------------------------
 \section{Functionality Changes}\label{section:functionality}
 
+\subsection{Procedure source location without inspector information (9.5.1)}
+
+When \scheme{generate-inspector-information} is set to \scheme{#f} and
+\scheme{generate-procedure-source-information} is set to \scheme{#t},
+source location information is preserved for a procedure, even though
+other inspector information is not preserved.
+
 \subsection{Procedure arity-mask adjustment and redirection (9.5.1)}
 
 The new procedure \scheme{make-arity-wrapper-procedure} creates a

s/cmacros.ss

@@ -1380,6 +1380,7 @@
    [ptr meta-level]
    [ptr compile-profile]
    [ptr generate-inspector-information]
+   [ptr generate-procedure-source-information]
    [ptr generate-profile-forms]
    [ptr optimize-level]
    [ptr subset-mode]

s/compile.ss

@@ -564,6 +564,7 @@
                    [cp0-score-limit (cp0-score-limit)]
                    [cp0-outer-unroll-limit (cp0-outer-unroll-limit)]
                    [generate-inspector-information (generate-inspector-information)]
+                   [generate-procedure-source-information (generate-procedure-source-information)]
                    [$compile-profile ($compile-profile)]
                    [generate-interrupt-trap (generate-interrupt-trap)]
                    [$optimize-closures ($optimize-closures)]

s/cpnanopass.ss

@@ -5370,6 +5370,7 @@
           (define-tc-parameter current-output-port current-output)
           (define-tc-parameter current-error-port current-error)
           (define-tc-parameter generate-inspector-information generate-inspector-information)
+          (define-tc-parameter generate-procedure-source-information generate-procedure-source-information)
           (define-tc-parameter generate-profile-forms generate-profile-forms)
           (define-tc-parameter $compile-profile compile-profile)
           (define-tc-parameter optimize-level optimize-level)
@@ -14012,6 +14013,11 @@
                                  (list->vector (ctci-rpi* ctci)))])
                         (vector-sort! (lambda (x y) (fx< (rp-info-offset x) (rp-info-offset y))) v)
                         v)))]
+                 [(and (generate-procedure-source-information)
+                       (info-lambda-src info)) =>
+                  (lambda (src)
+                    (include "types.ss")
+                    (make-code-info src #f #f #f #f))]
                  [else #f])
                (info-lambda-pinfo* info))
              (lambda (p) (c-trace (info-lambda-name info) code-size trace* p)))])

s/inspect.ss

@@ -2187,7 +2187,7 @@
               [len ($continuation-stack-length x)]
               [lpm ($continuation-return-livemask x)])
           (cond
-            [(and (code-info? info) (find-rpi offset (code-info-rpis info))) =>
+            [(and (code-info? info) (code-info-rpis info) (find-rpi offset (code-info-rpis info))) =>
              (lambda (rpi)
                (let ([cookie '(chocolate . chip)])
                  (let ([vals (make-vector len cookie)] [vars (make-vector len '())] [live (code-info-live info)])

s/patch.ss

@@ -14,6 +14,10 @@
 ;;; limitations under the License.
 
 (define ($make-arity-wrapper-procedure proc mask) proc)
+(define generate-procedure-source-information
+  (case-lambda
+   [() #f]
+   [(v) (void)]))
 
 (printf "loading ~s cross compiler~%" (constant machine-type-name))
 

s/primdata.ss

@@ -958,6 +958,7 @@
   (generate-inspector-information [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (generate-instruction-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (generate-interrupt-trap [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
+  (generate-procedure-source-information [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (generate-profile-forms [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (generate-wpo-files [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
   (gensym-count [sig [() -> (uint)] [(uint) -> (void)]] [flags])

s/prims.ss

@@ -1708,6 +1708,7 @@
                  [(x) (name (and x #t))]))
              (name init))])))
   (define-boolean-tc-parameter generate-inspector-information #t)
+  (define-boolean-tc-parameter generate-procedure-source-information #f)
   (define-boolean-tc-parameter generate-profile-forms #t)
   (define-boolean-tc-parameter $suppress-primitive-inlining #f)
 )