* Can load altcogen.

src/altmakefile.ss

@@ -1,327 +0,0 @@
-#!/usr/bin/env ikarus -b ikarus.boot --script
-
-;;; 9.1: * starting with libnumerics
-;;; 9.0: * graph marks for both reader and writer 
-;;;      * circularity detection during read 
-;;; 8.1: * using chez-style io ports
-;;; 6.9: * creating a *system* environment
-;;; 6.8: * creating a core-primitive form in the expander
-;;; 6.2: * side-effects now modify the dirty-vector
-;;;      * added bwp-object?
-;;;      * added pointer-value
-;;;      * added tcbuckets
-;;; 6.1: * added case-lambda, dropped lambda
-;;; 6.0: * basic compiler
-
-
-
-(define macros
-  '(|#primitive| lambda case-lambda set! quote begin define if letrec
-    foreign-call 
-    quasiquote unquote unquote-splicing
-    define-syntax identifier-syntax let-syntax letrec-syntax
-    fluid-let-syntax alias meta eval-when with-implicit with-syntax
-    type-descriptor
-    syntax-case syntax-rules module $module import $import import-only
-    syntax quasisyntax unsyntax unsyntax-splicing datum
-    let let* let-values cond case define-record or and when unless do
-    include parameterize trace untrace trace-lambda trace-define
-    rec
-    time))
-
-
-
-(define public-primitives
-  '(
-    
-    null? pair? char? fixnum? symbol? gensym? string? vector? list?
-    boolean? procedure?  not eof-object eof-object? bwp-object?
-    void fx= fx< fx<= fx> fx>= fxzero?  fx+ fx- fx* fxadd1 fxsub1
-    fxquotient fxremainder fxmodulo fxsll fxsra fxlognot fxlogor
-    fxlogand fxlogxor integer->char char->integer char=? char<?
-    char<=? char>? char>=?  cons car cdr set-car! set-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 list list*
-    make-list length list-ref append make-vector vector-ref
-    vector-set! vector-length vector vector->list list->vector
-    make-string string-ref string-set! string-length string
-    string->list list->string uuid string-append substring string=?
-    string<?  string<=? string>? string>=? remprop putprop getprop
-    property-list $$apply apply map for-each andmap ormap memq memv assq
-    assv assoc eq? eqv? equal? reverse string->symbol symbol->string
-    top-level-value set-top-level-value!  top-level-bound?
-    gensym gensym-count gensym-prefix print-gensym
-    gensym->unique-string call-with-values values make-parameter
-    dynamic-wind display write print-graph fasl-write printf fprintf format
-    print-error read-token read comment-handler error warning exit call/cc
-    error-handler eval current-eval compile alt-compile compile-file
-    alt-compile-file
-    new-cafe load system expand sc-expand current-expand expand-mode
-    environment? interaction-environment identifier?
-    free-identifier=? bound-identifier=? literal-identifier=?
-    datum->syntax-object syntax-object->datum syntax-error
-    syntax->list generate-temporaries record? record-set! record-ref
-    record-length record-type-descriptor make-record-type
-    record-printer record-name record-field-accessor
-    record-field-mutator record-predicate record-constructor
-    record-type-name record-type-symbol record-type-field-names
-    hash-table? make-hash-table get-hash-table put-hash-table!
-    assembler-output $make-environment 
-    command-line-arguments port? input-port? output-port?
-    make-input-port make-output-port make-input/output-port
-    port-handler port-input-buffer port-input-index port-input-size
-    port-output-buffer port-output-index port-output-size
-    set-port-input-index! set-port-input-size!
-    set-port-output-index! set-port-output-size!  port-name
-    input-port-name output-port-name write-char read-char
-    unread-char peek-char newline reset-input-port!
-    flush-output-port close-input-port close-output-port
-    console-input-port current-input-port standard-output-port
-    standard-error-port console-output-port current-output-port
-    open-output-file open-input-file open-output-string
-    with-output-to-string
-    get-output-string with-output-to-file call-with-output-file
-    open-input-string
-    with-input-from-file call-with-input-file date-string
-    file-exists? delete-file + - add1 sub1 * / expt 
-    quotient+remainder quotient remainder modulo number? positive?
-    negative? zero? number->string logand = < > <= >=
-    last-pair
-    make-guardian weak-cons collect 
-    interrupt-handler
-    time-it 
-    posix-fork fork waitpid env environ
-    pretty-print
-    even? odd? member char-whitespace? char-alphabetic?
-    char-downcase max min complex? real? rational? 
-    exact? inexact? integer?
-    string->number exact->inexact
-
-    flonum? flonum->string string->flonum bignum?
-    sin cos atan sqrt
-    ))
-
-(define system-primitives
-  '(
-    $primitive-call/cc
-    $closure-code immediate? $unbound-object? $forward-ptr?
-    pointer-value primitive-ref primitive-set!  $fx= $fx< $fx<= $fx>
-    $fx>= $fxzero?  $fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient
-    $fxremainder $fxmodulo $fxsll $fxsra $fxlognot $fxlogor
-    $fxlogand $fxlogxor $fixnum->char $char->fixnum $char= $char<
-    $char<= $char> $char>= $car $cdr $set-car! $set-cdr!
-    $make-vector $vector-ref $vector-set! $vector-length
-    $make-string $string-ref $string-set!  $string-length $string
-    $symbol-string $symbol-unique-string $symbol-value
-    $set-symbol-string! $set-symbol-unique-string!
-    $set-symbol-value!  $make-symbol $set-symbol-plist!
-    $symbol-plist $sc-put-cte $record? $record/rtd? $record-set!
-    $record-ref $record-rtd $make-record $record $base-rtd $code?
-    $code-reloc-vector $code-freevars $code-size $code-ref
-    $code-set!  $code->closure list*->code* make-code code?
-    set-code-reloc-vector!  code-reloc-vector code-freevars
-    code-size code-ref code-set!  $frame->continuation $fp-at-base
-    $current-frame $arg-list $seal-frame-and-call
-    $make-call-with-values-procedure $make-values-procedure
-    do-overflow $make-tcbucket $tcbucket-next $tcbucket-key
-    $tcbucket-val $set-tcbucket-next!  $set-tcbucket-val!
-    $set-tcbucket-tconc!  
-    call/cf
-    trace-symbol! untrace-symbol!  make-traced-procedure
-    fixnum->string 
-    $interrupted? $unset-interrupted! $do-event
-    $fasl-read
-    ;;; TODO: must open-code
-
-    $make-port/input $make-port/output $make-port/both
-    $make-input-port $make-output-port $make-input/output-port
-    $port-handler $port-input-buffer $port-input-index
-    $port-input-size $port-output-buffer $port-output-index
-    $port-output-size $set-port-input-index! $set-port-input-size!
-    $set-port-output-index! $set-port-output-size!
-
-    ;;; better open-code
-
-    $write-char $read-char $peek-char $unread-char
-
-    ;;; never open-code 
-
-    $reset-input-port! $close-input-port $close-output-port
-    $flush-output-port *standard-output-port* *standard-error-port*
-    *current-output-port* *standard-input-port* *current-input-port*
-    
-    ;;; 
-    compiler-giveup-tally
-    ))
- 
-
-
-(define (whack-system-env setenv?)
-  (define add-prim
-    (lambda (x)
-      (let ([g (gensym (symbol->string x))])
-        (putprop x '|#system| g)
-        (putprop g '*sc-expander* (cons 'core-primitive x)))))
-  (define add-macro
-    (lambda (x)
-      (let ([g (gensym (symbol->string x))]
-            [e (getprop x '*sc-expander*)])
-        (when e 
-          (putprop x '|#system| g)
-          (putprop g '*sc-expander* e)))))
-  (define (foo)
-    (eval 
-      `(begin
-         (define-syntax compile-time-date-string
-           (lambda (x)
-             #'(quote ,(date-string))))
-         (define-syntax public-primitives
-           (lambda (x)
-             #'(quote ,public-primitives)))
-         (define-syntax system-primitives
-           (lambda (x)
-             #'(quote ,system-primitives))) 
-         (define-syntax macros
-           (lambda (x)
-             #'(quote ,macros))))))
-  (set! system-env ($make-environment '|#system| #t))
-  (for-each add-macro macros)
-  (for-each add-prim public-primitives)
-  (for-each add-prim system-primitives)
-  (if setenv?
-      (parameterize ([interaction-environment system-env])
-        (foo))
-      (foo)))
-
-
-
-(when (eq? "" "")
-  (error #f "SEVERELY OUT OF DATE!\n")
-  (load "chez-compat.ss")
-  (set! primitive-ref top-level-value)
-  (set! primitive-set! set-top-level-value!)
-  (set! chez-expand sc-expand)
-  (set! chez-current-expand current-expand)
-  (printf "loading psyntax.pp ...\n")
-  (load "psyntax-7.1.pp")
-  (chez-current-expand
-    (lambda (x . args)
-      (apply chez-expand (sc-expand x) args)))
-  (whack-system-env #f)
-  (printf "loading psyntax.ss ...\n")
-  (load "psyntax-7.1-6.9.ss")
-  (chez-current-expand
-    (lambda (x . args)
-      (apply chez-expand (sc-expand x) args)))
-  (whack-system-env #t)
-  (printf "ok\n")
-  (load "libassembler-compat-6.7.ss") ; defines make-code etc.
-  (load "libintelasm-6.9.ss") ; uses make-code, etc.
-  (load "libfasl-6.7.ss") ; uses code? etc.
-  (load "libcompile-8.1.ss") ; uses fasl-write
-)
-
-
-(whack-system-env #t)
-
-(define scheme-library-files
-  '(["libhandlers.ss"   "libhandlers.fasl"  p0 chaitin]
-    ["libcontrol0.ss"   "libcontrol0.fasl"  p0 chaitin] 
-    ["libcontrol1.ss"   "libcontrol1.fasl"  p0 chaitin]
-    ["libcollect.ss"    "libcollect.fasl"   p0 chaitin]
-    ["librecord.ss"     "librecord.fasl"    p0 chaitin]
-    ["libcxr.ss"        "libcxr.fasl"       p0 chaitin]
-    ["libnumerics.ss"   "libnumerics.fasl"  p0 chaitin]
-    ["libguardians.ss"  "libguardians.fasl" p0 chaitin]
-    ["libcore.ss"       "libcore.fasl"      p0 chaitin]
-    ["libchezio.ss"     "libchezio.fasl"    p0 chaitin]
-    ["libhash.ss"       "libhash.fasl"      p0 chaitin]
-    ["libwriter.ss"     "libwriter.fasl"    p0 chaitin]
-    ["libtokenizer.ss"  "libtokenizer.fasl" p0 chaitin]
-    ["libassembler.ss"  "libassembler.fasl" p0 chaitin]
-    ["libintelasm.ss"   "libintelasm.fasl"  p0 chaitin]
-    ["libfasl.ss"       "libfasl.fasl"      p0 chaitin]
-    ["libtrace.ss"      "libtrace.fasl"     p0 chaitin]
-    ["libcompile.ss"    "libcompile.fasl"   p1 chaitin]
-    ["psyntax-7.1.ss"   "psyntax.fasl"      p0 chaitin]
-    ["libpp.ss"         "libpp.fasl"        p0 chaitin]
-    ["libcafe.ss"       "libcafe.fasl"      p0 chaitin] 
-    ["libposix.ss"      "libposix.fasl"     p0 chaitin]
-    ["libtimers.ss"     "libtimers.fasl"    p0 chaitin] 
-    ["libtoplevel.ss"   "libtoplevel.fasl"  p0 chaitin]
-    ))
-
-
-(define (read-file ifile)
-  (with-input-from-file ifile
-    (lambda ()
-      (let f ()
-        (let ([x (read)])
-          (if (eof-object? x)
-              '()
-              (cons x (f))))))))
-
-(define (expand-file ifile)
-  (map sc-expand (read-file ifile)))
-
-(define (compile-library ifile ofile which-compile)
-  (parameterize ([assembler-output #f] 
-                 [expand-mode 'bootstrap]
-                 [interaction-environment system-env])
-     (let ([proc 
-            (case which-compile
-              [(onepass) compile-file]
-              [(chaitin) alt-compile-file]
-              [else (error 'compile-library "unknown compile ~s"
-                           which-compile)])])
-      (printf "compiling ~a ... \n" ifile)
-      (proc ifile ofile 'replace))))
-
-
-
-;(let ()
-;  (define (compile-all who)
-;    (for-each
-;      (lambda (x)
-;        (when (eq? who (caddr x))
-;          (compile-library (car x) (cadr x) (cadddr x))))
-;      scheme-library-files))
-;  (define (time x) x)
-;  (fork
-;    (lambda (pid) 
-;      (time (compile-all 'p1))
-;      (unless (fxzero? (waitpid pid))
-;        (exit -1)))
-;    (lambda ()
-;      (time (compile-all 'p0))
-;      (exit))))
-
-(for-each 
-  (lambda (x)
-    (compile-library (car x) (cadr x) (cadddr x)))
-  scheme-library-files)
-
-(define (join s ls)
-  (cond
-    [(null? ls) ""]
-    [else
-     (let ([str (open-output-string)])
-       (let f ([a (car ls)] [d (cdr ls)])
-         (cond
-           [(null? d)
-            (display a str)
-            (get-output-string str)]
-           [else
-            (display a str)
-            (display s str)
-            (f (car d) (cdr d))])))]))
-   
-
-(system
-  (format "cat ~a > ikarus.boot"
-          (join " " (map cadr scheme-library-files))))
-
-(printf "Happy Happy Joy Joy!\n")
-;(#%compiler-giveup-tally)
-; vim:syntax=scheme

src/ikarus.compiler.ss

@@ -5318,6 +5318,12 @@
 
 (define assembler-output (make-parameter #f))
 
+
+(define eval-core
+  (lambda (x) ((compile-core-expr x))))
+
+(include "libaltcogen.ss")
+
 (define current-primitive-locations
   (let ([plocs (lambda (x) #f)])
     (case-lambda
@@ -5329,12 +5335,6 @@
              (refresh-cached-labels!))
            (error 'current-primitive-locations "~s is not a procedure" p))])))
 
-(define eval-core
-  (lambda (x) ((compile-core-expr x))))
-
-(include "libaltcogen.ss")
-
-
 )
 
 

src/ikarus.intel-assembler.ss

@@ -336,6 +336,8 @@
                (CODE c (ModRM 2 /d a1 (IMM32 a0 ac)))]
               [(and (imm8? a1) (reg? a0))
                (CODE c (ModRM 1 /d a0 (IMM8 a1 ac)))]
+              [(and (imm? a1) (reg? a0))
+               (CODE c (ModRM 2 /d a0 (IMM32 a1 ac)))]
               [(and (reg? a0) (reg? a1)) 
                (CODE c (ModRM 1 /d '/4 (SIB 0 a0 a1 (IMM8 0 ac))))]
               [else (error 'CODE/digit "unhandled ~s ~s" a0 a1)])))]

src/libaltcogen.ss

@@ -1244,6 +1244,73 @@
   #|ListyGraphs|#)
 
 
+(module IntegerGraphs 
+  (empty-graph add-edge! empty-graph? print-graph node-neighbors
+   delete-node!)
+  (import IntegerSet)
+  ;;;
+  (define-record graph (ls))
+  ;;;
+  (define (empty-graph) (make-graph '()))
+  ;;;
+  (define (empty-graph? g) 
+    (andmap (lambda (x) (empty-set? (cdr x))) (graph-ls g)))
+  ;;;
+  (define (single x)
+    (set-add x (make-empty-set)))
+
+  (define (add-edge! g x y)
+    (let ([ls (graph-ls g)])
+      (cond
+        [(assq x ls) =>
+         (lambda (p0)
+           (unless (set-member? y (cdr p0))
+             (set-cdr! p0 (set-add y (cdr p0)))
+             (cond
+               [(assq y ls) => 
+                (lambda (p1) 
+                  (set-cdr! p1 (set-add x (cdr p1))))]
+               [else
+                (set-graph-ls! g 
+                   (cons (cons y (single x)) ls))])))]
+        [(assq y ls) =>
+         (lambda (p1)
+           (set-cdr! p1 (set-add x (cdr p1)))
+           (set-graph-ls! g (cons (cons x (single y)) ls)))]
+        [else 
+         (set-graph-ls! g 
+           (list* (cons x (single y))
+                  (cons y (single x))
+                  ls))])))
+  (define (print-graph g)
+    (printf "G={\n")
+    (parameterize ([print-gensym 'pretty])
+      (for-each (lambda (x) 
+                  (let ([lhs (car x)] [rhs* (cdr x)])
+                    (printf "  ~s => ~s\n" 
+                            (unparse lhs)
+                            (map unparse (set->list rhs*)))))
+        (graph-ls g)))
+    (printf "}\n"))
+  (define (node-neighbors x g)
+    (cond
+      [(assq x (graph-ls g)) => cdr]
+      [else (make-empty-set)]))
+
+  (define (delete-node! x g)
+    (let ([ls (graph-ls g)])
+      (cond
+        [(assq x ls) =>
+         (lambda (p)
+           (for-each (lambda (y) 
+                       (let ([p (assq y ls)])
+                         (set-cdr! p (set-rem x (cdr p)))))
+                     (set->list (cdr p)))
+           (set-cdr! p (make-empty-set)))]
+        [else (void)])))
+  ;;;
+  #|IntegerGraphs|#)
+
 (module (assign-frame-sizes)
   ;;; assign-frame-sizes module
   (define indent (make-parameter 0))
@@ -1997,6 +2064,8 @@
 (module (color-by-chaitin)
   (import ListySet)
   (import ListyGraphs)
+  ;(import IntegerSet)
+  ;(import IntegerGraphs)
   ;;;
   (define (set-for-each f s)
     (for-each f (set->list s)))
@@ -2931,14 +3000,6 @@
         [ls (flatten-codes x)]
        ;[foo (printf "8")]
          )
-    (when #f
-      (parameterize ([gensym-prefix "L"]
-                     [print-gensym #f])
-        (for-each 
-          (lambda (ls)
-            (newline)
-            (for-each (lambda (x) (printf "    ~s\n" x)) ls))
-          ls)))
     ls))
   
 

src/makefile.ss

@@ -406,6 +406,7 @@
     [gensym->unique-string   i symbols]
     [symbol-bound?           i symbols]
     [symbol-value            i symbols]
+    [top-level-value         i symbols]
     [set-symbol-value!       i symbols]
     [make-guardian           i]
     [make-input-port         i]
@@ -520,7 +521,6 @@
     [system                  i]
 
     [installed-libraries     i]
-    [compile-core-expr-to-port   $boot]
     [current-primitive-locations $boot]
     [boot-library-expand         $boot]
     [eval-core                   $boot]
@@ -853,9 +853,16 @@
               [(assq x locs) => cdr]
               [else 
                (error 'bootstrap "no location for ~s" x)])))
-        (let ([p (open-output-file "ikarus.boot" 'replace)])
+        (let ([p (open-output-file "ikarus.boot.new" 'replace)]
+              [idx 0])
           (for-each 
-            (lambda (x) (compile-core-expr-to-port x p))
+            (lambda (x) 
+              (set! idx (+ idx 1))
+              (cond
+                [(memv idx '(1))
+                 (alt-compile-core-expr-to-port x p)]
+                [else
+                 (compile-core-expr-to-port x p)]))
             core*)
           (close-output-port p)))))
 

src/pass-specify-rep-primops.ss

@@ -70,6 +70,11 @@
 
 (section ;;; simple objects section
 
+(define-primop base-rtd safe
+  [(V) (prm 'mref pcr (K 44))]
+  [(P) (K #t)]
+  [(E) (prm 'nop)])
+
 (define-primop void safe
   [(V) (K void-object)]
   [(P) (K #t)]
@@ -494,6 +499,7 @@
      ;     (prm 'mref x (K (- disp-symbol-error-function symbol-tag))))
      (dirty-vector-set x))])
 
+
 (define-primop top-level-value safe
   [(V x)
    (record-case x
@@ -668,6 +674,48 @@
   [(P x) (sec-tag-test (T x) vector-mask vector-tag bignum-mask bignum-tag)]
   [(E x) (nop)])
 
+(define-primop $bignum-positive? unsafe
+  [(P x) 
+   (prm '= (prm 'logand
+                (prm 'mref (T x) (K (- vector-tag))) 
+                (K bignum-sign-mask))
+        (K 0))]
+  [(E x) (nop)])
+
+(define-primop $bignum-byte-ref unsafe
+  [(V s i)
+   (record-case i
+     [(constant i)
+      (unless (fixnum? i) (interrupt))
+      (prm 'sll
+        (prm 'logand 
+           (prm 'mref (T s)
+             (K (+ i (- disp-bignum-data record-tag))))
+           (K 255))
+        (K fx-shift))]
+     [else
+      (prm 'sll
+        (prm 'srl ;;; FIXME: bref
+           (prm 'mref (T s)
+                (prm 'int+
+                   (prm 'sra (T i) (K fixnum-shift))
+                   ;;; ENDIANNESS DEPENDENCY
+                   (K (- disp-bignum-data 
+                         (- wordsize 1) 
+                         record-tag))))
+           (K (* (- wordsize 1) 8)))
+        (K fx-shift))])]
+  [(P s i) (K #t)]
+  [(E s i) (nop)])
+
+(define-primop $bignum-size unsafe
+  [(V x) 
+   (prm 'sll
+     (prm 'sra
+       (prm 'mref (T x) (K (- record-tag))) 
+       (K bignum-length-shift))
+     (K (* 2 fx-shift)))])
+
 /section)
 
 (section ;;; flonums
@@ -678,6 +726,31 @@
 
 /section)
 
+(section ;;; ratnums
+
+(define-primop ratnum? safe
+  [(P x) (sec-tag-test (T x) vector-mask vector-tag #f ratnum-tag)]
+  [(E x) (nop)])
+
+(define-primop $make-ratnum unsafe
+  [(V num den)
+   (with-tmp ([x (prm 'alloc (K (align ratnum-size)) (K vector-tag))])
+     (prm 'mset x (K (- vector-tag)) (K ratnum-tag))
+     (prm 'mset x (K (- disp-ratnum-num vector-tag)) (T num))
+     (prm 'mset x (K (- disp-ratnum-den vector-tag)) (T den))
+     x)]
+  [(P str) (K #t)]
+  [(E str) (nop)])
+
+
+(define-primop $ratnum-n unsafe
+  [(V x) (prm 'mref (T x) (K (- vector-tag disp-ratnum-num)))])
+
+(define-primop $ratnum-d unsafe
+  [(V x) (prm 'mref (T x) (K (- vector-tag disp-ratnum-den)))])
+
+/section)
+
 (section ;;; generic arithmetic
 
 (define (non-fixnum? x)
@@ -981,6 +1054,170 @@
 
 /section)
 
+(section ;;; bytevectors
+         
+(define-primop bytevector? safe
+  [(P x) (tag-test (T x) bytevector-mask bytevector-tag)]
+  [(E x) (nop)])
+
+(define-primop $make-bytevector unsafe
+  [(V n)
+   (record-case n
+     [(constant n)
+      (unless (fixnum? n) (interrupt))
+      (with-tmp ([s (prm 'alloc 
+                      (K (align (+ n 1 disp-bytevector-data)))
+                      (K bytevector-tag))])
+         (prm 'mset s
+             (K (- disp-bytevector-length bytevector-tag))
+             (K (* n fixnum-scale)))
+         (prm 'bset/c s
+             (K (+ n (- disp-bytevector-data bytevector-tag)))
+             (K 0))
+         s)]
+     [else
+      (with-tmp ([s (prm 'alloc 
+                      (align-code 
+                        (prm 'sra (T n) (K fixnum-shift))
+                        (+ disp-bytevector-data 1))
+                      (K bytevector-tag))])
+          (prm 'mset s
+            (K (- disp-bytevector-length bytevector-tag))
+            (T n))
+          (prm 'bset/c s
+               (prm 'int+ 
+                    (prm 'sra (T n) (K fixnum-shift))
+                    (K (- disp-bytevector-data bytevector-tag)))
+               (K 0))
+          s)])]
+  [(P n) (K #t)]
+  [(E n) (nop)])
+
+(define-primop $bytevector-length unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-bytevector-length bytevector-tag)))]
+  [(P x) (K #t)]
+  [(E x) (nop)])
+
+(define-primop $bytevector-u8-ref unsafe
+  [(V s i)
+   (record-case i
+     [(constant i)
+      (unless (fixnum? i) (interrupt))
+      (prm 'sll
+        (prm 'logand 
+           (prm 'mref (T s)
+             (K (+ i (- disp-bytevector-data bytevector-tag))))
+           (K 255))
+        (K fx-shift))]
+     [else
+      (prm 'sll
+        (prm 'srl ;;; FIXME: bref
+           (prm 'mref (T s)
+                (prm 'int+
+                   (prm 'sra (T i) (K fixnum-shift))
+                   ;;; ENDIANNESS DEPENDENCY
+                   (K (- disp-bytevector-data 
+                         (- wordsize 1) 
+                         bytevector-tag))))
+           (K (* (- wordsize 1) 8)))
+        (K fx-shift))])]
+  [(P s i) (K #t)]
+  [(E s i) (nop)])
+
+(define-primop $bytevector-s8-ref unsafe
+  [(V s i)
+   (record-case i
+     [(constant i)
+      (unless (fixnum? i) (interrupt))
+      (prm 'srl
+        (prm 'sll
+          (prm 'logand 
+             (prm 'mref (T s)
+               (K (+ i (- disp-bytevector-data bytevector-tag))))
+             (K 255))
+          (K (- (* wordsize 8) 8)))
+        (K (- (* wordsize 8) (+ 8 fx-shift))))]
+     [else
+      (prm 'srl
+        (prm 'sll
+          (prm 'srl ;;; FIXME: bref
+             (prm 'mref (T s)
+                  (prm 'int+
+                     (prm 'sra (T i) (K fixnum-shift))
+                     ;;; ENDIANNESS DEPENDENCY
+                     (K (- disp-bytevector-data 
+                           (- wordsize 1) 
+                           bytevector-tag))))
+             (K (* (- wordsize 1) 8)))
+          (K fx-shift))
+        (K (- (* wordsize 8) (+ 8 fx-shift))))])]
+  [(P s i) (K #t)]
+  [(E s i) (nop)])
+
+#;
+(define (assert-fixnum x)
+  (record-case x
+    [(constant i) 
+     (if (fixnum? i) (nop) (interrupt))]
+    [else (interrupt-unless (cogen-pred-fixnum? x))]))
+#;
+(define (assert-string x)
+  (record-case x
+    [(constant s) (if (string? s) (nop) (interrupt))]
+    [else (interrupt-unless (cogen-pred-string? x))]))
+#;
+(define-primop string-ref safe
+  [(V s i)
+   (seq*
+     (assert-fixnum i)
+     (assert-string s)
+     (interrupt-unless (prm 'u< (T i) (cogen-value-$string-length s)))
+     (cogen-value-$string-ref s i))]
+  [(P s i)
+   (seq*
+     (assert-fixnum i)
+     (assert-string s)
+     (interrupt-unless (prm 'u< (T i) (cogen-value-$string-length s)))
+     (K #t))]
+  [(E s i)
+   (seq*
+     (assert-fixnum i)
+     (assert-string s)
+     (interrupt-unless (prm 'u< (T i) (cogen-value-$string-length s))))])
+
+(define-primop $bytevector-set! unsafe
+  [(E x i c)
+   (record-case i
+     [(constant i) 
+      (unless (fixnum? i) (interrupt))
+      (record-case c
+        [(constant c)
+         (unless (fixnum? c) (interrupt))
+         (prm 'bset/c (T x)
+              (K (+ i (- disp-bytevector-data bytevector-tag)))
+              (K c))]
+        [else
+         (prm 'bset/h (T x)
+               (K (+ i (- disp-bytevector-data bytevector-tag)))
+               (prm 'sll (T c) (K (- 8 fx-shift))))])]
+     [else
+      (record-case c
+        [(constant c)
+         (unless (fixnum? c) (interrupt))
+         (prm 'bset/c (T x) 
+              (prm 'int+ 
+                   (prm 'sra (T i) (K fixnum-shift))
+                   (K (- disp-bytevector-data bytevector-tag)))
+              (K c))]
+        [else
+         (prm 'bset/h (T x)
+               (prm 'int+ 
+                    (prm 'sra (T i) (K fixnum-shift))
+                    (K (- disp-bytevector-data bytevector-tag)))
+               (prm 'sll (T c) (K (- 8 fx-shift))))])])])
+
+/section)
+
 (section ;;; strings
          
 (define-primop string? safe
@@ -993,29 +1230,19 @@
      [(constant n)
       (unless (fixnum? n) (interrupt))
       (with-tmp ([s (prm 'alloc 
-                      (K (align (+ n 1 disp-string-data)))
+                      (K (align (+ (* n wordsize) disp-string-data)))
                       (K string-tag))])
          (prm 'mset s
              (K (- disp-string-length string-tag))
              (K (* n fixnum-scale)))
-         (prm 'bset/c s
-             (K (+ n (- disp-string-data string-tag)))
-             (K 0))
          s)]
      [else
       (with-tmp ([s (prm 'alloc 
-                      (align-code 
+                      (align-code (T n) disp-string-data)
-                        (prm 'sra (T n) (K fixnum-shift))
-                        (+ disp-string-data 1))
                       (K string-tag))])
           (prm 'mset s
             (K (- disp-string-length string-tag))
             (T n))
-          (prm 'bset/c s
-               (prm 'int+ 
-                    (prm 'sra (T n) (K fixnum-shift))
-                    (K (- disp-string-data string-tag)))
-               (K 0))
           s)])]
   [(P n) (K #t)]
   [(E n) (nop)])
@@ -1031,28 +1258,13 @@
    (record-case i
      [(constant i)
       (unless (fixnum? i) (interrupt))
-      (prm 'logor
-        (prm 'sll
-          (prm 'logand 
       (prm 'mref (T s)
-               (K (+ i (- disp-string-data string-tag))))
+        (K (+ (* i fixnum-scale) 
-             (K 255))
+              (- disp-string-data string-tag))))]
-          (K char-shift))
-        (K char-tag))]
      [else
-      (prm 'logor
-        (prm 'sll
-          (prm 'srl ;;; FIXME: bref
       (prm 'mref (T s)
-                  (prm 'int+
+        (prm 'int+ (T i)
-                     (prm 'sra (T i) (K fixnum-shift))
+          (K (- disp-string-data string-tag))))])]
-                     ;;; ENDIANNESS DEPENDENCY
-                     (K (- disp-string-data 
-                           (- wordsize 1) 
-                           string-tag))))
-             (K (* (- wordsize 1) 8)))
-          (K char-shift))
-        (K char-tag))])]
   [(P s i) (K #t)]
   [(E s i) (nop)])
 
@@ -1092,33 +1304,13 @@
    (record-case i
      [(constant i) 
       (unless (fixnum? i) (interrupt))
-      (record-case c
+      (prm 'mset (T x) 
-        [(constant c)
+         (K (+ (* i fixnum-scale) (- disp-string-data string-tag)))
-         (unless (char? c) (interrupt))
+         (T c))]
-         (prm 'bset/c (T x) 
-              (K (+ i (- disp-string-data string-tag)))
-              (K (char->integer c)))]
      [else
-         (unless (= char-shift 8) (error 'cogen-$string-set! "BUG"))
+      (prm 'mset (T x) 
-         (prm 'bset/h (T x)
+         (prm 'int+ (T i) (K (- disp-string-data string-tag)))
-               (K (+ i (- disp-string-data string-tag)))
+         (T c))])])
-               (T c))])]
-     [else
-      (record-case c
-        [(constant c)
-         (unless (char? c) (interrupt))
-         (prm 'bset/c (T x) 
-              (prm 'int+ 
-                   (prm 'sra (T i) (K fixnum-shift))
-                   (K (- disp-string-data string-tag)))
-              (K (char->integer c)))]
-        [else
-         (unless (= char-shift 8) (error 'cogen-$string-set! "BUG"))
-         (prm 'bset/h (T x)
-               (prm 'int+ 
-                    (prm 'sra (T i) (K fixnum-shift))
-                    (K (- disp-string-data string-tag)))
-               (T c))])])])
 
 /section)
 
@@ -1291,7 +1483,7 @@
 
 (section ;;; codes
 
-(define-primop $code? unsafe
+(define-primop code? unsafe
   [(P x) (sec-tag-test (T x) vector-mask vector-tag #f code-tag)])
 
 (define-primop $closure-code unsafe

src/pass-specify-rep.ss

@@ -415,7 +415,7 @@
            (lambda (sym)
              (record-symbol-call! sym)
              (prm 'mref (T (K sym))
-                  (K (- disp-symbol-record-proc symbol-ptag))))]
+                  (K (- disp-symbol-record-value symbol-ptag))))]
           [else (nonproc x)])]
        [(primref op) (V x)]
        [else (nonproc x)]))
@@ -468,7 +468,7 @@
         [cmpl ,closure-tag ,cp-register]
         [jne (label ,L1)]
         [movl (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol)) ,cp-register]
-        [movl ,cp-register (disp ,(- disp-symbol-record-proc symbol-ptag) (obj ,symbol))]
+        [movl ,cp-register (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol))]
         [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]
         [label ,L1]
         [movl (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol)) %eax]
@@ -507,7 +507,8 @@
        (let ([code* (map Clambda code*)]
              [body (V body)])
          (make-codes code*
-           (make-seq (error-codes) body)))]
+           ;(make-seq (error-codes) body)
+           body))]
       [else (error 'specify-rep "invalid program ~s" x)]))
 
   (define (specify-representation x)