call-native: specify how many return values after address

stage1/init.s

@@ -203,10 +203,17 @@ trap:
         mv a0, s1
         li a1, 16
         call put_hex
-1:
-        # loop forever
-        wfi
-        j 1b
+        # newline
+        li a0, '\n'
+        call putc
+        j shutdown
+
+.global shutdown
+shutdown:
+        # call opensbi sbi_shutdown
+        li a7, 0x08
+        ecall
+        1: j 1b
 
 .section .rodata
 
@@ -235,7 +242,7 @@ NOT_CALLABLE_MSG: .ascii "not-callable: "
 NOT_CALLABLE_MSG_LENGTH: .quad . - NOT_CALLABLE_MSG
 
 NO_FREE_MEM_MSG: .ascii "no-free-mem: "
-NO_FREE_MEM_MSG_LENGTH: .quad . - NO_FREE_MEM_MSG_LENGTH
+NO_FREE_MEM_MSG_LENGTH: .quad . - NO_FREE_MEM_MSG
 
 PRODUCE_MSG: .ascii "==> "
 PRODUCE_MSG_LENGTH: .quad . - PRODUCE_MSG

stage1/proc_builtin.s

@@ -102,21 +102,21 @@ proc_deref:
 
 # Lisp procedure for calling native routines.
 #
-# > (call-native address a0 a1 a2 a3 a4 a5 a6 a7)
-# ==> (a0 a1)
+# > (call-native address return-n a0 a1 a2 a3 a4 a5 a6 a7)
+# ==> (a0 a1 .. a<return-n>)
 .global proc_call_native
 proc_call_native:
-        addi sp, sp, -0x68
+        addi sp, sp, -0x70
         sd ra, 0x00(sp)
         sd s1, 0x08(sp) # pointer to args on stack
         sd s2, 0x10(sp) # arg list to process
         sd a1, 0x18(sp) # local words table
         mv s2, a0
-        # address 0x20, a0-a7 from 0x28 .. 0x68
+        # address 0x20, return-n 0x28, a0-a7 from 0x30 .. 0x70
         addi s1, sp, 0x20
         # just in case, zero that memory to avoid unwanted side effects
         mv t1, s1
-        addi t2, sp, 0x68
+        addi t2, sp, 0x70
 2:
         sd zero, (t1)
         addi t1, t1, 8
@@ -147,38 +147,62 @@ proc_call_native:
 .Lproc_call_native_invoke:
         # load address to t0
         ld t0, 0x20(sp)
+        beqz t0, .Lproc_call_native_exc # assert address != 0
+        # check that return-n is not > 8
+        ld t1, 0x28(sp)
+        li t2, 8
+        bgtu t1, t2, .Lproc_call_native_exc
         # load arguments from stack
-        ld a0, 0x28(sp)
-        ld a1, 0x30(sp)
-        ld a2, 0x38(sp)
-        ld a3, 0x40(sp)
-        ld a4, 0x48(sp)
-        ld a5, 0x50(sp)
-        ld a6, 0x58(sp)
-        ld a7, 0x60(sp)
+        ld a0, 0x30(sp)
+        ld a1, 0x38(sp)
+        ld a2, 0x40(sp)
+        ld a3, 0x48(sp)
+        ld a4, 0x50(sp)
+        ld a5, 0x58(sp)
+        ld a6, 0x60(sp)
+        ld a7, 0x68(sp)
         # do the call
         jalr ra, (t0)
-        # store a0
-        sd a0, 0x28(sp)
-        # make list (a0 a1)
-        mv a0, a1
-        call box_integer
-        beqz a0, .Lproc_call_native_nomem
-        mv a1, zero
-        call cons
-        beqz a0, .Lproc_call_native_nomem
-        # ==> (a1)
-        mv s1, a0
-        ld a0, 0x28(sp)
+        # store return args
+        sd a0, 0x30(sp)
+        sd a1, 0x38(sp)
+        sd a2, 0x40(sp)
+        sd a3, 0x48(sp)
+        sd a4, 0x50(sp)
+        sd a5, 0x58(sp)
+        sd a6, 0x60(sp)
+        sd a7, 0x68(sp)
+        # make return list in s2. first free it up
+        mv a0, s2
+        call release_object
+        mv s2, zero # nil
+        # calculate end of stack for return-n
+        addi s1, sp, 0x30 # beginning of args
+        ld t1, 0x28(sp) # return-n
+        slli t1, t1, 3 # x 8
+        add s1, s1, t1 # end of args to return
+.Lproc_call_native_ret_list_loop:
+        # check stack limit
+        addi t1, sp, 0x30
+        bleu s1, t1, .Lproc_call_native_ret_list
+        # decrement
+        addi s1, s1, -8
+        # load from stack, box
+        ld a0, (s1)
         call box_integer
         beqz a0, .Lproc_call_native_nomem
-        mv a1, s1
+        # form list
+        mv a1, s2
         call cons
         beqz a0, .Lproc_call_native_nomem
-        # ==> (a0 . (a1))
-        mv a1, a0
+        mv s2, a0
+        j .Lproc_call_native_ret_list_loop
+.Lproc_call_native_ret_list:
+        # take a1 (return value) from s2
+        mv a1, s2
         mv a0, zero # ok
-        j .Lproc_call_native_ret 
+        mv s2, zero # used
+        j .Lproc_call_native_ret
 .Lproc_call_native_exc:
         li a0, EVAL_ERROR_EXCEPTION
         mv a1, zero
@@ -200,7 +224,7 @@ proc_call_native:
         ld s2, 0x10(sp)
         ld a0, 0x20(sp)
         ld a1, 0x28(sp)
-        addi sp, sp, 0x68
+        addi sp, sp, 0x70
         ret
 
 # Peek

stage2/00-early.lsp

@@ -1,8 +1,8 @@
 ; (define <key> <value>) = ?
-(call-native define$
+(call-native define$ 0
   (ref (quote define))
   (ref (proc args scope
-    (call-native define$
+    (call-native define$ 0
       (ref (car args))
       (ref (eval scope (car (cdr args))))))))
 
@@ -16,7 +16,7 @@
 ; (allocate <size> <align>)
 (define allocate (proc args scope
   (car
-    (call-native allocate$
+    (call-native allocate$ 1
       (eval scope (car args))
       (eval scope (cadr args))))))
 
@@ -45,15 +45,15 @@
 ; redefine define to return the original value
 (define define (proc args scope
   (seq1
-    (call-native define$
+    (call-native define$ 0
       (ref (car args))
       (ref (eval scope (cadr args))))
     (eval scope (car args)))))
 
 ; (print <object>) = <object>
 (define print (proc args scope
   (deref (car
-    (call-native print-obj$
+    (call-native print-obj$ 1
       (ref (eval scope (car args))))))))
 
 ; (let1 <var> <value> <expression>)

stage2/02-logic.lsp

@@ -14,7 +14,7 @@
 (define swap-if
   (proc args scope
     (let1 address-pair
-      (call-native swap-if$
+      (call-native swap-if$ 2
         (eval scope (car args))
         (ref (eval scope (cadr args)))
         (ref (eval scope (cadr (cdr args)))))
@@ -44,16 +44,16 @@
   0x00008067 ; ret
 )
 (define zero? (proc args scope
-  (car (call-native zero?$ (eval scope (car args))))))
+  (car (call-native zero?$ 1 (eval scope (car args))))))
 
 ; Returns 1 if the argument is nil
 (define nil? (proc args scope
   (let1 value (ref (eval scope (car args)))
-    (cleanup value (car (call-native zero?$ value))))))
+    (cleanup value (car (call-native zero?$ 1 value))))))
 
 ; Returns 1 if the two numbers are equal
 (define number-eq? (proc args scope
-  (zero? (car (call-native ^$
+  (zero? (car (call-native ^$ 1
     (eval scope (car args))
     (eval scope (cadr args)))))))
 

stage2/03-list-util.lsp

@@ -12,7 +12,7 @@
           ; modify the tail of the cons in-place
           ; usually you should not do this
           (seq1
-            (poke.d (car (call-native +$ pair-ref 0x10)) (ref value))
+            (poke.d (car (call-native +$ 1 pair-ref 0x10)) (ref value))
             (deref pair-ref)))
         (eval scope' (cadr (cdr args))))))))
 

stage2/05-math.lsp

@@ -9,7 +9,7 @@
           (eval scope (car args)) ; no more args
           (let1 value
             (car ;a0
-              (call-native address
+              (call-native address 1
                 (eval scope (car args))
                 (eval scope (cadr args))))
             ; tail recursive call with remainder of args
@@ -28,7 +28,7 @@
 ; print hex number, plain
 (define put-hex (fn (number digits)
   (seq1
-    (call-native put-hex$ number
+    (call-native put-hex$ 0 number
       (if (nil? digits) 16 digits))
     number)))
 

stage2/06-types.lsp

@@ -6,7 +6,7 @@
 ; Get refcount of object
 (define refcount-of (fn (arg)
   (let1 address (ref arg)
-    (cleanup address (peek.w (car (call-native +$ address 0x4)))))))
+    (cleanup address (peek.w (car (call-native +$ 1 address 0x4)))))))
 
 ; Get type of object as symbol
 (define types$ (allocate 0x40 8))

stage2/21-more-io.lsp

@@ -3,14 +3,14 @@
   (if (symbol-eq? (type-of string) (quote string))
     (let1 address (ref string)
       (seq1
-        (call-native put-buf$
+        (call-native put-buf$ 0
           (peek.d (+ address 0x08))
           (peek.d (+ address 0x10)))
         (deref address)))
     (error (quote not-a-string:) string))))
 
 ; put char
-(define putc (fn (char) (seq1 (call-native putc$ char) char)))
+(define putc (fn (char) (seq1 (call-native putc$ 0 char) char)))
 
 ; print hex nicely
 (define print-hex