code tweaks

collects/tests/racket/path.rktl

@@ -5,6 +5,15 @@
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(test (string->path "x.zo") path-replace-suffix "x.rkt" ".zo")
+(test (string->path "x.zo") path-replace-suffix "x.rkt" #".zo")
+(test (string->path "x.zo") path-replace-suffix "x" #".zo")
+(test (string->path "x.o.zo") path-replace-suffix "x.o.rkt" #".zo")
+(test (string->path "x_rkt.zo") path-add-suffix "x.rkt" ".zo")
+(test (string->path "x_rkt.zo") path-add-suffix "x.rkt" #".zo")
+(test (string->path "x.zo") path-add-suffix "x" #".zo")
+(test (string->path "x.o_rkt.zo") path-add-suffix "x.o.rkt" #".zo")
+
 (define (make-/tf p exn?)
   (lambda args
     (with-handlers ([exn? (lambda (x) #f)]

src/racket/src/env.c

@@ -544,6 +544,10 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr
 
   scheme_starting_up = 1; /* in case it's not set already */
 
+#ifdef TIME_STARTUP_PROCESS
+  printf("pre-embedded @ %" PRIdPTR "\n", scheme_get_process_milliseconds());
+#endif
+
   scheme_add_embedded_builtins(env);
 
   boot_module_resolver();
@@ -1241,9 +1245,13 @@ Scheme_Env *scheme_get_bucket_home(Scheme_Bucket *b)
 void scheme_set_bucket_home(Scheme_Bucket *b, Scheme_Env *e)
 {
   if (!((Scheme_Bucket_With_Home *)b)->home_link) {
-    Scheme_Object *link;
+    if (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_STRONG_HOME_LINK)
-    link = scheme_get_home_weak_link(e);
+      ((Scheme_Bucket_With_Home *)b)->home_link = (Scheme_Object *)e;
-    ((Scheme_Bucket_With_Home *)b)->home_link = link;
+    else {
+      Scheme_Object *link;
+      link = scheme_get_home_weak_link(e);
+      ((Scheme_Bucket_With_Home *)b)->home_link = link;
+    }
   }
 }
 
@@ -1302,11 +1310,11 @@ scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym,
     b = scheme_bucket_from_table(env->toplevel, (const char *)sym);
     b->val = obj;
     ASSERT_IS_VARIABLE_BUCKET(b);
-    scheme_set_bucket_home(b, env);
     if (constant && scheme_defining_primitives) {
       ((Scheme_Bucket_With_Flags *)b)->id = builtin_ref_counter++;
-      ((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_HAS_REF_ID | GLOB_IS_CONST);
+      ((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_HAS_REF_ID | GLOB_IS_CONST | GLOB_STRONG_HOME_LINK);
     }
+    scheme_set_bucket_home(b, env);
   } else
     scheme_add_to_table(env->syntax, (const char *)sym, obj, constant);
 }

src/racket/src/jit.c

@@ -1132,7 +1132,8 @@ static int generate_flonum_local_boxing(mz_jit_state *jitter, int pos, int local
 int scheme_generate_flonum_local_unboxing(mz_jit_state *jitter, int push, int no_store, int extfl)
 /* Move FPR0 onto C stack */
 {
-  int sz, fpr0;
+  int sz;
+  int fpr0 USED_ONLY_SOMETIMES;
 
   sz = MZ_FPUSEL(extfl, 2 * sizeof(double), sizeof(double));
 

src/racket/src/lightning/i386/core-common.h

@@ -245,7 +245,7 @@ static jit_state 			_jit;
 # if defined(JIT_X86_64)
 #  define jit_extr_i_l(d, rs)		(jit_lshi_l((d), (rs), 32), jit_rshi_l((d), (d), 32))
 # else
-#  define jit_extr_i_l(d, rs)		0
+#  define jit_extr_i_l(d, rs)		/* empty */
 # endif
 #endif
 #ifndef jit_extr_c_ul
@@ -258,7 +258,7 @@ static jit_state 			_jit;
 # if defined(JIT_X86_64)
 #  define jit_extr_i_ul(d, rs)		jit_andi_l((d), (rs), 0xFFFFFFFFUL)
 # else
-#  define jit_extr_i_ul(d, rs)		0
+#  define jit_extr_i_ul(d, rs)		/* empty */
 # endif
 #endif
 #endif

src/racket/src/startup.inc

@@ -261,7 +261,7 @@
 "(if(and(relative-path? program)"
 "(let-values(((base name dir?)(split-path program)))"
 "(eq? base 'relative)))"
-"(let((paths-str(environment-variables-get(current-environment-variables)"
+"(let((paths-str(environment-variables-ref(current-environment-variables)"
 " #\"PATH\"))"
 "(win-add(lambda(s)(if(eq?(system-type) 'windows) "
 " (cons (bytes->path #\".\") s) "
@@ -593,38 +593,41 @@
 "(when(not base)"
 " (raise-mismatch-error who \"cannot add a suffix to a root path: \" s))"
 "(values base name))))"
+"(define-values(path-adjust-suffix)"
+"(lambda(name sep rest-bytes s sfx)"
+"(let-values(((base name)(check-suffix-call s sfx name)))"
+"(define bs(path-element->bytes name))"
+"(define finish"
+"(lambda(i sep i2)"
+"(bytes->path-element"
+"(bytes-append"
+"(subbytes bs 0 i)"
+" sep"
+"(rest-bytes bs i2)"
+"(if(string? sfx)"
+"(string->bytes/locale sfx(char->integer #\\?))"
+" sfx))"
+"(if(path-for-some-system? s)"
+"(path-convention-type s)"
+"(system-path-convention-type)))))"
+"(let((new-name(letrec-values(((loop)"
+"(lambda(i)"
+"(if(zero? i)"
+" (finish (bytes-length bs) #\"\" (bytes-length bs))"
+"(let-values(((i)(sub1 i)))"
+"(if(eq?(char->integer #\\.)(bytes-ref bs i))"
+"(finish i sep(add1 i))"
+"(loop i)))))))"
+"(loop(bytes-length bs)))))"
+"(if(path? base)"
+"(build-path base new-name)"
+" new-name)))))"
 "(define-values(path-replace-suffix)"
 "(lambda(s sfx)"
-"(let-values(((base name)(check-suffix-call s sfx 'path-replace-suffix)))"
+" (path-adjust-suffix 'path-replace-suffix #\"\" (lambda (bs i) #\"\") s sfx)))"
-"(let((new-name(bytes->path-element"
-" (regexp-replace #rx#\"(?:[.][^.]*|)$\""
-"(path-element->bytes name)"
-"(if(string? sfx)"
-"(string->bytes/locale sfx(char->integer #\\?))"
-" sfx))"
-"(if(path-for-some-system? s)"
-"(path-convention-type s)"
-"(system-path-convention-type)))))"
-"(if(path? base)"
-"(build-path base new-name)"
-" new-name)))))"
 "(define-values(path-add-suffix)"
 "(lambda(s sfx)"
-"(let-values(((base name)(check-suffix-call s sfx 'path-add-suffix)))"
+" (path-adjust-suffix 'path-replace-suffix #\"_\" subbytes s sfx)))"
-"(let((new-name(bytes->path-element"
-"(bytes-append"
-" (regexp-replace* #rx#\"[.]\""
-"(path-element->bytes name)"
-" \"_\")"
-"(if(string? sfx)"
-"(string->bytes/locale sfx(char->integer #\\?))"
-" sfx))"
-"(if(path-for-some-system? s)"
-"(path-convention-type s)"
-"(system-path-convention-type)))))"
-"(if(path? base)"
-"(build-path base new-name)"
-" new-name)))))"
 "(define-values(load/use-compiled)"
 "(lambda(f)((current-load/use-compiled) f #f)))"
 "(define-values(find-library-collection-paths)"
@@ -636,7 +639,7 @@
 "(cons-if(lambda(f r)(if f(cons f r) r))))"
 "(path-list-string->path-list"
 "(if user-too?"
-"(let((c(environment-variables-get(current-environment-variables)"
+"(let((c(environment-variables-ref(current-environment-variables)"
 " #\"PLTCOLLECTS\")))"
 "(if c"
 "(bytes->string/locale c #\\?)"
@@ -874,12 +877,14 @@
 "(define-values(-prev-relto-dir) #f)"
 "(define(split-relative-string s coll-mode?)"
 "(let((l(let loop((s s))"
+"(let((len(string-length s)))"
+"(let iloop((i 0))"
 "(cond"
-" ((regexp-match #rx\"^(.*?)/(.*)$\" s)"
+"((= i len)(list s))"
-" =>(lambda(m)"
+"((char=? #\\/(string-ref s i))"
-"(cons(cadr m)"
+"(cons(substring s 0 i)"
-"(loop(caddr m)))))"
+"(loop(substring s(add1 i)))))"
-"(else(list s))))))"
+"(else(iloop(add1 i)))))))))"
 "(if coll-mode?"
 " l"
 "(let loop((l l))"

src/racket/src/startup.rktl

@@ -316,7 +316,7 @@
 	(if (and (relative-path? program)
 		 (let-values ([(base name dir?) (split-path program)])
 		   (eq? base 'relative)))
-	    (let ([paths-str (environment-variables-get (current-environment-variables)
+	    (let ([paths-str (environment-variables-ref (current-environment-variables)
                                                         #"PATH")]
 		  [win-add (lambda (s) (if (eq? (system-type) 'windows) 
 					   (cons (bytes->path #".") s) 
@@ -684,41 +684,44 @@
         (when (not base)
           (raise-mismatch-error who "cannot add a suffix to a root path: " s))
         (values base name))))
-        
+
+  (define-values (path-adjust-suffix)
+    (lambda (name sep rest-bytes s sfx)
+      (let-values ([(base name) (check-suffix-call s sfx name)])
+        (define bs (path-element->bytes name))
+        (define finish
+          (lambda (i sep i2)
+            (bytes->path-element
+             (bytes-append
+              (subbytes bs 0 i)
+              sep
+              (rest-bytes bs i2)
+              (if (string? sfx)
+                  (string->bytes/locale sfx (char->integer #\?))
+                  sfx))
+             (if (path-for-some-system? s)
+                 (path-convention-type s)
+                 (system-path-convention-type)))))
+        (let ([new-name (letrec-values ([(loop)
+                                         (lambda (i)
+                                           (if (zero? i)
+                                               (finish (bytes-length bs) #"" (bytes-length bs))
+                                               (let-values ([(i) (sub1 i)])
+                                                 (if (eq? (char->integer #\.) (bytes-ref bs i))
+                                                     (finish i sep (add1 i))
+                                                     (loop i)))))])
+                          (loop (bytes-length bs)))])
+          (if (path? base)
+              (build-path base new-name)
+              new-name)))))
 
   (define-values (path-replace-suffix)
     (lambda (s sfx)
-      (let-values ([(base name) (check-suffix-call s sfx 'path-replace-suffix)])
+      (path-adjust-suffix 'path-replace-suffix #"" (lambda (bs i) #"") s sfx)))
-        (let ([new-name (bytes->path-element
-                         (regexp-replace #rx#"(?:[.][^.]*|)$"
-                                         (path-element->bytes name)
-                                         (if (string? sfx)
-                                             (string->bytes/locale sfx (char->integer #\?))
-                                             sfx))
-                         (if (path-for-some-system? s)
-                             (path-convention-type s)
-                             (system-path-convention-type)))])
-          (if (path? base)
-              (build-path base new-name)
-              new-name)))))
 
   (define-values (path-add-suffix)
     (lambda (s sfx)
-      (let-values ([(base name) (check-suffix-call s sfx 'path-add-suffix)])
+      (path-adjust-suffix 'path-replace-suffix #"_" subbytes s sfx)))
-        (let ([new-name (bytes->path-element
-                         (bytes-append
-                          (regexp-replace* #rx#"[.]"
-                                           (path-element->bytes name)
-                                           "_")
-                          (if (string? sfx)
-                              (string->bytes/locale sfx (char->integer #\?))
-                              sfx))
-                         (if (path-for-some-system? s)
-                             (path-convention-type s)
-                             (system-path-convention-type)))])
-          (if (path? base)
-              (build-path base new-name)
-              new-name)))))
 
   (define-values (load/use-compiled)
     (lambda (f) ((current-load/use-compiled) f #f)))
@@ -732,7 +735,7 @@
 	    [cons-if (lambda (f r) (if f (cons f r) r))])
 	(path-list-string->path-list
 	 (if user-too?
-             (let ([c (environment-variables-get (current-environment-variables)
+             (let ([c (environment-variables-ref (current-environment-variables)
                                                  #"PLTCOLLECTS")])
                (if c
                    (bytes->string/locale c #\?)
@@ -1001,12 +1004,14 @@
 
   (define (split-relative-string s coll-mode?)
     (let ([l (let loop ([s s])
-               (cond
+               (let ([len (string-length s)])
-                [(regexp-match #rx"^(.*?)/(.*)$" s)
+                 (let iloop ([i 0])
-                 => (lambda (m)
+                   (cond
-                      (cons (cadr m)
+                    [(= i len) (list s)]
-                            (loop (caddr m))))]
+                    [(char=? #\/ (string-ref s i))
-                [else (list s)]))])
+                     (cons (substring s 0 i)
+                           (loop (substring s (add1 i))))]
+                    [else (iloop (add1 i))]))))])
       (if coll-mode?
           l
           (let loop ([l l])