support for user defined object types with custom destructor

devyn · Aug 17, 2023 · a71118f · a71118f
1 parent 6f430ec
commit a71118f
Show file tree

Hide file tree

Showing 7 changed files with 55 additions and 40 deletions.
diff --git a/stage1/eval.s b/stage1/eval.s
@@ -24,7 +24,7 @@ eval:
         sd a1, 0x10(sp) # a1 = local words list
         # check type of expression
         beqz a0, .Leval_literal # return literal nil
-        lwu t1, LISP_OBJECT_TYPE(a0)
+        lw t1, LISP_OBJECT_TYPE(a0)
         li t2, LISP_OBJECT_TYPE_SYMBOL
         beq t1, t2, .Leval_symbol # eval symbol just looks it up
         li t2, LISP_OBJECT_TYPE_CONS
@@ -108,7 +108,7 @@ acquire_locals:
 call_procedure:
         # check if the value is a procedure
         beqz a0, .Lcall_procedure_not_callable
-        lwu t1, LISP_OBJECT_TYPE(a0)
+        lw t1, LISP_OBJECT_TYPE(a0)
         li t2, LISP_OBJECT_TYPE_PROCEDURE
         bne t1, t2, .Lcall_procedure_not_callable
         # add ref to data and release procedure object

diff --git a/stage1/memory.s b/stage1/memory.s
@@ -261,7 +261,7 @@ drop_object:
         sd s1, 8(sp) # s1 = saved object address
         sd s2, 16(sp) # s2 = object type
         mv s1, a0
-        lwu s2, LISP_OBJECT_TYPE(s1)
+        lw s2, LISP_OBJECT_TYPE(s1)
         # check type
         li t0, LISP_OBJECT_TYPE_CONS
         beq s2, t0, .Ldrop_object_cons
@@ -271,6 +271,7 @@ drop_object:
         beq s2, t0, .Ldrop_object_procedure
         li t0, LISP_OBJECT_TYPE_SYMBOL
         beq s2, t0, .Ldrop_object_symbol
+        bltz s2, .Ldrop_object_user
         beqz s2, .Ldrop_object_zero # most likely double free
         j .Ldrop_object_end # unknown or no special handling needed
 .Ldrop_object_cons:
@@ -297,6 +298,12 @@ drop_object:
         mv a0, s1
         call acquire_object
         j .Ldrop_object_ret
+.Ldrop_object_user:
+        # call destructor unless zero
+        ld t0, LISP_USER_OBJ_DESTRUCTOR(s1)
+        beqz t0, .Ldrop_object_end
+        la ra, .Ldrop_object_end
+        jr (t0)
 .Ldrop_object_zero:
         # print z address and return without deallocating
         li a0, 'z'
@@ -306,7 +313,7 @@ drop_object:
         call put_hex
         li a0, '\n'
         call putc
-        j 1f
+        j .Ldrop_object_ret
 .Ldrop_object_end:
         mv a0, s1
         li a1, LISP_OBJECT_SIZE

diff --git a/stage1/object.h b/stage1/object.h
@@ -3,6 +3,7 @@
 #define LISP_OBJECT_TYPE_CONS       3
 #define LISP_OBJECT_TYPE_STRING     4
 #define LISP_OBJECT_TYPE_PROCEDURE  5
+#define LISP_OBJECT_TYPE_BIT_USER   (1 << 31)
 
 // This is just pseudocode to describe the structure of the lisp objects in memory
 struct lisp_cons {
@@ -36,14 +37,21 @@ struct lisp_return {
   struct lisp_object *return_value;
 };
 
+struct lisp_user_obj {
+  void (*destructor)(struct lisp_object *obj);
+  long data1;
+  long data2;
+};
+
 struct lisp_object {
-  unsigned int type;
+  int type; // negative values are user types
   int refcount; // should be >= 1, or else destroy
   union {
     long as_integer;
     struct lisp_symbol as_symbol;
     struct lisp_cons as_cons;
     struct lisp_string as_string;
     struct lisp_procedure as_procedure;
+    struct lisp_user_obj as_user_obj;
   } value;
 };
diff --git a/stage1/object.h.s b/stage1/object.h.s
@@ -18,6 +18,10 @@
 .set LISP_PROCEDURE_PTR, 8
 .set LISP_PROCEDURE_DATA, 16
 
+.set LISP_USER_OBJ_DESTRUCTOR, 8
+.set LISP_USER_OBJ_DATA1, 16
+.set LISP_USER_OBJ_DATA2, 24
+
 # Size of a lisp_object in bytes
 .set LISP_OBJECT_SIZE, 32
 .set LISP_OBJECT_ALIGN, 8
@@ -28,3 +32,4 @@
 .set LISP_OBJECT_TYPE_CONS,       3
 .set LISP_OBJECT_TYPE_STRING,     4
 .set LISP_OBJECT_TYPE_PROCEDURE,  5
+.set LISP_OBJECT_TYPE_BIT_USER,   1 << 31
diff --git a/stage1/object.s b/stage1/object.s
@@ -24,7 +24,7 @@ uncons:
         sd zero, 0x20(sp)
         beqz a0, .Luncons_ret # nil
         li t1, LISP_OBJECT_TYPE_CONS
-        lwu t2, LISP_OBJECT_TYPE(a0)
+        lw t2, LISP_OBJECT_TYPE(a0)
         bne t2, t1, .Luncons_ret # not cons
         # success - get value
         li t1, 1
@@ -121,7 +121,7 @@ unbox_integer:
         sd zero, 0x10(sp)
         beqz a0, .Lunbox_integer_ret # nil
         li t1, LISP_OBJECT_TYPE_INTEGER
-        lwu t2, LISP_OBJECT_TYPE(a0)
+        lw t2, LISP_OBJECT_TYPE(a0)
         bne t2, t1, .Lunbox_integer_ret # not integer
         # success - get value
         li t1, 1
@@ -161,7 +161,7 @@ unbox_procedure:
         sd a0, 0x20(sp)
         beqz a0, .Lunbox_procedure_ret # nil
         li t1, LISP_OBJECT_TYPE_PROCEDURE
-        lwu t2, LISP_OBJECT_TYPE(a0)
+        lw t2, LISP_OBJECT_TYPE(a0)
         bne t2, t1, .Lunbox_procedure_ret # not procedure
         # success - get value
         li t1, 1
@@ -248,7 +248,7 @@ print_obj:
         mv s1, a0
         beqz s1, .Lprint_obj_cons # since nil = (), handle with cons
         # check object type
-        lwu t0, LISP_OBJECT_TYPE(s1)
+        lw t0, LISP_OBJECT_TYPE(s1)
         li t1, LISP_OBJECT_TYPE_CONS
         beq t0, t1, .Lprint_obj_cons
         li t1, LISP_OBJECT_TYPE_INTEGER
@@ -257,12 +257,29 @@ print_obj:
         beq t0, t1, .Lprint_obj_symbol
         li t1, LISP_OBJECT_TYPE_STRING
         beq t0, t1, .Lprint_obj_string
-        li t1, LISP_OBJECT_TYPE_PROCEDURE
-        beq t0, t1, .Lprint_obj_procedure
-        # print <??> if unrecognized
-        la a0, PRINT_UNRECOGNIZED_MSG
-        ld a1, (PRINT_UNRECOGNIZED_MSG_LENGTH)
-        call put_buf
+        # for anything else, print the raw fields
+        li a0, '<'
+        call putc
+        ld a0, 0x00(s1)
+        li a1, 16
+        call put_hex
+        li a0, ' '
+        call putc
+        ld a0, 0x08(s1)
+        li a1, 16
+        call put_hex
+        li a0, ' '
+        call putc
+        ld a0, 0x10(s1)
+        li a1, 16
+        call put_hex
+        li a0, ' '
+        call putc
+        ld a0, 0x18(s1)
+        li a1, 16
+        call put_hex
+        li a0, '>'
+        call putc
         j .Lprint_obj_ret
 .Lprint_obj_cons:
         li a0, '('
@@ -280,7 +297,7 @@ print_obj:
         li a0, ' '
         call putc
         # check if the type is CONS and loop if so
-        lwu t0, LISP_OBJECT_TYPE(s1)
+        lw t0, LISP_OBJECT_TYPE(s1)
         li t1, LISP_OBJECT_TYPE_CONS
         beq t0, t1, .Lprint_obj_cons_loop
         # this is an assoc so put the dot and space
@@ -336,23 +353,6 @@ print_obj:
         ld s3, 0x08(sp)
         addi sp, sp, 0x10
         j .Lprint_obj_ret
-.Lprint_obj_procedure:
-        # print <address data>
-        li a0, '<'
-        call putc
-        jal t0, .Lprint_obj_zero_x
-        ld a0, LISP_PROCEDURE_PTR(s1)
-        li a1, 16
-        call put_hex
-        li a0, ' '
-        call putc
-        jal t0, .Lprint_obj_zero_x
-        ld a0, LISP_PROCEDURE_DATA(s1)
-        li a1, 16
-        call put_hex
-        li a0, '>'
-        call putc
-        j .Lprint_obj_ret
 .Lprint_obj_zero_x:
         li a0, '0'
         call putc
@@ -365,8 +365,3 @@ print_obj:
         ld a0, 0x10(sp)
         addi sp, sp, 0x18
         ret
-
-.section .rodata
-
-PRINT_UNRECOGNIZED_MSG: .ascii "<??>"
-PRINT_UNRECOGNIZED_MSG_LENGTH: .quad . - PRINT_UNRECOGNIZED_MSG
diff --git a/stage1/parser.s b/stage1/parser.s
@@ -477,7 +477,7 @@ parse_token:
         # (empty list)
         ld t3, PARSER_STATE_E_CURRENT_NODE(s2)
         beqz t3, 1f # cons is not set yet
-        lwu t4, LISP_OBJECT_TYPE(t3)
+        lw t4, LISP_OBJECT_TYPE(t3)
         li t5, LISP_OBJECT_TYPE_CONS
         bne t4, t5, .Lparse_token_error # must assoc to a list
         ld t4, LISP_CONS_TAIL(t3)

diff --git a/stage1/words.s b/stage1/words.s
@@ -453,7 +453,7 @@ lookup_var:
 define:
         # check early for unacceptable arguments
         beqz a0, .Ldefine_err # can't define nil
-        lwu t0, LISP_OBJECT_TYPE(a0)
+        lw t0, LISP_OBJECT_TYPE(a0)
         li t1, LISP_OBJECT_TYPE_SYMBOL
         bne t0, t1, .Ldefine_err # can't define other than a symbol as key
         # setup stack so we can call stuff