Skip to content

Commit

Permalink
wip
Browse files Browse the repository at this point in the history
  • Loading branch information
@winston-h-zhang
winston-h-zhang committed Oct 31, 2024
1 parent 793d188 commit 5de911e
Show file tree
Hide file tree
Showing 6 changed files with 986 additions and 94 deletions.
1 change: 1 addition & 0 deletions loam.asd
View file
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
2 changes: 1 addition & 1 deletion loam/allocation.lisp
View file
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
190 changes: 141 additions & 49 deletions loam/data.lisp
View file
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*
(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)
(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,7 +113,7 @@

(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))

Expand All @@ -35,7 +125,8 @@

(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 Down Expand Up @@ -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))))))
(:method ((tag (eql :thunk)) x)
(let ((body (intern-wide-ptr (thunk-body x)))
(closed-env (intern-wide-ptr (thunk-closed-env x))))
Expand All @@ -122,11 +214,6 @@
(wide-ptr-tag 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 @@ -162,9 +249,9 @@
(expr<-wide-ptr-parts body-tag body-value)
(expr<-wide-ptr-parts env-tag 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))
(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 @@ -308,4 +399,5 @@
(test-roundtrip "roundtrip")
(test-roundtrip (comm 0 123))
(test-roundtrip (fun '(a b c) '(+ a (* b c)) nil))
(test-roundtrip 'lurk:lambda))))
(test-roundtrip 'lurk:lambda)
(test-roundtrip '('lurk:cons 1 2)))))
Loading

0 comments on commit 5de911e

Please sign in to comment.