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
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
df0cd80
Add real `env` implementation.
winston-h-zhang Nov 14, 2024
2ddd3f4
wip
winston-h-zhang Oct 30, 2024
71fda3a
cleanup
winston-h-zhang Nov 14, 2024
272d409
Finish memory macro.
winston-h-zhang Nov 15, 2024
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
170 changes: 139 additions & 31 deletions loam/allocation.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -231,6 +231,128 @@

(defun ptr-wide-tag (ptr) (widen (ptr-tag ptr)))

#+nil
(eval-when (:compile-toplevel :load-toplevel :execute)
;; TODO: Any better way to do this?
(defun concat-sym (root suf)
(intern (format nil "~A~A" root suf))))

;; TODO: Maybe it would be better for this to belong here? I've copied this over to evaluation.lisp for now.
#+nil
(defmacro defmem (prog-name superclasses config &body arg-specs)
(multiple-value-bind
(signal-args
signal-type-args
digest<-mem-forms
mem<-digest-forms
hash-args
unhash-args
alloc-forms
egress-forms)
(loop for arg-spec in arg-specs
for arg = (getf arg-spec :arg)
for arg-tag = (concat-sym arg '-tag)
for arg-value = (concat-sym arg '-value)
for type = (getf arg-spec :type)
for explicit-tag? = (getf arg-spec :tag)
for tag-check-form = (if explicit-tag?
`(when (== (ptr-tag ,arg) (tag-address ,(getf config :tag))))
`(when (== (ptr-tag ,arg) (wide-nth 0 ,arg-tag))))
collect arg into signal-args
collect type into signal-type-args
collect `(ptr-value ,arg ,arg-value) into digest<-mem-forms
when explicit-tag?
collect tag-check-form into digest<-mem-forms
collect `(ptr-value ,arg ,arg-value) into mem<-digest-forms
collect tag-check-form into mem<-digest-forms
when (not explicit-tag?)
collect `(widen (ptr-tag ,arg)) into hash-args
and collect arg-tag into unhash-args
collect arg-value into hash-args
collect arg-value into unhash-args
collect `(alloc (wide-nth 0 ,arg-tag) ,arg-value) into alloc-forms
collect `(egress ,arg) into egress-forms
finally (return (values
signal-args
signal-type-args
digest<-mem-forms
mem<-digest-forms
hash-args
unhash-args
alloc-forms
egress-forms)))
(let* ((name (getf config :name))
(tag (getf config :tag))
(initial-addr (getf config :initial-addr))
(hasher (getf config :hasher))
(name-rel (concat-sym name '-rel))
(name-digest-mem (concat-sym name '-digest-mem))
(name-mem (concat-sym name '-mem))
(hash-rel (concat-sym hasher '-rel))
(unhasher (concat-sym 'un hasher))
)
`(progn
(defprogram ,prog-name ,superclasses
(include ptr-program)
(include ,hasher)

;; Signal.
(relation (,name ,@signal-type-args))
;; The canonical `name` Ptr relation.
(relation (,name-rel ,@signal-type-args ptr))

;; Memory to support data allocated by digest or contents.
(lattice (,name-digest-mem wide dual-element)) ; (digest addr)
(lattice (,name-mem ,@signal-type-args dual-element)) ; (args addr)

;; Populating alloc(...) triggers allocation in cons-digest-mem.
(rule (,name-digest-mem ,'value (alloc ,tag (dual ,initial-addr))) <--
(alloc (tag-address ,tag) ,'value))

;; Populating `name`(...) triggers allocation in name-mem.
(rule (,name-mem ,@signal-args (alloc ,tag (dual ,initial-addr))) <-- (,name ,@signal-args))

;; Populate name-digest-mem if a name in cons-mem has been hashed in hash4-rel.
(rule (,name-digest-mem digest addr) <--
(,name-mem ,@signal-args addr)
,@digest<-mem-forms
(,hash-rel ,@hash-args digest))

;; Other way around.
(rule (,name-mem ,@signal-args addr) <--
(,name-digest-mem digest addr)
(,hash-rel ,@unhash-args digest)
,@mem<-digest-forms)

;; Register a memory value.
(rule (ptr-value ,name value) <--
(,name-digest-mem value addr) (let ((,name (ptr ,tag (dual-value addr))))))

;; Register a memory relation.
(rule (,name-rel ,@signal-args ,name) <--
(,name-mem ,@signal-args addr)
(let ((,name (ptr ,tag (dual-value addr))))))

;; signal
(rule (,unhasher (tag-address ,tag) digest) <--
(ingress ptr) (when (has-tag-p ptr ,tag)) (ptr-value ptr digest))

;; signal
(rule ,@alloc-forms <--
(,unhasher (tag-address ,tag) digest)
(,hash-rel ,@unhash-args digest))

;; signal
(rule (,hasher (tag-address ,tag) ,@hash-args) <--
(egress ,name)
(,name-rel ,@signal-args ,name)
,@digest<-mem-forms)

;; signal
(rule ,@egress-forms <--
(egress ,name) (,name-rel ,@signal-args ,name))
)))))

(defprogram ptr-program (lurk-allocation)
(relation (tag element wide)) ; (short-tag wide-tag)

Expand Down Expand Up @@ -268,36 +390,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 +393 to +394
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?

(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 +427,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 +437,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 +457,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 +555,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
47 changes: 29 additions & 18 deletions loam/data.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -71,7 +71,7 @@

(defstruct (comm (:constructor comm (secret value))) secret value)

(deftype maybe-env () '(or null env))
(deftype maybe-env () '(or symbol env))
(defstruct (env (:constructor env (key value next-env)))
(key nil :type t) ; Key can be of type :sym, :builtin, or :coroutine.
(value nil :type t)
Expand All @@ -81,15 +81,17 @@
(defstruct (fun (:constructor fun (args body closed-env)))
(args nil :type list)
(body nil :type t)
(closed-env nil :type list))
(closed-env nil :type maybe-env))

(defun tag (thing)
(etypecase thing
(null :sym) ; nil is also a sym.
(boolean :sym) ; nil and t are both sym.
(cons :cons)
(keyword :key)
(symbol (if (lurk-builtin-p thing) :builtin :sym))
(symbol (if (eql 'lurk:nil-env thing)
:env
(if (lurk-builtin-p thing) :builtin :sym)))
(num :num)
((unsigned-byte 64) :u64)
(wide-num :bignum)
Expand All @@ -98,7 +100,7 @@
(character :char)
(comm :comm)
(thunk :thunk)
(env (if env :cons :sym)) ; If env is nil, tag should be sym ; TODO: Revert back to :env
(maybe-env :env)
(fun :fun)))

;; size is number of elements, bits is bits per 'element'
Expand Down Expand Up @@ -150,7 +152,9 @@
(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 :cons)) (x 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)))
(env-value (intern-wide-ptr (env-value x))))
(hash (wide-ptr-tag env-key)
Expand All @@ -159,7 +163,7 @@
(wide-ptr-value env-value)
(etypecase (env-next-env x)
(env (wide-ptr-value (intern-wide-ptr (env-next-env x))))
(null (widen 0))))))
(symbol (widen 0))))))
(:method ((tag (eql :thunk)) x)
(let ((body (intern-wide-ptr (thunk-body x)))
(closed-env (intern-wide-ptr (thunk-closed-env x))))
Expand Down Expand Up @@ -207,14 +211,15 @@
(unhash w 5)
(fun (expr<-wide-ptr-parts args-tag args-value)
(expr<-wide-ptr-parts body-tag body-value)
(expr<-wide-ptr-parts (tag-value :cons) env-value))))
(expr<-wide-ptr-parts (tag-value :env) env-value))))
(:method ((tag (eql :env)) (w wide))
(destructuring-bind (key-tag key-value val-tag val-value next-env)
(unhash w 5)
(env (expr<-wide key-tag key-value)
(expr<-wide-ptr-parts val-tag val-value)
(unless (wide-zero-p next-env)
(expr<-wide :env next-env)))))
(if (wide-zero-p w)
'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)
(expr<-wide-ptr-parts val-tag val-value)
(expr<-wide :env next-env)))))
(:method ((tag (eql :str)) (w wide))
(with-output-to-string (out)
(loop while (not (wide-zero-p w))
Expand Down Expand Up @@ -269,7 +274,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 @@ -318,8 +323,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))))))
#+nil(let* ((env1 (env 'a 123 nil))
(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 @@ -351,14 +360,16 @@
(test-roundtrip 'a)
(test-roundtrip :mango)
;; TODO: Revert back after restoring :env changes
#+nil(let* ((env1 (env 'a 123 nil))
(let* ((env0 'lurk:nil-env)
(env1 (env 'a 123 env0))
(env2 (env 'b "xxx" env1)))
(test-roundtrip env0)
(test-roundtrip env1)
(test-roundtrip env2)
(test-roundtrip (thunk '(give up the thunk) '((b . "xxx") (a . 123))))
)
(test-roundtrip "roundtrip")
(test-roundtrip (comm 0 123))
(test-roundtrip (fun '(a b c) '(+ a (* b c)) '((x . 1))))
(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