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: The Lurk evaluation in Loam #7

Merged
merged 5 commits into from
Nov 14, 2024
Merged

feat: The Lurk evaluation in Loam #7

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
d7b1cbe
wip
winston-h-zhang Oct 29, 2024
638fdbd
make tests pass
winston-h-zhang Oct 31, 2024
9466a23
we are kinda back
winston-h-zhang Nov 1, 2024
8e36145
Refactor builtin handling. (#8)
porcuquine Nov 5, 2024
910ef54
Cleanup.
winston-h-zhang Nov 14, 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
1 change: 1 addition & 0 deletions loam.asd
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -18,6 +18,7 @@
(:file "lattice")
(:file "datalog")
(:file "allocation")
(:file "evaluation")
(:file "data")
)))

Expand Down
4 changes: 2 additions & 2 deletions loam/allocation.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -112,7 +112,7 @@

(defclass lurk-allocation (allocation)
()
(:default-initargs :tag-names #(:nil :cons :sym :fun :num :str :char :comm :u64 :key :env :err :thunk :builtin :bignum)))
(:default-initargs :tag-names #(:u64 :num :bignum :comm :char :str :key :fun :builtin :coroutine :sym :cons :env :thunk :err)))

(defmethod initialize-program :after ((a lurk-allocation) &key &allow-other-keys)
(setf (allocation-tag-names a) (coerce (allocation-tag-names a) 'vector))
Expand Down Expand Up @@ -199,7 +199,7 @@
(:method ((allocation allocation) ((tag element) t) ((initial-address dual) t))
(let* ((allocation-map (allocation-allocation-map allocation))
(last-address (gethash tag allocation-map))
(allocated (if last-address (dual (1+ (dual-value last-address))) (dual 0))))
(allocated (if last-address (dual (1+ (dual-value last-address))) initial-address)))
(setf (gethash tag allocation-map) allocated)))
(:method ((allocation allocation) ((tag-spec keyword) symbol) ((initial-address dual) t))
(allocate allocation (tag-address tag-spec) initial-address))
Expand Down
210 changes: 151 additions & 59 deletions loam/data.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -7,12 +7,102 @@
(def-suite* data-suite :in loam:master-suite)

;; '(:nil :cons :sym :fun :num :str :char :comm :u64 :key :env :err :thunk :builtin :bignum)
(deflexical +tags+ (allocation-tag-names (make-instance 'lurk-allocation)))
; (deflexical +tags+ (allocation-tag-names (make-instance 'lurk-allocation)))

(let ((builtin-package (find-package :lurk.builtin)))
(defun* lurk-builtin-p ((s symbol))
(eq (symbol-package s) builtin-package)))

;; Getting them via do-external-symbols doesn't preserve the order, so here we are...
(defparameter *builtin-list*
winston-h-zhang marked this conversation as resolved.
Show resolved Hide resolved
(list 'lurk.builtin:atom
'lurk.builtin:apply
'lurk.builtin:begin
'lurk.builtin:car
'lurk.builtin:cdr
'lurk.builtin:char
'lurk.builtin:commit
'lurk.builtin:comm
'lurk.builtin:bignum
'lurk.builtin:cons
'lurk.builtin:current-env
'lurk.builtin:emit
'lurk.builtin:empty-env
'lurk.builtin:eval
'lurk.builtin:eq
'lurk.builtin:eqq
'lurk.builtin:type-eq
'lurk.builtin:type-eqq
'lurk.builtin:hide
'lurk.builtin:if
'lurk.builtin:lambda
'lurk.builtin:let
'lurk.builtin:letrec
'lurk.builtin:u64
'lurk.builtin:open
'lurk.builtin:quote
'lurk.builtin:secret
'lurk.builtin:strcons
'lurk.builtin:list
'lurk.builtin:+
'lurk.builtin:-
'lurk.builtin:*
'lurk.builtin:/
'lurk.builtin:%
'lurk.builtin:=
'lurk.builtin:<
'lurk.builtin:>
'lurk.builtin:<=
'lurk.builtin:>=
'lurk.builtin:breakpoint
'lurk.builtin:fail))

;; Forgive the heresy.
(defun builtin-idx (b)
winston-h-zhang marked this conversation as resolved.
Show resolved Hide resolved
(case b
(lurk.builtin:atom 0)
(lurk.builtin:apply 1)
(lurk.builtin:begin 2)
(lurk.builtin:car 3)
(lurk.builtin:cdr 4)
(lurk.builtin:char 5)
(lurk.builtin:commit 6)
(lurk.builtin:comm 7)
(lurk.builtin:bignum 8)
(lurk.builtin:cons 9)
(lurk.builtin:current-env 10)
(lurk.builtin:emit 11)
(lurk.builtin:empty-env 12)
(lurk.builtin:eval 13)
(lurk.builtin:eq 14)
(lurk.builtin:eqq 15)
(lurk.builtin:type-eq 16)
(lurk.builtin:type-eqq 17)
(lurk.builtin:hide 18)
(lurk.builtin:if 19)
(lurk.builtin:lambda 20)
(lurk.builtin:let 21)
(lurk.builtin:letrec 22)
(lurk.builtin:u64 23)
(lurk.builtin:open 24)
(lurk.builtin:quote 25)
(lurk.builtin:secret 26)
(lurk.builtin:strcons 27)
(lurk.builtin:list 28)
(lurk.builtin:+ 29)
(lurk.builtin:- 30)
(lurk.builtin:* 31)
(lurk.builtin:/ 32)
(lurk.builtin:% 33)
(lurk.builtin:= 34)
(lurk.builtin:< 35)
(lurk.builtin:> 36)
(lurk.builtin:<= 37)
(lurk.builtin:>= 38)
(lurk.builtin:breakpoint 39)
(lurk.builtin:fail 40)
))

;; bignum is reserved.
(deftype wide-num () '(unsigned-byte 256))

Expand All @@ -23,19 +113,20 @@

(deftype maybe-env () '(or null env))
(defstruct (env (:constructor env (key value next-env)))
(key nil :type symbol)
(key nil :type t) ; Key can be of type :sym, :builtin, or :coroutine.
(value nil :type t)
(next-env nil :type maybe-env))

(defstruct (thunk (:constructor thunk (body closed-env))) body (closed-env maybe-env))
(defstruct (fun (:constructor fun (args body closed-env)))
(args nil :type list)
(body nil :type t)
(closed-env maybe-env))
(closed-env cons))
winston-h-zhang marked this conversation as resolved.
Show resolved Hide resolved

(defun tag (thing)
(etypecase thing
(null :nil)
(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))
Expand All @@ -47,7 +138,7 @@
(character :char)
(comm :comm)
(thunk :thunk)
(env :env)
(env :cons)
(fun :fun)))

;; size is number of elements, bits is bits per 'element'
Expand All @@ -67,9 +158,6 @@
(list (symbol-name symbol) (package-name (symbol-package symbol))))

(defgeneric value<-expr (tag expr)
(:method ((tag (eql :nil)) x)
(assert (null x))
(value<-expr :sym nil))
(:method ((tag (eql :cons)) (x cons))
(let ((car (intern-wide-ptr (car x)))
(cdr (intern-wide-ptr (cdr x))))
Expand Down Expand Up @@ -103,11 +191,15 @@
(:method ((tag (eql :bignum)) x)
(make-wide :elements (le-elements<- x :size 8 :bits +element-bits+)))
(:method ((tag (eql :env)) x)
(let ((env-value (intern-wide-ptr (env-value x))))
(hash (value<-expr :sym (env-key x)) (wide-ptr-tag env-value)
(wide-ptr-value env-value) (etypecase (env-next-env x)
(env (wide-ptr-value (intern-wide-ptr (env-next-env x))))
(null (widen 0))))))
(let ((env-key (intern-wide-ptr (env-key x)))
(env-value (intern-wide-ptr (env-value x))))
(hash (wide-ptr-tag env-key)
(wide-ptr-value env-key)
(wide-ptr-tag env-value)
(wide-ptr-value env-value)
(etypecase (env-next-env x)
(env (wide-ptr-value (intern-wide-ptr (env-next-env x))))
(null (widen 0))))))
winston-h-zhang marked this conversation as resolved.
Show resolved Hide resolved
(:method ((tag (eql :thunk)) x)
(let ((body (intern-wide-ptr (thunk-body x)))
(closed-env (intern-wide-ptr (thunk-closed-env x))))
Expand All @@ -119,14 +211,9 @@
(closed-env (intern-wide-ptr (fun-closed-env x))))
(hash (wide-ptr-tag args) (wide-ptr-value args)
(wide-ptr-tag body) (wide-ptr-value body)
(wide-ptr-tag closed-env) (wide-ptr-value closed-env)))))
(wide-ptr-value closed-env)))))

(defgeneric expr<-wide (tag wide)
(:method ((tag (eql :nil)) (w wide))
(assert (== (value<-expr :nil nil) w)) ;; todo: this is expensive. We should also just cache original values when
;; interning. however, we need to be able to do this since we may be constructing
;; for the first time from preimages.
nil)
(:method ((tag (eql :num)) (w wide))
(assert (one-non-zero-limb-p w))
(num (wide-nth 0 w)))
Expand Down Expand Up @@ -156,15 +243,15 @@
(thunk (expr<-wide-ptr-parts body-tag body-value)
(expr<-wide-ptr-parts env-tag env-value))))
(:method ((tag (eql :fun)) (w wide))
(destructuring-bind (args-tag args-value body-tag body-value env-tag env-value)
(unhash w 6)
(destructuring-bind (args-tag args-value body-tag body-value env-value)
(unhash w 5)
(fun (expr<-wide-ptr-parts args-tag args-value)
(expr<-wide-ptr-parts body-tag body-value)
(expr<-wide-ptr-parts env-tag env-value))))
(expr<-wide-ptr-parts (tag-value :cons) env-value))))
(:method ((tag (eql :env)) (w wide))
(destructuring-bind (key-value val-tag val-value next-env)
(unhash w 4)
(env (expr<-wide :sym key-value)
(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)))))
Expand Down Expand Up @@ -218,41 +305,45 @@

(test intern-wide-ptr
(let ((*program* (make-program-instance 'test-program)))
(is (== (make-wide-ptr (tag-value :nil)
(wide 3988418742 3372394342 3989293407 3622167317
481098280 1226104118 3434725496 1157621715))
(is (== (make-wide-ptr (tag-value :sym)
(wide 281884145 1129688213 4120351968 327773871
384021070 117463301 2561106250 2236819005))
(intern-wide-ptr nil)))
#+nil(is (== (make-wide-ptr (tag-value :sym)
(wide 3513864683 4092952692 2311625634 434126079
1771964958 3138455192 216228261 3651295992))
(intern-wide-ptr t)))
(is (== (make-wide-ptr (tag-value :cons)
(wide 1971744287 3641459736 3774975494 1609894661
2629299411 3809236520 3595245074 62596448))
(wide 2469980295 1055013087 2071707850 3745798905
3182302750 3162655254 201317758 1580638714))
(intern-wide-ptr (cons 123 456))))
(is (== (make-wide-ptr (tag-value :sym)
(wide 3397136945 3387145446 234774522 2107533973
1504082815 1984471249 3548321992 3338191787))
(wide 4271245205 4041199923 139311603 1349105236
664727753 2939019886 3736723608 3286357898))
(intern-wide-ptr 'asparagus)))
(is (== (make-wide-ptr (tag-value :builtin)
(wide 1260038541 2992399590 2762133428 3260290791
4207369508 543827090 3180187974 2412760993))
(wide 3968199370 1224537180 3052128672 2224715904
3672658990 2925916735 1411103358 1335116285))
(intern-wide-ptr 'lurk:current-env)))
(is (== (make-wide-ptr (tag-value :num) (widen 987)) (intern-wide-ptr (num 987))))
(is (== (make-wide-ptr (tag-value :str) (widen 0)) (intern-wide-ptr "")))
(is (== (make-wide-ptr (tag-value :str) (wide 3915542193 3963547268 1543020646 761117776
2609865840 67719049 4263057193 3398353849))
(is (== (make-wide-ptr (tag-value :str) (wide 3076722117 4024338722 2289365418 698970534
3323852321 2245302033 976266832 315509495))
(intern-wide-ptr "boo")))
(is (== (make-wide-ptr (tag-value :char) (widen 65)) (intern-wide-ptr #\A)))
(is (== (make-wide-ptr (tag-value :comm) (wide 1397905034 3832045063 2843405970 3708064556
1931248981 1080144743 1379707257 644801363))
(is (== (make-wide-ptr (tag-value :comm) (wide 311654523 2666201238 1854678539 1180780569
3514416075 3591153456 1110633005 2917630731))
(intern-wide-ptr (comm 0 123))))
(is (== (make-wide-ptr (tag-value :comm) (wide 236359359 1527390219 2343696523 758167213
871965242 1355972474 190653183 4160106812))
(is (== (make-wide-ptr (tag-value :comm) (wide 1168834247 1827588988 2006807406 2556695211
2853839954 3698934260 4200172904 2878587015))
(intern-wide-ptr (comm 1 123))))
(is (== (make-wide-ptr (tag-value :comm) (wide 172617292 3084003310 1424146954 835899195
355959493 4174224837 4227269854 3448899362))
(is (== (make-wide-ptr (tag-value :comm) (wide 434704492 2111142387 1382466299 1563109978
294220625 1775261771 3288317254 2170675192))
(intern-wide-ptr (comm 0 '(brass monkey)))))
(is (== (make-wide-ptr (tag-value :u64) (widen 123)) (intern-wide-ptr 123)))
(is (== (make-wide-ptr (tag-value :key)
(wide 1431751249 3279460643 1685215955 1633314351
299894911 3402633075 3048470820 3631157086))
(wide 1228499544 2092597812 598601078 363335323
111897536 3513321278 2999164444 2314684892))
(intern-wide-ptr :asparagus)))
(is (== (make-wide-ptr (tag-value :bignum)
(wide #xffffffff #xffffffff #xffffffff #xffffffff
Expand All @@ -264,26 +355,26 @@
;; check endianness: the first limb should be affected.
(intern-wide-ptr (- (expt 2 256) 2))))
(is (== (make-wide-ptr (tag-value :cons)
(wide 3601906325 1188897660 3210004168 2644944356
514402910 756461026 1647625721 2397550761))
(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))
#+nil(let* ((env1 (env 'a 123 nil))
(env2 (env 'b :xxx env1)))
(is (== (make-wide-ptr (tag-value :env)
(wide 597130475 2448729965 2094617081 3023196126
2451788936 308612520 3598067228 2002918837))
(wide 2064456524 2837991327 1206943432 1993810858
165399524 1338455424 3431677448 3424566788))
(intern-wide-ptr env1)))
(is (== (make-wide-ptr (tag-value :env)
(wide 3077842195 572091283 2801462678 1065752347
522695411 544506590 3675411477 2546351666))
(wide 3920784138 2081306664 3462857731 2435250064
1090130623 216254371 3470941065 2646990734))
(intern-wide-ptr env2)))
(is (== (make-wide-ptr (tag-value :thunk)
(wide 1398018567 2260761747 719070819 1427893169
225825928 2996049430 2412858216 2883049183))
(wide 3496672372 2677663421 2116635234 3871946652
3542027988 2162033960 208146369 2711802215))
(intern-wide-ptr (thunk '(we want the thunk) env2)))))
(is (== (make-wide-ptr (tag-value :fun)
(wide 2071419739 2190085449 200730859 790264635
1557685556 3998478079 4149964193 2656130860))
(wide 2457271655 1361316774 3992440303 3109589054
3087846088 326130256 771752173 918216196))
(intern-wide-ptr (fun '(a b c) '(+ a (* b c)) nil))))))

(test expr<-wide-ptr
Expand All @@ -299,13 +390,14 @@
(test-roundtrip '(1 2 (3 4)))
(test-roundtrip 'a)
(test-roundtrip :mango)
(let* ((env1 (env 'a 123 nil))
#+nil(let* ((env1 (env 'a 123 nil))
winston-h-zhang marked this conversation as resolved.
Show resolved Hide resolved
(env2 (env 'b "xxx" env1)))
(test-roundtrip env1)
(test-roundtrip env2)
(test-roundtrip (thunk '(give up the thunk) 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)) nil))
(test-roundtrip 'lurk:lambda))))
(test-roundtrip (fun '(a b c) '(+ a (* b c)) '((x . 1))))
(test-roundtrip 'lurk:lambda)
(test-roundtrip '('lurk:cons 1 2)))))
Loading
Loading