Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

feat: Memory macro #10

Open
wants to merge 4 commits into
base: main
Choose a base branch
from
+345 −348
Open

feat: Memory macro #10

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
9c45bab
wip
winston-h-zhang Oct 30, 2024
e5a43f5
cleanup
winston-h-zhang Nov 14, 2024
507f4b0
Finish memory macro.
winston-h-zhang Nov 15, 2024
3facd21
Address review comments
winston-h-zhang Jan 17, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
48 changes: 17 additions & 31 deletions loam/allocation.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -268,36 +268,30 @@
;; hash-cache takes precedence over program in superclass list
(defprogram hash4 (hash-cache)
(include ptr-program)
(relation (hash4 wide wide wide wide)) ; (a b c d)
(relation (unhash4 wide)) ; (digest)
(relation (hash4 element wide wide wide wide)) ; (tag a b c d)
(relation (unhash4 element wide)) ; (tag digest)
Comment on lines +271 to +272
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why make this change?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Leaving this comment for context coming back in the future. Originally, I removed the tag because to combine all the hashing logic between the different memories, e.g. getting a hash4 from Cons v.s. Thunk goes through the same hashing pipeline.

However, when writing out the macro, it's easier to keep each completely separate. I added back in the tag to differentiate and deduplicate the hashing.

(relation (hash4-rel wide wide wide wide wide)) ; (a b c d digest)

;; signal
(rule (hash4-rel a b c d digest) <--
(unhash4 digest)
(unhash4 _ digest)
(let ((preimage (unhash4 digest))
(a (nth 0 preimage))
(b (nth 1 preimage))
(c (nth 2 preimage))
(d (nth 3 preimage)))))

;; signal
(rule (hash4-rel a b c d (hash a b c d)) <-- (hash4 a b c d))

;; signal
(rule (alloc a-tag a-value) (alloc b-tag b-value) <--
(unhash4 digest)
(hash4-rel wide-a-tag a-value wide-b-tag b-value digest)
(tag a-tag wide-a-tag)
(tag b-tag wide-b-tag)))
(rule (hash4-rel a b c d (hash a b c d)) <-- (hash4 _ a b c d))
)

(defprogram cons-mem ()
(include ptr-program)
(include hash4)

;; The following relations could be determined by something like:
;; (constructor cons (:cons 0 hash4) (car ptr) (cdr ptr))
; signal
;; signal
(relation (cons ptr ptr)) ; (car cdr)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Expand All @@ -311,7 +305,7 @@
(lattice (cons-mem ptr ptr dual-element)) ; (car cdr addr)

;; Populating alloc(...) triggers allocation in cons-digest-mem.
(rule (cons-digest-mem value (alloc :cons (dual 0))) <--
(rule (cons-digest-mem value (alloc :cons (dual 0))) <--
(alloc (tag-address :cons) value))

;; Populating cons(...) triggers allocation in cons-mem.
Expand All @@ -321,15 +315,15 @@
(rule (cons-digest-mem digest addr) <--
(cons-mem car cdr addr)
(ptr-value car car-value) (ptr-value cdr cdr-value)
(tag (ptr-tag car) car-tag) (tag (ptr-tag cdr) cdr-tag)
(hash4-rel car-tag car-value cdr-tag cdr-value digest))
(hash4-rel (widen (ptr-tag car)) car-value (widen (ptr-tag cdr)) cdr-value digest))

;; Other way around.
(rule (cons-mem car cdr addr) <--
(cons-digest-mem digest addr)
(hash4-rel car-tag car-value cdr-tag cdr-value digest)
(ptr-value car car-value) (ptr-value cdr cdr-value)
(tag (ptr-tag car) car-tag) (tag (ptr-tag cdr) cdr-tag))
(when (and (== (ptr-tag car) (wide-nth 0 car-tag))
(== (ptr-tag cdr) (wide-nth 0 cdr-tag)))))

;; Register a cons value.
(rule (ptr-value cons value) <--
Expand All @@ -341,14 +335,18 @@
(let ((cons (ptr :cons (dual-value addr))))))

;; signal
(rule (unhash4 digest) <--
(rule (unhash4 (tag-address :cons) digest) <--
(ingress ptr) (when (has-tag-p ptr :cons)) (ptr-value ptr digest))

;; signal
(rule (hash4 car-tag car-value cdr-tag cdr-value) <--
(rule (alloc (wide-nth 0 car-tag) car-value) (alloc (wide-nth 0 cdr-tag) cdr-value) <--
(unhash4 (tag-address :cons) digest)
(hash4-rel car-tag car-value cdr-tag cdr-value digest))

;; signal
(rule (hash4 (tag-address :cons) (widen (ptr-tag car)) car-value (widen (ptr-tag cdr)) cdr-value) <--
(egress cons)
(cons-rel car cdr cons)
(tag (ptr-tag car) car-tag) (tag (ptr-tag cdr) cdr-tag)
(ptr-value car car-value) (ptr-value cdr cdr-value))

;; signal
Expand Down Expand Up @@ -435,18 +433,6 @@
(signal-map-double cdr double-cdr)
(signal-cons double-car double-cdr doubled)))))

#|
(synthesize-rule (signal-map-double ptr doubled) <--
(when (has-tag-p ptr :num))
(let ((doubled (ptr :num (* 2 (ptr-value ptr)))))))

(synthesize-rule (signal-map-double ptr double-cons) <--
(ingress-cons car cdr ptr)
(signal-map-double car double-car)
(signal-map-double cdr double-cdr)
(signal-cons double-car double-cdr double-cons)))
|#

(defun make-cons (a-tag-spec a-wide b-tag-spec b-wide)
(hash4 (tag-value a-tag-spec) a-wide (tag-value b-tag-spec) b-wide))

Expand Down
20 changes: 12 additions & 8 deletions loam/data.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -93,7 +93,7 @@
(boolean :sym) ; nil and t are both sym.
(cons :cons)
(keyword :key)
(symbol (if (eql 'nil-env thing)
(symbol (if (eql 'lurk:nil-env thing)
:env
(if (lurk-builtin-p thing) :builtin :sym)))
(num :num)
Expand Down Expand Up @@ -156,7 +156,7 @@
(make-wide :elements (le-elements<- x :size 8)))
(:method ((tag (eql :bignum)) x)
(make-wide :elements (le-elements<- x :size 8 :bits +element-bits+)))
(:method ((tag (eql :env)) (x (eql 'nil-env)))
(:method ((tag (eql :env)) (x (eql 'lurk:nil-env)))
(widen 0))
(:method ((tag (eql :env)) (x env))
(let ((env-key (intern-wide-ptr (env-key x)))
Expand Down Expand Up @@ -218,7 +218,7 @@
(expr<-wide-ptr-parts (tag-value :env) env-value))))
(:method ((tag (eql :env)) (w wide))
(if (wide-zero-p w)
'nil-env
'lurk:nil-env
(destructuring-bind (key-tag key-value val-tag val-value next-env)
(unhash w 5)
(env (expr<-wide-ptr-parts key-tag key-value)
Expand Down Expand Up @@ -278,7 +278,7 @@
(wide 281884145 1129688213 4120351968 327773871
384021070 117463301 2561106250 2236819005))
(intern-wide-ptr nil)))
#+nil(is (== (make-wide-ptr (tag-value :sym)
(is (== (make-wide-ptr (tag-value :sym)
(wide 3513864683 4092952692 2311625634 434126079
1771964958 3138455192 216228261 3651295992))
(intern-wide-ptr t)))
Expand Down Expand Up @@ -327,8 +327,12 @@
(wide 3232492942 3172902725 3905286198 3869388357
3770444062 3474609343 2951998298 4004311820))
(intern-wide-ptr `(foo (bar 1) (:baz #\x "monkey") ,(num 123) ,(1- (expt 2 256))))))
(let* ((env1 (env 'a 123 'nil-env))
(let* ((env0 'lurk:nil-env)
(env1 (env 'a 123 env0))
(env2 (env 'b :xxx env1)))
(is (== (make-wide-ptr (tag-value :env)
(wide 0 0 0 0 0 0 0 0))
(intern-wide-ptr env0)))
(is (== (make-wide-ptr (tag-value :env)
(wide 2064456524 2837991327 1206943432 1993810858
165399524 1338455424 3431677448 3424566788))
Expand Down Expand Up @@ -360,7 +364,7 @@
(test-roundtrip 'a)
(test-roundtrip :mango)
;; TODO: Revert back after restoring :env changes
(let* ((env0 'nil-env)
(let* ((env0 'lurk:nil-env)
(env1 (env 'a 123 env0))
(env2 (env 'b "xxx" env1)))
(test-roundtrip env0)
Expand All @@ -370,6 +374,6 @@
)
(test-roundtrip "roundtrip")
(test-roundtrip (comm 0 123))
(test-roundtrip (fun '(a b c) '(+ a (* b c)) (env 'x 1 'nil-env)))
(test-roundtrip (fun '(a b c) '(+ a (* b c)) (env 'x 1 'lurk:nil-env)))
(test-roundtrip 'lurk:lambda)
(test-roundtrip '('lurk:cons 1 2)))))
(test-roundtrip '(lurk:cons 1 2)))))
Loading
Loading