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

original commit: 552758ee584d142f5e92612676869cd4fde64ede

LOG

@@ -773,3 +773,11 @@
     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*
+- fix signature of bytevector-[u/s]16-native-set!
+    primdata.ss
+- fix enumerate signature 
+    primdata.ss
+- add generate-procedure-source-information
+    cmacros.ss, compile.ss, cpnanopass.ss, inspect.ss,
+    primdata.ss, prims.ss, misc.ms,
+    system.stex, release_notes.tex

c/globals.h

@@ -15,7 +15,7 @@
  */
 
 /* globals that do NOT need to be preserved in a saved heap.
- * they must be initalized each time the system is brought up. */
+ * they must be initialized each time the system is brought up. */
 
 /* gc.c */
 EXTERN IBOOL S_checkheap;

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

@@ -99,6 +99,13 @@ for triggering just-in-time conversions of a procedure's
 implementation while imposing a minimal overhead on calls to the
 procedure before or after conversion.
 
+\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{Record equality and hashing (9.5)}
 
 The new procedures \scheme{record-type-equal-procedure} and

s/cmacros.ss

@@ -1378,6 +1378,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

@@ -559,6 +559,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)
@@ -14009,6 +14010,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

@@ -13,7 +13,10 @@
 ;;; See the License for the specific language governing permissions and
 ;;; 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

@@ -367,7 +367,7 @@
   (bytevector-uint-ref [sig [(bytevector sub-index symbol sub-length) -> (uint)]] [flags true mifoldable discard])
   (bytevector-sint-ref [sig [(bytevector sub-index symbol sub-length) -> (sint)]] [flags true mifoldable discard])
   (bytevector-uint-set! [sig [(bytevector sub-index sub-uint symbol sub-length) -> (void)]] [flags true])
-  (bytevector-sint-set! [sig [(bytevector sub-index sub-uint symbol sub-length) -> (void)]] [flags true])
+  (bytevector-sint-set! [sig [(bytevector sub-index sub-sint symbol sub-length) -> (void)]] [flags true])
   (bytevector->uint-list [sig [(bytevector symbol sub-index) -> (list)]] [flags alloc])
   (bytevector->sint-list [sig [(bytevector symbol sub-index) -> (list)]] [flags alloc])
   (uint-list->bytevector [sig [(sub-list symbol sub-index) -> (bytevector)]] [flags alloc])
@@ -378,8 +378,8 @@
   (bytevector-s16-native-ref [sig [(bytevector sub-index) -> (s16)]] [flags true cp02])
   (bytevector-u16-set! [sig [(bytevector sub-index u16 symbol) -> (void)]] [flags true])
   (bytevector-s16-set! [sig [(bytevector sub-index s16 symbol) -> (void)]] [flags true])
-  (bytevector-u16-native-set! [sig [(bytevector sub-index symbol) -> (void)]] [flags true])
+  (bytevector-u16-native-set! [sig [(bytevector sub-index u16) -> (void)]] [flags true])
-  (bytevector-s16-native-set! [sig [(bytevector sub-index symbol) -> (void)]] [flags true])
+  (bytevector-s16-native-set! [sig [(bytevector sub-index s16) -> (void)]] [flags true])
   (bytevector-u32-ref [sig [(bytevector sub-index symbol) -> (u32)]] [flags true mifoldable discard])
   (bytevector-s32-ref [sig [(bytevector sub-index symbol) -> (s32)]] [flags true mifoldable discard])
   (bytevector-u32-native-ref [sig [(bytevector sub-index) -> (u32)]] [flags true cp02])
@@ -954,6 +954,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])
@@ -1247,7 +1248,7 @@
   (enable-interrupts [sig [() -> (uint)]] [flags true])
   (engine-block [sig [() -> (ptr)]] [flags])
   (engine-return [sig [(ptr ...) -> (bottom)]] [flags abort-op])
-  (enumerate [sig [(list) -> (ufixnum)]] [flags alloc])
+  (enumerate [sig [(list) -> (list)]] [flags alloc])
   (enum-set? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (environment? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (environment-mutable? [sig [(environment) -> (boolean)]] [flags pure mifoldable discard])
@@ -1461,8 +1462,8 @@
   (mutex-release [feature pthreads] [sig [(mutex) -> (void)]] [flags true])
   (mutex? [feature pthreads] [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (new-cafe [sig [() (procedure) -> (ptr ...)]] [flags])
-  (nonnegative? [sig [(number) -> (boolean)]] [flags pure mifoldable discard])
+  (nonnegative? [sig [(real) -> (boolean)]] [flags pure mifoldable discard])
-  (nonpositive? [sig [(number) -> (boolean)]] [flags pure mifoldable discard])
+  (nonpositive? [sig [(real) -> (boolean)]] [flags pure mifoldable discard])
   (number->string [sig [(number) (number sub-ufixnum) (number sub-ufixnum sub-ufixnum) -> (string)]] [flags alloc])  ; radix not restricted to 2, 4, 8, 16
   (object-counts [sig [() -> (ptr)]] [flags alloc])
   (oblist [sig [() -> (list)]] [flags alloc])

s/prims.ss

@@ -1706,6 +1706,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)
 )

scheme.1.in

@@ -14,7 +14,7 @@
 \fB{InstallPetiteName}\fP [ \fIoptions\fP ] \fIfile\fP ...
 .SH DESCRIPTION
 \*s is a programming language, based on R6RS Scheme, and a
-high-performance implementation of that langauge.
+high-performance implementation of that language.
 \*s compiles source expressions \fIincrementally\fP to machine code,
 providing the speed of compiled code in an interactive system.
 .LP