crook

hoax/heap-bits.rkt

@@ -0,0 +1,66 @@
+#lang racket
+(require "types.rkt")
+(provide (struct-out heap) heap-ref heap-set!
+         alloc-box alloc-cons
+         alloc-vect alloc-str)
+
+(struct heap ([n #:mutable] bytes))
+
+;; Value* Heap -> Answer*
+(define (alloc-box v h)
+  (match h
+    [(heap n bs)
+     (heap-set! h n v)
+     (set-heap-n! h (+ n 8))
+     (bitwise-xor n type-box)]))
+
+;; Value* Value* Heap -> Answer*
+(define (alloc-cons v1 v2 h)
+  (match h
+    [(heap n bs)
+     (heap-set! h (+ n 0) v1)
+     (heap-set! h (+ n 8) v2)
+     (set-heap-n! h (+ n 16))
+     (bitwise-xor n type-cons)]))
+
+(define (alloc-vect vs h)
+  (match h
+    [(heap n bs)
+     (heap-set! h n (arithmetic-shift (length vs) int-shift))
+     (write-values! h vs (+ n 8))
+     (set-heap-n! h (+ n (* 8 (add1 (length vs)))))
+     (bitwise-xor n type-vect)]))
+
+(define (alloc-str cs h)
+  (match h
+    [(heap n bs)
+     (heap-set! h n (arithmetic-shift (length cs) int-shift))
+     (write-values! h cs (+ n 8))
+     (set-heap-n! h (+ n (* 8 (add1 (length cs)))))
+     (bitwise-xor n type-str)]))
+
+
+(define (write-values! h vs i)
+  (match vs
+    ['() (void)]
+    [(cons v vs)
+     (heap-set! h i v)
+     (write-values! h vs (+ i 8))]))
+
+;; Heap Address -> Value*
+(define (heap-ref h a)
+  (integer-bytes->integer (heap-bytes h) #t #f a (+ a 8)))
+
+;; Heap Address Natural -> [Listof Value*]
+(define (heap-ref/n h a n)
+  (define (loop n vs)
+    (match n
+      [0 vs]
+      [_ (loop (sub1 n)
+               (cons (heap-ref h (+ a n)) vs))]))
+  (loop n '()))
+
+;; Heap Address Value* -> Void
+(define (heap-set! h i v)
+  (integer->integer-bytes v 8 (negative? v) #f (heap-bytes h) i))
+

hoax/interp-heap-bits.rkt

@@ -0,0 +1,85 @@
+#lang racket
+(provide interp)
+(require "ast.rkt")
+(require "types.rkt")
+(require "env.rkt")
+(require "heap-bits.rkt")
+(require "interp-prims-heap-bits.rkt")
+(require "unload-bits.rkt")
+
+(define *heap-size* 100000) ; # words in heap
+
+;; type Answer* =
+;; | Value*
+;; | 'err
+
+;; type Value* =
+;; | (value->bits Integer)
+;; | (value->bits Boolean)
+;; | (value->bits Character)
+;; | (value->bits Eof)
+;; | (value->bits Void)
+;; | (value->bits '())
+;; | (bitwise-xor Address type-box)
+;; | (bitwise-xor Address type-cons)
+
+;; type Address = Natural divisible by 8
+
+;; type Heap = (heap Address Bytes)
+
+;; type REnv = (Listof (List Id Value*))
+
+;; Expr -> Value
+(define (interp e)
+  (define h (heap 0 (make-bytes (* 8 *heap-size*) 0)))
+  (unload h (interp-env-heap-bits e '() h)))
+
+;; Expr REnv Heap -> Answer*
+(define (interp-env-heap-bits e r h)
+  (match e
+    [(Lit (? string? s)) (alloc-str (map value->bits (string->list s)) h)]
+    [(Lit d) (value->bits d)]
+    [(Eof)   (value->bits eof)]
+    [(Var x) (lookup r x)]
+    [(Prim0 p) (interp-prim0 p h)]
+    [(Prim1 p e)
+     (match (interp-env-heap-bits e r h)
+       ['err 'err]
+       [v
+        (interp-prim1 p v h)])]
+    [(Prim2 p e1 e2)
+     (match (interp-env-heap-bits e1 r h)
+       ['err 'err]
+       [v1
+        (match (interp-env-heap-bits e2 r h)
+          ['err 'err]
+          [v2
+           (interp-prim2 p v1 v2 h)])])]
+    [(Prim3 p e1 e2 e3)
+     (match (interp-env-heap-bits e1 r h)
+       ['err 'err]
+       [v1
+        (match (interp-env-heap-bits e2 r h)
+          ['err 'err]
+          [v2
+           (match (interp-env-heap-bits e3 r h)
+             ['err 'err]
+             [v3
+              (interp-prim3 p v1 v2 v3 h)])])])]
+    [(If p e1 e2)
+     (match (interp-env-heap-bits p r h)
+       ['err 'err]
+       [v
+        (if (= v (value->bits #f))
+            (interp-env-heap-bits e2 r h)
+            (interp-env-heap-bits e1 r h))])]
+    [(Begin e1 e2)
+     (match (interp-env-heap-bits e1 r h)
+       ['err 'err]
+       [_ (interp-env-heap-bits e2 r h)])]
+    [(Let x e1 e2)
+     (match (interp-env-heap-bits e1 r h)
+       ['err 'err]
+       [v
+        (interp-env-heap-bits e2 (ext r x v) h)])]))
+

hoax/interp-prims-heap-bits.rkt

@@ -0,0 +1,103 @@
+#lang racket
+(provide interp-prim0 interp-prim1 interp-prim2 interp-prim3)
+(require "heap-bits.rkt")
+(require "types.rkt")
+
+;; Op0 Heap -> Answer*
+(define (interp-prim0 op h)
+  (match op
+    ['read-byte (value->bits (read-byte))]
+    ['peek-byte (value->bits (peek-byte))]
+    ['void      (value->bits (void))]))
+
+;; Op1 Value* Heap -> Answer*
+(define (interp-prim1 p v h)
+  (match (list p v)
+    [(list 'add1 (? int-bits? i))
+     (+ i (value->bits 1))]
+    [(list 'sub1 (? int-bits? i))
+     (- i (value->bits 1))]
+    [(list 'zero? (? int-bits? i))
+     (value->bits (zero? i))]
+    [(list 'char? v)
+     (value->bits (char-bits? v))]
+    [(list 'char->integer (? char-bits?))
+     (arithmetic-shift (bitwise-xor v type-char) (- int-shift char-shift))]
+    [(list 'integer->char (? codepoint-bits?))
+     (bitwise-xor (arithmetic-shift v (- char-shift int-shift)) type-char)]
+    [(list 'eof-object? v)
+     (value->bits (= (value->bits eof) v))]
+    [(list 'write-byte (? byte-bits?))
+     (begin (write-byte (arithmetic-shift v (- int-shift)))
+            (value->bits (void)))]
+    [(list 'box v) (alloc-box v h)]
+    [(list 'unbox (? box-bits? i))
+     (heap-ref h (bitwise-xor i type-box))]
+    [(list 'car (? cons-bits? i))
+     (heap-ref h (bitwise-xor i type-cons))]
+    [(list 'cdr (? cons-bits? i))
+     (heap-ref h (bitwise-xor (+ i 8) type-cons))]
+    [(list 'empty? v)
+     (value->bits (= (value->bits '()) v))]
+    [(list 'vector? v)
+     (value->bits (vect-bits? v))]
+    [(list 'string? v)
+     (value->bits (str-bits? v))]
+    [(list 'vector-length (? vect-bits?))
+     (define p (bitwise-xor v type-vect))
+     (heap-ref h p)]
+    [(list 'string-length (? str-bits?))
+     (define p (bitwise-xor v type-str))
+     (heap-ref h p)]
+    [_ 'err]))
+
+;; Op2 Value* Value* Heap -> Answer*
+(define (interp-prim2 p v1 v2 h)
+  (match (list p v1 v2)
+    [(list '+ (? int-bits? i1) (? int-bits? i2)) (+ i1 i2)]
+    [(list '- (? int-bits? i1) (? int-bits? i2)) (- i1 i2)]
+    [(list '< (? int-bits? i1) (? int-bits? i2)) (value->bits (< i1 i2))]
+    [(list '= (? int-bits? i1) (? int-bits? i2)) (value->bits (= i1 i2))]
+    [(list 'eq? v1 v2) (value->bits (= v1 v2))]
+    [(list 'cons v1 v2) (alloc-cons v1 v2 h)]
+    [(list 'make-vector (? int-bits? i) v)
+     (if (< i 0)
+         'err
+         (alloc-vect (make-list (arithmetic-shift i (- int-shift)) v) h))]
+    [(list 'vector-ref (? vect-bits? a) (? int-bits? i))
+     (define p (bitwise-xor a type-vect))
+     (if (<= 0 i (sub1 (heap-ref h p)))
+         (heap-ref h (+ p 8 (arithmetic-shift i (- 3 int-shift))))
+         'err)]
+    [(list 'make-string (? int-bits? i) (? char-bits? c))
+     (if (< i 0)
+         'err
+         (alloc-str (make-list (arithmetic-shift i (- int-shift)) c) h))]
+    [(list 'string-ref (? str-bits? a) (? int-bits? i))
+     (define p (bitwise-xor a type-str))
+     (if (<= 0 i (sub1 (heap-ref h p)))
+         (heap-ref h (+ p 8 (arithmetic-shift i (- 3 int-shift))))
+         'err)]
+    [_ 'err]))
+
+;; Op3 Value* Value* Value* Heap -> Answer*
+(define (interp-prim3 p v1 v2 v3 h)
+  (match (list p v1 v2 v3)
+    [(list 'vector-set! (? vect-bits?) (? int-bits?) _)
+     (define p (bitwise-xor v1 type-vect))
+     (if (<= 0 v2 (sub1 (heap-ref h p)))
+         (heap-set! h (+ p 8 (arithmetic-shift v2 (- 3 int-shift))) v3)
+         'err)]
+    [_ 'err]))
+
+;; Int64 -> Boolean
+(define (byte-bits? v)
+  (and (int-bits? v)
+       (<= 0 v (value->bits 255))))
+
+;; Int64 -> Boolean
+(define (codepoint-bits? v)
+  (and (int-bits? v)
+       (or (<= 0 v (value->bits 55295))
+           (<= (value->bits 57344) v (value->bits 1114111)))))
+

hoax/test/interp-heap-bits.rkt

@@ -0,0 +1,11 @@
+#lang racket
+(require "test-runner.rkt")
+(require "../parse.rkt")
+(require "../interp-heap-bits.rkt")
+(require "../interp-io.rkt")
+
+(test (λ (e) (interp (parse e))))
+
+;; FIXME: this is not running a heap-based interpreter!
+(test/io (λ (s e) (interp/io (parse e) s)))
+

hoax/types.rkt

@@ -27,20 +27,20 @@
         [(char-bits? b)
          (integer->char (arithmetic-shift b (- char-shift)))]
         [(box-bits? b)
-         (box (bits->value (heap-ref b)))]
+         (box (bits->value (mem-ref b)))]
         [(cons-bits? b)
-         (cons (bits->value (heap-ref (+ b 8)))
-               (bits->value (heap-ref b)))]
+         (cons (bits->value (mem-ref (+ b 8)))
+               (bits->value (mem-ref b)))]
         [(vect-bits? b)
          (if (zero? (untag b))
              (vector)
-             (build-vector (heap-ref b)
+             (build-vector (mem-ref b)
                            (lambda (j)
-                             (bits->value (heap-ref (+ b (* 8 (add1 j))))))))]
+                             (bits->value (mem-ref (+ b (* 8 (add1 j))))))))]
         [(str-bits? b)
          (if (zero? (untag b))
              (string)
-             (build-string (heap-ref b)
+             (build-string (mem-ref b)
                            (lambda (j)
                              (char-ref (+ b 8) j))))]
         [else (error "invalid bits")]))
@@ -82,7 +82,7 @@
   (arithmetic-shift (arithmetic-shift i (- (integer-length ptr-mask)))
                     (integer-length ptr-mask)))
 
-(define (heap-ref i)
+(define (mem-ref i)
   (ptr-ref (cast (untag i) _int64 _pointer) _int64))
 
 (define (char-ref i j)

hoax/unload-bits.rkt

@@ -0,0 +1,33 @@
+#lang racket
+(provide unload unload-value)
+(require "heap-bits.rkt")
+(require "types.rkt")
+
+;; Heap Answer* -> Answer
+(define (unload h a)
+  (match a
+    ['err 'err]
+    [v (unload-value v h)]))
+
+;; Value* Heap -> Value
+(define (unload-value v h)
+  (match v
+    [(? box-bits?)
+     (define p (bitwise-xor v type-box))
+     (box (unload-value (heap-ref h p) h))]
+    [(? cons-bits?)
+     (define p (bitwise-xor v type-cons))
+     (cons (unload-value (heap-ref h (+ p 0)) h)
+           (unload-value (heap-ref h (+ p 8)) h))]
+    [(? vect-bits?)
+     (define p (bitwise-xor v type-vect))
+     (build-vector (arithmetic-shift (heap-ref h p) (- int-shift))
+                   (λ (i)
+                     (bits->value (heap-ref h (+ p (* 8 (add1 i)))))))]
+    [(? str-bits?)
+     (define p (bitwise-xor v type-str))
+     (build-string (arithmetic-shift (heap-ref h p) (- int-shift))
+                   (λ (i)
+                     (bits->value (heap-ref h (+ p (* 8 (add1 i)))))))]
+    [_ (bits->value v)]))
+

hustle/heap-bits.rkt

@@ -1,25 +1,32 @@
 #lang racket
-(provide alloc-box alloc-cons heap-ref heap-set)
 (require "types.rkt")
+(provide (struct-out heap) heap-ref
+         alloc-box alloc-cons)
 
-;; Value* Heap -> Answer
+(struct heap ([n #:mutable] bytes))
+
+;; Value* Heap -> Answer*
 (define (alloc-box v h)
-  (cons (cons v h)
-        (bitwise-ior (arithmetic-shift (length h) imm-shift)
-                     type-box)))
+  (match h
+    [(heap n bs)
+     (heap-set! h n v)
+     (set-heap-n! h (+ n 8))
+     (bitwise-xor n type-box)]))
 
-;; Value* Value* Heap -> Answer
+;; Value* Value* Heap -> Answer*
 (define (alloc-cons v1 v2 h)
-  (cons (cons v2 (cons v1 h))
-        (bitwise-ior (arithmetic-shift (length h) imm-shift)
-                     type-cons)))
+  (match h
+    [(heap n bs)
+     (heap-set! h (+ n 0) v1)
+     (heap-set! h (+ n 8) v2)
+     (set-heap-n! h (+ n 16))
+     (bitwise-xor n type-cons)]))
 
 ;; Heap Address -> Value*
 (define (heap-ref h a)
-  (let ((a (arithmetic-shift a (- imm-shift))))
-    (list-ref h (- (length h) (add1 a)))))
+  (integer-bytes->integer (heap-bytes h) #t #f a (+ a 8)))
+
+;; Heap Address Value* -> Void
+(define (heap-set! h i v)
+  (integer->integer-bytes v 8 (negative? v) #f (heap-bytes h) i))
 
-;; Heap Address Value* -> Heap
-(define (heap-set h a v)
-  (let ((a (arithmetic-shift a (- imm-shift))))
-    (list-set h (- (length h) a 1) v)))