From bfc1173ed52399ebcaf9fc69844b9c14ebc5aebb Mon Sep 17 00:00:00 2001 From: water111 <48171810+water111@users.noreply.github.com> Date: Fri, 25 Jun 2021 17:55:50 -0400 Subject: [PATCH] Clean up files in kernel (#625) * clean up gcommon * cleanup kernel --- docs/markdown/progress-notes/changelog.md | 4 +- goal_src/goal-lib.gc | 17 + goal_src/goos-lib.gs | 4 + goal_src/kernel/gcommon.gc | 1070 ++++++++++----------- goal_src/kernel/gkernel.gc | 2 +- goal_src/kernel/gstring.gc | 377 ++++---- goalc/compiler/Compiler.h | 7 +- goalc/compiler/compilation/Type.cpp | 43 +- test/offline/offline_test_main.cpp | 4 - 9 files changed, 760 insertions(+), 768 deletions(-) diff --git a/docs/markdown/progress-notes/changelog.md b/docs/markdown/progress-notes/changelog.md index 1ff8a89df9..51f4b3fa39 100644 --- a/docs/markdown/progress-notes/changelog.md +++ b/docs/markdown/progress-notes/changelog.md @@ -165,4 +165,6 @@ - Fixed a bug where saved xmm registers might be clobbered when calling a C++ function that wasn't `format`. - The `declare-type` form now supports any parent type. The type system will do a better job of trying to make things work out when only part of the type hierarchy is defined, and you can now chain type forward declarations. The compiler is stricter and will not accept forward declarations that are possibly incompatible. Instead, forward declare enough types and their parents for the compiler to be able to figure it out. - The `deftype` form is more strict and will throw an error if the type definition is in any way incompatible with existing forward declarations of types. -- Added a `type-ref` form to insert a reference to a type into a static structure and optionally forward declare the number of methods \ No newline at end of file +- Added a `type-ref` form to insert a reference to a type into a static structure and optionally forward declare the number of methods +- The `method-of-type` form will now accept an expression returning a type instead of just a type name. In this case, it will only allow you to access method of `object`. +- Added a `defun-recursive` to make it easier to define recursive functions \ No newline at end of file diff --git a/goal_src/goal-lib.gc b/goal_src/goal-lib.gc index b4ff571e76..09edeb085f 100644 --- a/goal_src/goal-lib.gc +++ b/goal_src/goal-lib.gc @@ -217,6 +217,23 @@ ) ) +;; the compiler can't figure out types of a recursive function without +;; first knowing the return type, so we use this form to forward declare +;; and define a function. +(defmacro defun-recursive (name return-type bindings &rest body) + `(begin + (define-extern ,name + (function ,@(apply (lambda (x) + (if (pair? x) + (second x) + 'object) + ) + bindings) + ,return-type)) + (defun ,name ,bindings ,@body) + ) + ) + (defmacro defun-extern (function-name &rest type-info) `(define-extern ,function-name (function ,@type-info)) ) diff --git a/goal_src/goos-lib.gs b/goal_src/goos-lib.gs index 4379caf486..e774c8c220 100644 --- a/goal_src/goos-lib.gs +++ b/goal_src/goos-lib.gs @@ -157,6 +157,10 @@ `(type? 'integer ,x) ) +(defsmacro pair? (x) + `(type? 'pair ,x) + ) + (defsmacro ferror (&rest args) `(error (fmt #f ,@args)) ) diff --git a/goal_src/kernel/gcommon.gc b/goal_src/kernel/gcommon.gc index a3f6131324..0908899342 100644 --- a/goal_src/kernel/gcommon.gc +++ b/goal_src/kernel/gcommon.gc @@ -6,26 +6,22 @@ ;; dgos: KERNEL ;; gcommon is the first file compiled and loaded. -;; it's expected that this function will mostly be hand-decompiled +;; it implements some features of built-in types +;; and language constants +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Game constants +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; CONSTANTS -(defconstant NEW_METHOD_ID 0) -(defconstant DELETE_METHOD_ID 1) -(defconstant PRINT_METHOD_ID 2) -(defconstant INSPECT_METHOD_ID 3) -(defconstant LENGTH_METHOD_ID 4) -(defconstant ASIZE_METHOD_ID 5) -(defconstant COPY_METHOD_ID 6) -(defconstant RELOC_METHOD_ID 7) ;; or login? -(defconstant MEM_USAGE_METHOD_ID 8) - +;; disable PS2 only code and enable PC-specific code (defglobalconstant PC_PORT #t) + +;; redirects access to EE memory mapped registers through get-vm-ptr to valid addresses that +;; are monitored in the runtime for debugging. (defglobalconstant USE_VM #t) (defmacro get-vm-ptr (ptr) "Turn an EE register address into a valid PS2 VM address" - `(#cond (USE_VM (vm-ptr ,ptr) @@ -36,6 +32,21 @@ ) ) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; GOAL language constants +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; GOAL built-in method IDs +(defconstant NEW_METHOD_ID 0) +(defconstant DELETE_METHOD_ID 1) +(defconstant PRINT_METHOD_ID 2) +(defconstant INSPECT_METHOD_ID 3) +(defconstant LENGTH_METHOD_ID 4) +(defconstant ASIZE_METHOD_ID 5) +(defconstant COPY_METHOD_ID 6) +(defconstant RELOC_METHOD_ID 7) ;; or login? +(defconstant MEM_USAGE_METHOD_ID 8) + ;; distance from a symbol pointer to a (pointer string) ;; this relies on the memory layout of the symbol table ;; this must match SYM_INFO_OFFSET in goal_constants.h + offset of the str field in struct SymUpper. @@ -44,33 +55,42 @@ ;; pointers larger than this are invalid by valid? (defconstant END_OF_MEMORY #x8000000) -;; boxed object offset (16-byte alignement offsets) +;; GOAL boxed offsets use the lower three bits to indicate if they are +;; an integer (binteger), a pair, or a strucutre with type info (basic) (defconstant BINTEGER_OFFSET 0) (defconstant PAIR_OFFSET 2) (defconstant BASIC_OFFSET 4) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; GOAL language macros +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defmacro symbol->string (sym) "Convert a symbol to a goal string." `(-> (the-as (pointer string) (+ SYM_TO_STRING_OFFSET (the-as int ,sym)))) ) -;; forward declarations. -(define-extern name= (function basic basic symbol)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Function versions of built-in forms +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; basic operations like +, - are handled by the compiler. +;; these provide actual functions that wrap these common operations. (defun identity ((x object)) - "Function which returns its input. The first function of the game!" + "Function which returns its input. The first function of the game! + This will not preserve the upper 64-bits of a 128-bit value." x ) (defun 1/ ((x float)) "Reciprocal floating point" - ;; likely inlined? nothing calls this. (declare (inline)) (/ 1. x) ) -;; these next 4 functions are just function wrappers around the build in add/subtract/multiply/divide. -;; this will let you use + as an operation on integers and also as a function pointer. (defun + ((x int) (y int)) "Compute the sum of two integers" (+ x y) @@ -196,6 +216,10 @@ '#t ) +;;;;;;;;;;;;;;;;;;;;;;;;;; +;; format +;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; The C Kernel implements the format function and creates a trampoline function in the GOAL heap which jumps to ;; format. (In OpenGOAL, there's actually two trampoline functions, to make the 8 arguments all work.) ;; For some reason, the C Kernel names this trampoline function _format. We need to set the value of format @@ -205,8 +229,12 @@ ;; or 128-bit arguments (unimplemented in C Kernel), but both of these were never finished. (define format _format) -;; vec4s - this is present in the game as a 128-bit integer with 4 packed floats. -;; this isn't used very much. +;;;;;;;;;;;;;;;;;;;;;;;;;; +;; numeric types +;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; vec4s packs 4 floats into a single 128-bit integer register. +;; This is not used very often. (deftype vec4s (uint128) ((x float :offset 0) (y float :offset 32) @@ -244,6 +272,17 @@ ) ) +(defmacro make-u128 (upper lower) + "Make a i128 from two 64-bit values." + `(rlet ((result :class i128) + (upper-xmm :class i128) + (lower-xmm :class i128)) + (.mov upper-xmm ,upper) + (.mov lower-xmm ,lower) + (.pcpyld result upper-xmm lower-xmm) + (the-as uint result) + ) + ) ;; A "boxed float" type. Simply a float with type information. (deftype bfloat (basic) ((data float :offset-assert 4)) @@ -272,100 +311,99 @@ (align16 (+ 28 (* 4 (-> type allocated-length)))) ) - - (defun basic-type? ((obj basic) (parent-type type)) "Is obj of type parent-type? Note: this will return #f if you put a parent-type of object. Only use this with types that are fully defined." - (local-vars (obj-type type) (end-type type)) - - ;; note - this was likely a "do" loop. - (set! obj-type (-> obj type)) - (set! end-type object) - (until (begin - (set! obj-type (-> obj-type parent)) - (= obj-type end-type) - ) - (if (= obj-type parent-type) - (return '#t) + (let ((obj-type (-> obj type)) + (end-type object) ) + (until (begin + (set! obj-type (-> obj-type parent)) + (= obj-type end-type) + ) + (if (= obj-type parent-type) + (return #t) + ) + ) ) - '#f + #f ) (defun type-type? ((child-type type) (parent-type type)) "Is child-type a child (or equal to) parent-type? It is safe to use this on a type that is not fully set up, but in this case it will return #f." - (local-vars (end-type type)) - (set! end-type object) - (until (begin - (set! child-type (-> child-type parent)) - (or (= child-type end-type) (zero? child-type)) + (let ((end-type object)) + (until (begin + (set! child-type (-> child-type parent)) + (or (= child-type end-type) (zero? child-type)) + ) + (if (= child-type parent-type) + (return #t) ) - (if (= child-type parent-type) - (return '#t) - ) + ) ) - '#f + #f ) - (defun find-parent-method ((child-type type) (method-id int)) "Search the type tree for a parent type with a different method from the child, for the given method ID. DANGER: only call this if you expect to find something. - There are method-table range checks, so it may run off the end + There are no method-table range checks, so it may run off the end of a method table and return junk" - (local-vars - (current-method function) - (original-method function) - ) - (set! original-method (-> child-type method-table method-id)) - (until (!= current-method original-method) - (if (= child-type object) - (return nothing) - ) - (set! child-type (-> child-type parent)) - (set! current-method (-> child-type method-table method-id)) - (if (zero? current-method) - (return nothing) - ) + (local-vars (current-method function)) + (let ((original-method (-> child-type method-table method-id))) + (until (!= current-method original-method) + (if (= child-type object) + (return nothing) + ) + (set! child-type (-> child-type parent)) + (set! current-method (-> child-type method-table method-id)) + (if (zero? current-method) + (return nothing) + ) + ) ) current-method ) +(defmacro as-type (obj type) + "Macro to _safely_ convert to a different type, returning #f if the type doesn't match. + Does a runtime type check so it's expensive." + `(if (and (nonzero? ,obj) (type-type? (-> ,obj type) ,type)) + (the-as ,type ,obj) + ) + ) +;;;;;;;;;;;;;;;;;;;;;;;;;; +;; pairs, lists, etc +;;;;;;;;;;;;;;;;;;;;;;;;;; + (defun ref ((lst object) (index int)) "Get an entry in a proper list by index" - (let ((count 0)) - (while (< count index) - ;; inserted by GOAL compiler for EE loop bug (short loop) - (nop!) - (nop!) - (set! lst (cdr lst)) - (set! count (+ count 1)) - ) - (car lst) + (dotimes (count index) + (nop!) + (nop!) + (set! lst (cdr lst)) ) + (car lst) ) (defmethod length pair ((obj pair)) "Get the length of a proper list" - (local-vars (result int) (iter object)) + (local-vars (result int)) (cond - ((= obj '()) - ;; length of empty list is 0 + ((null? obj) (set! result 0) ) (else - (set! iter (cdr obj)) - (set! result 1) - (while (and (!= iter '()) - (pair? iter) ;; manually replaced. - ) - (set! result (+ result 1)) - (set! iter (cdr iter)) + (let ((iter (cdr obj))) + (set! result 1) + (while (and (not (null? iter)) (pair? iter)) + (+! result 1) + (set! iter (cdr iter)) + ) ) ) ) @@ -382,43 +420,34 @@ (defun last ((lst object)) "Get the last element in a proper list" - (local-vars (iter object)) - (set! iter lst) - (while (!= (cdr iter) '()) - ;; for EE loop bug. - (nop!) - (nop!) - (set! iter (cdr iter)) + (let ((iter lst)) + (while (not (null? (cdr iter))) + (nop!) + (nop!) + (set! iter (cdr iter)) + ) + iter ) - iter ) (defun member ((obj object) (lst object)) "Is obj in the list lst? Returns pair with obj as its car, or #f if not found." - (local-vars (iter object)) - (set! iter lst) - ;; loop until we reach the end or the object - (while (not (or (= iter '()) - (= (car iter) obj) - ) - ) - (set! iter (cdr iter)) - ) - - (if (!= iter '()) - ;; return the pair containing obj as its car. - iter - ;; #f is returned in the other case. + (let ((iter lst)) + (while (not (or (null? iter) (= (car iter) obj))) + (set! iter (cdr iter)) ) + (if (not (null? iter)) + iter + ) + ) ) +;; need to forward declare this, we haven't loaded the string library yet. +(define-extern name= (function basic basic symbol)) (defun nmember ((obj basic) (lst object)) "Is obj in the list lst? Check with the name= function." - (while (not (or (= lst '()) - (name= (the-as basic (car lst)) obj) - ) - ) + (while (not (or (= lst '()) (name= (the-as basic (car lst)) obj))) (set! lst (cdr lst)) ) (if (!= lst '()) @@ -429,17 +458,14 @@ (defun assoc ((item object) (alist object)) "Is item in the association list alist? Returns the key-value pair." - (local-vars (iter object)) - (set! iter alist) - (while (not (or (= iter '()) - (= (car (car iter)) item) - ) - ) - (set! iter (cdr iter)) - ) - (if (!= iter '()) - (car iter) + (let ((iter alist)) + (while (not (or (null? iter) (= (car (car iter)) item))) + (set! iter (cdr iter)) ) + (if (not (null? iter)) + (car iter) + ) + ) ) @@ -447,41 +473,34 @@ "Is there an entry with key item in the association list alist? Returns the key-value pair. Treats a key of 'else like an else case" - (local-vars (iter object)) - (set! iter alist) - (while (not (or (= iter '()) - (= (car (car iter)) item) - (= (car (car iter)) 'else) - ) - ) - (set! iter (cdr iter)) - ) - (if (!= iter '()) - (car iter) + (let ((iter alist)) + (while (not (or (null? iter) + (= (car (car iter)) item) + (= (car (car iter)) 'else))) + (set! iter (cdr iter)) ) + (if (not (null? iter)) + (car iter) + ) + ) ) (defun nassoc ((item-name string) (alist object)) "Is there an entry named item-name in the association list alist? Checks name with nmember or name= so you can have multiple keys. Returns the ([key|(key..)] . value) pair." - (local-vars (key object)) - (while (not (or - (= alist '()) - (begin - (set! key (car (car alist))) - (if (pair? key) - ;; multiple keys - (nmember item-name key) - ;; only one key - (name= (the-as basic key) item-name) + (while (not (or (null? alist) + (let ((key (car (car alist)))) + (if (pair? key) + (nmember item-name key) + (name= (the-as basic key) item-name) + ) ) - ) - ) + ) ) (set! alist (cdr alist)) ) - (if (!= alist '()) + (if (not (null? alist)) (car alist) ) ) @@ -490,49 +509,42 @@ "Is there an entry named item-name in the association list alist? Checks name with nmember for multiple keys or name= for single. Allows else as a single key that always matches" - (local-vars (key object)) - (while (not (or - (= alist '()) - (begin - (set! key (car (car alist))) - (if (pair? key) - ;; multiple keys - (nmember item-name key) - ;; single key, try match or accept else. - (or (name= (the-as basic key) item-name) - (= key 'else) + (while (not (or (null? alist) + (let ((key (car (car alist)))) + (if (pair? key) + (nmember item-name key) + (or + (name= (the-as basic key) item-name) + (= key 'else) + ) ) ) - ) - ) + ) ) (set! alist (cdr alist)) ) - (if (!= alist '()) + (if (not (null? alist)) (car alist) ) ) (defun append! ((front object) (back object)) - (local-vars (iter object)) + "Append back to front, return the combined list." (cond - ((= front '()) - ;; the first list was empty, just return the second one + ((null? front) + ;; can't append to '(), just return back. back ) (else - ;; get to the back of the front list - (set! iter front) - (while (!= (cdr iter) '()) - ;; for EE short loop bug. - (nop!) - (nop!) - (set! iter (cdr iter)) - ) - - ;; this check seems not needed? - (when (!= iter '()) - (set! (cdr iter) back) + (let ((iter front)) + (while (not (null? (cdr iter))) + (nop!) + (nop!) + (set! iter (cdr iter)) + ) + (if (not (null? iter)) + (set! (cdr iter) back) + ) ) front ) @@ -541,27 +553,23 @@ (defun delete! ((item object) (lst object)) "Remove the first occurance of item from lst (where item is actual a pair in the list)" - (local-vars (iter-prev object) (iter object)) (the-as pair (cond ((= item (car lst)) - ;; special case for lst starts with object. (cdr lst) ) (else - ;; iterate until (car iter) = item (or we reach the end) - (set! iter-prev lst) - (set! iter (cdr lst)) - (while (not (or (= iter '()) (= (car iter) item))) - (set! iter-prev iter) - (set! iter (cdr iter)) - ) - - ;; splice out the element to delete! - (if (!= iter '()) - (set! (cdr iter-prev) (cdr iter)) + (let ((iter-prev lst) + (iter (cdr lst)) + ) + (while (not (or (null? iter) (= (car iter) item))) + (set! iter-prev iter) + (set! iter (cdr iter)) ) - ;; return original list. + (if (not (null? iter)) + (set! (cdr iter-prev) (cdr iter)) + ) + ) lst ) ) @@ -570,37 +578,34 @@ (defun delete-car! ((item object) (lst object)) "Remove the first first occurance of an element from the list where (car elt) is item." - (local-vars (iter-prev object) (iter object)) - (cond ((= item (car (car lst))) - ;; special case for removing the first item. - (cdr lst) - ) - (else - ;; iterate until (car iter) is the thing we want to delete - (set! iter-prev lst) - (set! iter (cdr lst)) - (while (not (or (= iter '()) (= (car (car iter)) item))) - (set! iter-prev iter) - (set! iter (cdr iter)) + (cond + ((= item (car (car lst))) + (cdr lst) + ) + (else + (let ((iter-prev lst) + (iter (cdr lst)) ) - ;; splice out element to delete, if we got it. - (if (!= iter '()) - (set! (cdr iter-prev) (cdr iter)) - ) - lst + (while (not (or (null? iter) (= (car (car iter)) item))) + (set! iter-prev iter) + (set! iter (cdr iter)) ) - ) + (if (not (null? iter)) + (set! (cdr iter-prev) (cdr iter)) + ) + ) + lst + ) + ) ) (defun insert-cons! ((kv object) (alist object)) "Update an association list to have the given (key . value) pair kv. If it already exists in the list, remove it. DANGER: this function allocates memory on the global heap." - (local-vars (updated-list object)) - ;; possibly remove an existing entry - (set! updated-list (delete-car! (car kv) alist)) - ;; and put a new one in! - (new 'global 'pair kv updated-list) + (let ((updated-list (delete-car! (car kv) alist))) + (cons kv updated-list) + ) ) (defun sort ((lst object) (compare-func (function object object object))) @@ -611,55 +616,48 @@ For booleans, you must explicitly use TRUE and not a truthy value. Ex: (sort my-list (lambda ((x int) (y int)) (< x y))) will sort ascending. NOTE: if you use an integer, don't accidentally return TRUE." - (local-vars - (compare-result object) - (second-elt object) - (first-elt object) - (iter object) - (unsorted-count int) - ) - - ;; number of out-of-orders encountered - (set! unsorted-count -1) - - ;; loop until we have nothing unsorted - (while (nonzero? unsorted-count) - ;; assume sorted - (set! unsorted-count 0) - (set! iter lst) - - ;; loop over list (excluding last element, so we can grab pairs of elements) - (while (not (or (= (cdr iter) '()) - ;; (>= (shl (the-as int (cdr iter)) 62) 0) - (not-pair? (cdr iter)) - ) - ) - - ;; get the two elements, and compare - (set! first-elt (car iter)) - (set! second-elt (car (cdr iter))) - (set! compare-result (compare-func first-elt second-elt)) - ;; the compare function can return a few possible things. - ;; we assume "unsorted" if compare-result is #f explicitly, or if it positive. - ;; HOWEVER, '#t itself is positive. So if we get #t, we assume sorted. - ;; there is possibly an ambiguity, if you happen to return a positive integer that - ;; happens to be a pointer to #t, - (when (and - (or (not compare-result) (> (the-as int compare-result) 0)) - (!= compare-result '#t) - ) - ;; remember we hit an unsorted sequence - (set! unsorted-count (+ unsorted-count 1)) - ;; swap! - (set! (car iter) second-elt) - (set! (car (cdr iter)) first-elt) + ;; the compare function can return a few possible things. + ;; we assume "unsorted" if compare-result is #f explicitly, or if it positive. + ;; HOWEVER, '#t itself is positive. So if we get #t, we assume sorted. + ;; there is possibly an ambiguity, if you happen to return a positive integer that + ;; happens to be a pointer to #t, + (let ((unsorted-count -1)) + ;; loop, until unsorted count goes to 0. + (while (nonzero? unsorted-count) + ;; search for unsorted things... + (set! unsorted-count 0) + (let ((iter lst)) + (while (not (or (null? (cdr iter)) (not (pair? (cdr iter))))) + (let* ((first-elt (car iter)) + (seoncd-elt (car (cdr iter))) + (compare-result (compare-func first-elt seoncd-elt)) + ) + ;; the compare function can return a few possible things. + ;; we assume "unsorted" if compare-result is #f explicitly, or if it positive. + ;; HOWEVER, '#t itself is positive. So if we get #t, we assume sorted. + ;; there is possibly an ambiguity, if you happen to return a positive integer that + ;; happens to be a pointer to #t, + (when (and + (or (not compare-result) (> (the-as int compare-result) 0)) + (!= compare-result #t) + ) + (+! unsorted-count 1) + (set! (car iter) seoncd-elt) + (set! (car (cdr iter)) first-elt) + ) + ) + (set! iter (cdr iter)) + ) ) - (set! iter (cdr iter)) ) ) lst ) +;;;;;;;;;;;;;;;;;;;;;;;;;; +;; inline-array-class +;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; This is used as base class for boxed inline arrays. ;; The heap-base of the _type_ object will be used to store the stride ;; This way, you don't pay the price of storing the stride in each object. @@ -718,6 +716,18 @@ ) ) +;;;;;;;;;;;;;;;;;;;;;;;;;; +;; array +;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; the GOAL array type is a boxed array. +;; it is a basic that knows its content type, currently used length, and allocated length. +;; It can hold: +;; any boxed object (gets 4 bytes, so bintegers get clipped to 32-bits) +;; any structure/reference/pointer +;; any integer/float +;; It cannot hold any inlined structures. + (defmethod new array ((allocation symbol) (type-to-make type) (content-type type) (len int)) "Allocate a new array to hold len elements of type content-type. The content should either be a numeric type (child of number) @@ -745,251 +755,200 @@ (defmethod print array ((obj array)) "Print array." - (local-vars - (content-type-sym symbol) - (i int) - ) - (format '#t "#(") + (format #t "#(") (cond ((type-type? (-> obj content-type) integer) - ;; PRINT INTEGER ARRAY - (set! content-type-sym (-> obj content-type symbol)) - (cond - ((= content-type-sym 'int32) - (set! i 0) - (while (< i (-> obj length)) - (format '#t (if (zero? i) "~D" " ~D") (-> (the-as (array int32) obj) i)) - (set! i (+ i 1)) + (let ((content-type-sym (-> obj content-type symbol))) + (cond + ((= content-type-sym 'int32) + (dotimes (s5-0 (-> obj length)) + (format #t (if (zero? s5-0) "~D" " ~D") + (-> (the-as (array int32) obj) s5-0) + ) + ) ) - ) - ((= content-type-sym 'uint32) - (set! i 0) - (while (< i (-> obj length)) - (format '#t (if (zero? i) "~D" " ~D") (-> (the-as (array uint32) obj) i)) - (set! i (+ i 1)) + ((= content-type-sym 'uint32) + (dotimes (s5-1 (-> obj length)) + (format #t (if (zero? s5-1) "~D" " ~D") + (-> (the-as (array uint32) obj) s5-1) + ) + ) ) - ) - ((= content-type-sym 'int64) - (set! i 0) - (while (< i (-> obj length)) - (format '#t (if (zero? i) "~D" " ~D") (-> (the-as (array int64) obj) i)) - (set! i (+ i 1)) + ((= content-type-sym 'int64) + (dotimes (s5-2 (-> obj length)) + (format #t (if (zero? s5-2) "~D" " ~D") + (-> (the-as (array int64) obj) s5-2) + ) + ) ) - ) - ((= content-type-sym 'uint64) - (set! i 0) - (while (< i (-> obj length)) - (format '#t (if (zero? i) "#x~X" " #x~X") (-> (the-as (array uint64) obj) i)) - (set! i (+ i 1)) + ((= content-type-sym 'uint64) + (dotimes (s5-3 (-> obj length)) + (format #t (if (zero? s5-3) "#x~X" " #x~X") + (-> (the-as (array uint64) obj) s5-3) + ) + ) ) - ) - ((= content-type-sym 'int8) - (set! i 0) - (while (< i (-> obj length)) - (format '#t (if (zero? i) "~D" " ~D") (-> (the-as (array int8) obj) i)) - (set! i (+ i 1)) + ((= content-type-sym 'int8) + (dotimes (s5-4 (-> obj length)) + (format #t (if (zero? s5-4) "~D" " ~D") + (-> (the-as (array int8) obj) s5-4) + ) + ) ) - ) - ((= content-type-sym 'uint8) - (set! i 0) - (while (< i (-> obj length)) - (format '#t (if (zero? i) "~D" " ~D") (-> (the-as (array uint8) obj) i)) - (set! i (+ i 1)) + ((= content-type-sym 'uint8) + (dotimes (s5-5 (-> obj length)) + (format #t (if (zero? s5-5) "~D" " ~D") + (-> (the-as (array uint8) obj) s5-5) + ) + ) ) - ) - ((= content-type-sym 'int16) - (set! i 0) - (while (< i (-> obj length)) - (format '#t (if (zero? i) "~D" " ~D") (-> (the-as (array int16) obj) i)) - (set! i (+ i 1)) + ((= content-type-sym 'int16) + (dotimes (s5-6 (-> obj length)) + (format #t (if (zero? s5-6) "~D" " ~D") + (-> (the-as (array int16) obj) s5-6) + ) + ) ) - ) - ((= content-type-sym 'uint16) - (set! i 0) - (while (< i (-> obj length)) - (format '#t (if (zero? i) "~D" " ~D") (-> (the-as (array uint16) obj) i)) - (set! i (+ i 1)) + ((= content-type-sym 'uint16) + (dotimes (s5-7 (-> obj length)) + (format #t (if (zero? s5-7) "~D" " ~D") + (-> (the-as (array uint16) obj) s5-7) + ) + ) ) - ) - (else - ;; unhandled integer case. - ;; note, decompiler failed to put v1-40 here. I think condition "raising" happens at the wrong time. - (cond - ((or (= content-type-sym 'uint128) (= content-type-sym 'int128)) - (set! i 0) - ;; REMOVED. GOAL never uses these type of array (and can't even print int128s) - ;; if we need/want it later we'll have to do something more creative - (while (< i (-> obj length)) - (format #t (if (zero? i) "?" " ?")) - ;;(set! t9-10 format) - ;;(set! a0-21 '#t) - ;;(set! a1-11 (if (zero? i) "#x~X" " #x~X")) - ;;(set! v1-42 (+ (shl i 4) (the-as int (the-as (array uint128) obj)))) - ;;(.lq a2-8 12 v1-42) - ;;(t9-10 a0-21 a1-11 a2-8) - (set! i (+ i 1)) + (else + (cond + ((or (= content-type-sym 'uint128) (= content-type-sym 'int128)) + (dotimes (s5-8 (-> obj length)) + (format #t (if (zero? s5-8) "#x~X" " #x~X") + (-> (the-as (array uint128) obj) s5-8) + ) + ) ) - ) - (else - ;; unknown integer. treat as int32 - (set! i 0) - (while (< i (-> obj length)) - (format '#t (if (zero? i) "~D" " ~D") (-> (the-as (array int32) obj) i)) - (set! i (+ i 1)) + (else + (dotimes (s5-9 (-> obj length)) + (format #t (if (zero? s5-9) "~D" " ~D") + (-> (the-as (array int32) obj) s5-9) + ) + ) ) - ) + ) ) - ) + ) ) ) (else - ;; Not an integer cases. (cond ((= (-> obj content-type) float) - (set! i 0) - (while (< i (-> obj length)) - (if (zero? i) - (format '#t "~f" (-> (the-as (array float) obj) i)) - (format '#t " ~f" (-> (the-as (array float) obj) i)) + (dotimes (s5-10 (-> obj length)) + (if (zero? s5-10) + (format #t "~f" (-> (the-as (array float) obj) s5-10)) + (format #t " ~f" (-> (the-as (array float) obj) s5-10)) ) - (set! i (+ i 1)) ) ) (else - ;; totally unknown, try printing as boxed. - (set! i 0) - (while (< i (-> obj length)) - (if (zero? i) - (format '#t "~A" (-> (the-as (array basic) obj) i)) - (format '#t " ~A" (-> (the-as (array basic) obj) i)) + (dotimes (s5-11 (-> obj length)) + (if (zero? s5-11) + (format #t "~A" (-> (the-as (array basic) obj) s5-11)) + (format #t " ~A" (-> (the-as (array basic) obj) s5-11)) ) - (set! i (+ i 1)) ) ) ) ) ) - (format '#t ")") + (format #t ")") obj ) ;; definition for method of type array (defmethod inspect array ((obj array)) "Inspect an array" - (local-vars - (content-type-sym symbol) - (i int) - ) - (format '#t "[~8x] ~A~%" obj (-> obj type)) - (format '#t "~Tallocated-length: ~D~%" (-> obj allocated-length)) - (format '#t "~Tlength: ~D~%" (-> obj length)) - (format '#t "~Tcontent-type: ~A~%" (-> obj content-type)) - (format '#t "~Tdata[~D]: @ #x~X~%" (-> obj allocated-length) (-> obj data)) + (format #t "[~8x] ~A~%" obj (-> obj type)) + (format #t "~Tallocated-length: ~D~%" (-> obj allocated-length)) + (format #t "~Tlength: ~D~%" (-> obj length)) + (format #t "~Tcontent-type: ~A~%" (-> obj content-type)) + (format #t "~Tdata[~D]: @ #x~X~%" (-> obj allocated-length) (-> obj data)) (cond ((type-type? (-> obj content-type) integer) - (set! content-type-sym (-> obj content-type symbol)) - (cond - ((= content-type-sym 'int32) - (set! i 0) - (while (< i (-> obj length)) - (format '#t "~T [~D] ~D~%" i (-> (the-as (array int32) obj) i)) - (set! i (+ i 1)) + (let ((content-type-sym (-> obj content-type symbol))) + (cond + ((= content-type-sym 'int32) + (dotimes (s5-0 (-> obj length)) + (format #t "~T [~D] ~D~%" s5-0 (-> (the-as (array int32) obj) s5-0)) + ) ) - ) - ((= content-type-sym 'uint32) - (set! i 0) - (while (< i (-> obj length)) - (format '#t "~T [~D] ~D~%" i (-> (the-as (array uint32) obj) i)) - (set! i (+ i 1)) + ((= content-type-sym 'uint32) + (dotimes (s5-1 (-> obj length)) + (format #t "~T [~D] ~D~%" s5-1 (-> (the-as (array uint32) obj) s5-1)) + ) ) - ) - ((= content-type-sym 'int64) - (set! i 0) - (while (< i (-> obj length)) - (format '#t "~T [~D] ~D~%" i (-> (the-as (array int64) obj) i)) - (set! i (+ i 1)) + ((= content-type-sym 'int64) + (dotimes (s5-2 (-> obj length)) + (format #t "~T [~D] ~D~%" s5-2 (-> (the-as (array int64) obj) s5-2)) + ) ) - ) - ((= content-type-sym 'uint64) - (set! i 0) - (while (< i (-> obj length)) - (format '#t "~T [~D] #x~X~%" i (-> (the-as (array uint64) obj) i)) - (set! i (+ i 1)) + ((= content-type-sym 'uint64) + (dotimes (s5-3 (-> obj length)) + (format #t "~T [~D] #x~X~%" s5-3 (-> (the-as (array uint64) obj) s5-3)) + ) ) - ) - ((= content-type-sym 'int8) - (set! i 0) - (while (< i (-> obj length)) - (format '#t "~T [~D] ~D~%" i (-> (the-as (array int8) obj) i)) - (set! i (+ i 1)) + ((= content-type-sym 'int8) + (dotimes (s5-4 (-> obj length)) + (format #t "~T [~D] ~D~%" s5-4 (-> (the-as (array int8) obj) s5-4)) + ) ) - ) - ((= content-type-sym 'uint8) - (set! i 0) - (while (< i (-> obj length)) - (format '#t "~T [~D] ~D~%" i (-> (the-as (array int8) obj) i)) - (set! i (+ i 1)) + ((= content-type-sym 'uint8) + (dotimes (s5-5 (-> obj length)) + (format #t "~T [~D] ~D~%" s5-5 (-> (the-as (array int8) obj) s5-5)) + ) ) - ) - ((= content-type-sym 'int16) - (set! i 0) - (while (< i (-> obj length)) - (format '#t "~T [~D] ~D~%" i (-> (the-as (array int16) obj) i)) - (set! i (+ i 1)) + ((= content-type-sym 'int16) + (dotimes (s5-6 (-> obj length)) + (format #t "~T [~D] ~D~%" s5-6 (-> (the-as (array int16) obj) s5-6)) + ) ) - ) - ((= content-type-sym 'uint16) - (set! i 0) - (while (< i (-> obj length)) - (format '#t "~T [~D] ~D~%" i (-> (the-as (array uint16) obj) i)) - (set! i (+ i 1)) + ((= content-type-sym 'uint16) + (dotimes (s5-7 (-> obj length)) + (format #t "~T [~D] ~D~%" s5-7 (-> (the-as (array uint16) obj) s5-7)) + ) ) - ) - (else - ;; again, decompiler created a temp for the or here. - (cond - ((or (= content-type-sym 'int128) (= content-type-sym 'uint128)) - ;; REMOVED: GOAL doesn't print int128's anyway. - (set! i 0) - (while (< i (-> obj length)) - ;;(set! t9-14 format) - ;;(set! a0-25 '#t) - ;;(set! a1-15 "~T [~D] #x~X~%") - (format #t "~T [~D] ??~%" i) - ;;(set! a2-13 i) - ;;(set! v1-42 (+ (shl i 4) (the-as int obj))) - ;;(.lq a3-10 12 v1-42) - ;;(t9-14 a0-25 a1-15 a2-13 a3-10) - (set! i (+ i 1)) + (else + (cond + ((or (= content-type-sym 'int128) (= content-type-sym 'uint128)) + (dotimes (s5-8 (-> obj length)) + (format + #t + "~T [~D] #x~X~%" + s5-8 + (-> (the-as (array uint128) obj) s5-8) + ) + ) ) - ) - (else - (set! i 0) - (while (< i (-> obj length)) - (format '#t "~T [~D] ~D~%" i (-> (the (array int32) obj) i)) - (set! i (+ i 1)) + (else + (dotimes (s5-9 (-> obj length)) + (format #t "~T [~D] ~D~%" s5-9 (-> (the-as (array int32) obj) s5-9)) + ) ) - ) + ) ) - ) + ) ) ) (else - (cond ((= (-> obj content-type) float) - (set! i 0) - (while (< i (-> obj length)) - (format '#t "~T [~D] ~f~%" i (-> (the (array float) obj) i)) - (set! i (+ i 1)) - ) - ) - (else - (set! i 0) - (while (< i (-> obj length)) - (format '#t "~T [~D] ~A~%" i (-> (the (array basic) obj) i)) - (set! i (+ i 1)) - ) - ) - ) + (cond + ((= (-> obj content-type) float) + (dotimes (s5-10 (-> obj length)) + (format #t "~T [~D] ~f~%" s5-10 (-> (the-as (array float) obj) s5-10)) + ) + ) + (else + (dotimes (s5-11 (-> obj length)) + (format #t "~T [~D] ~A~%" s5-11 (-> (the-as (array basic) obj) s5-11)) + ) + ) + ) ) ) obj @@ -1013,21 +972,21 @@ ) ) +;;;;;;;;;;;;;;;;;;;;;;;; +;; memory manipulation +;;;;;;;;;;;;;;;;;;;;;;;; + (defun mem-copy! ((dst pointer) (src pointer) (size int)) "Memory copy. Not a very efficient optimization, but has no restrictions. Increasing address copy." - (local-vars (result pointer) (i int) (v1-1 symbol) (v1-2 symbol)) - (set! result dst) - (set! i 0) - (while (< i size) - ;; copy - (set! (-> (the-as (pointer uint8) dst)) (-> (the-as (pointer uint8) src))) - ;; increment pointers and count - (set! dst (&+ dst (the-as uint 1))) - (set! src (&+ src (the-as uint 1))) - (set! i (+ i 1)) + (let ((result dst)) + (dotimes (i size) + (set! (-> (the-as (pointer uint8) dst)) (-> (the-as (pointer uint8) src))) + (&+! dst 1) + (&+! src 1) + ) + result ) - result ) (defun qmem-copy<-! ((dst pointer) (src pointer) (size int)) @@ -1035,21 +994,20 @@ - dst and src should be 16-byte aligned. - size in bytes will be rounded up to 16-bytes - Ascending address copy." - (local-vars (result pointer) (qwc int)) - (set! result dst) - - ;; round up to nearest quadword count. - (set! qwc (sar (+ size 15) 4)) - (while (nonzero? qwc) - (set! qwc (+ qwc -1)) - ;; Use 128-bit OpenGOAL integers to do copy by quadword. - (set! (-> (the (pointer uint128) dst)) - (-> (the (pointer uint128) src))) - - (set! dst (&+ dst 16)) - (set! src (&+ src 16)) + (let ((result dst)) + (let ((qwc (/ (+ size 15) 16))) + (while (nonzero? qwc) + (+! qwc -1) + (set! + (-> (the-as (pointer uint128) dst)) + (-> (the-as (pointer uint128) src)) + ) + (&+! dst 16) + (&+! src 16) + ) + ) + result ) - result ) (defun qmem-copy->! ((dst pointer) (src pointer) (size int)) @@ -1057,61 +1015,56 @@ - dst and src should be 16-byte aligned. - size in bytes will be rounding up to nearest 16-bytes - Descending address copy" - (local-vars - (result pointer) - (qwc int) - (src-ptr pointer) - (dst-ptr pointer) - ) - - (set! result dst) - (set! qwc (sar (+ size 15) 4)) - ;; start at the end - (set! dst-ptr (&+ dst (the-as uint (shl qwc 4)))) - (set! src-ptr (&+ src (the-as uint (shl qwc 4)))) - (while (nonzero? qwc) - (set! qwc (+ qwc -1)) - (set! src-ptr (&+ src-ptr (the-as uint -16))) - (set! dst-ptr (&+ dst-ptr (the-as uint -16))) - - (set! (-> (the (pointer uint128) dst-ptr)) - (-> (the (pointer uint128) src-ptr))) + (let ((result dst)) + (let* ((qwc (/ (+ size 15) 16)) + (dst-ptr (&+ dst (* qwc 16))) + (src-ptr (&+ src (* qwc 16))) + ) + (while (nonzero? qwc) + (+! qwc -1) + (&+! dst-ptr -16) + (&+! src-ptr -16) + (set! + (-> (the-as (pointer uint128) dst-ptr)) + (-> (the-as (pointer uint128) src-ptr)) + ) + ) + ) + result ) - result ) (defun mem-set32! ((dst pointer) (size int) (value int)) "Normal memset, but by 32-bit word. NOTE: argument order is swapped from C" - (local-vars (result pointer) (i int)) - (set! result dst) - (set! i 0) - (while (< i size) - (set! (-> (the-as (pointer int32) dst)) value) - (set! dst (&+ dst 4)) - (nop!) - (set! i (+ i 1)) + (let ((result dst)) + (dotimes (i size) + (set! (-> (the-as (pointer int32) dst)) value) + (&+! dst 4) + (nop!) + ) + result ) - result ) (defun mem-or! ((dst pointer) (src pointer) (size int)) "Set the dst to (logior dst src) byte by byte. Not very efficient." - (local-vars (result pointer) (i int) (v1-1 symbol) (v1-2 symbol)) - (set! result dst) - (set! i 0) - (while (< i size) - (set! (-> (the-as (pointer uint8) dst)) - (logior (-> (the-as (pointer uint8) dst)) - (-> (the-as (pointer uint8) src))) - ) - (set! dst (&+ dst 1)) - (set! src (&+ src 1)) - (set! i (+ i 1)) + (let ((result dst)) + (dotimes (i size) + (set! + (-> (the-as (pointer uint8) dst)) + (logior + (-> (the-as (pointer uint8) dst)) + (-> (the-as (pointer uint8) src)) + ) + ) + (&+! dst 1) + (&+! src 1) + ) + result ) - result ) @@ -1121,56 +1074,55 @@ 0 ) -;; we need to forward declare recursive functions so the compiler -;; know their return type. -(define-extern fact (function int int)) -(defun fact ((x int)) +(defun-recursive fact int ((x int)) (if (= x 1) 1 (* x (fact (+ x -1)))) ) -;; Print utilities. +;;;;;;;;;;;;;;;;;;;;;;;; +;; printing +;;;;;;;;;;;;;;;;;;;;;;;; + +;; the column that will be printed to by format. (define *print-column* (the binteger 0)) -(defun print ((obj object)) +(defun print ((arg0 object)) "Print out any boxed object. Does NOT insert a newline." - (let ((print-method (-> (rtype-of obj) method-table PRINT_METHOD_ID))) - ((the (function object object) print-method) obj) - ) + ((method-of-type (rtype-of arg0) print) arg0) ) -(defun printl ((obj object)) +(defun printl ((arg0 object)) "Print out any boxed object and a newline at the end." - (let ((print-method (-> (rtype-of obj) method-table PRINT_METHOD_ID))) - ((the (function object object) print-method) obj) - (format #t "~%") - obj) + (let ((a0-1 arg0)) + ((method-of-type (rtype-of a0-1) print) a0-1) + ) + (format #t "~%") + arg0 ) -(defun inspect ((obj object)) +(defun inspect ((arg0 object)) "Inspect any boxed object." - (let ((inspect-method (-> (rtype-of obj) method-table INSPECT_METHOD_ID))) - ((the (function object object) inspect-method) obj) - ) + ((method-of-type (rtype-of arg0) inspect) arg0) ) +;;;;;;;;;;;;;;;;;;;;; +;; debug utils +;;;;;;;;;;;;;;;;;;;;; + (defun-debug mem-print ((data (pointer uint32)) (word-count int)) "Print memory to runtime stdout by quadword. Input count is in 32-bit words" - (local-vars (current-qword int)) - (set! current-qword 0) - (while (< current-qword (sar word-count 2)) + (dotimes (current-qword (/ word-count 4)) (format 0 "~X: ~X ~X ~X ~X~%" - (+ (+ (shl (shl current-qword 2) 2) 0) (the-as int data)) - (-> data (shl current-qword 2)) - (-> data (+ (shl current-qword 2) 1)) - (-> data (+ (shl current-qword 2) 2)) - (-> data (+ (shl current-qword 2) 3)) + (&-> data (* current-qword 4)) + (-> data (* current-qword 4)) + (-> data (+ (* current-qword 4) 1)) + (-> data (+ (* current-qword 4) 2)) + (-> data (+ (* current-qword 4) 3)) ) - (set! current-qword (+ current-qword 1)) ) - '#f + #f ) ;; not sure what this is. @@ -1178,25 +1130,26 @@ (defun print-tree-bitmask ((bits int) (count int)) "Print out a single entry for a process tree 'tree' diagram" - (local-vars (i int)) - (set! i 0) - (while (< i count) + (dotimes (i count) (if (zero? (logand bits 1)) - (format '#t " ") - (format '#t "| ") + (format #t " ") + (format #t "| ") ) (set! bits (shr bits 1)) - (set! i (+ i 1)) ) - '#f + #f ) (defun breakpoint-range-set! ((a0 uint) (a1 uint) (a2 uint)) - "Sets some debug register (COP0 Debug, dab, dabm)" + "Sets some debug register (COP0 Debug, dab, dabm) to break on memory access. + This is not supported in OpenGOAL." (format 0 "breakpoint-range-set! not supported in OpenGOAL~%") 0 ) +;;;;;;;;;;;;;;;;;;;;;;; +;; valid +;;;;;;;;;;;;;;;;;;;;;;; ;; these are not quite right, but it's close enough. (defmacro start-of-symbol-table () @@ -1237,6 +1190,7 @@ ) ;; first, check if we are even in valid memory. This is the start of the symbol table to the end of RAM. + ;; (note, this will fail stuff like the debug and global heap info objects, which aren't in GOAL heaps.) (set! in-goal-mem (and (>= (the-as uint obj) (start-of-symbol-table)) (< (the-as uint obj) END_OF_MEMORY) ) @@ -1266,7 +1220,7 @@ ((and allow-false (not obj)) ;; we got a false, but its allowed! ;; note that we don't reject falses otherwise, as false is a perfectly valid symbol. - '#t) + #t) (else (cond ((= expected-type structure) @@ -1401,6 +1355,9 @@ ) +;;;;;;;;;;;;;;;;;;;;;;; +;; PC Port asm macros +;;;;;;;;;;;;;;;;;;;;;;; (#when PC_PORT ;; SYNC is an EE instruction that waits for various memory access and DMA to be completed ;; DMA will be instant in the PC port, so these are no longer necessary @@ -1411,22 +1368,3 @@ ;; Copies the contents of a gpr to a cop0 (system control) register (fake-asm .mtc0 dest src) ) - - -(defmacro make-u128 (upper lower) - "Make a i128 from two 64-bit values." - `(rlet ((result :class i128) - (upper-xmm :class i128) - (lower-xmm :class i128)) - (.mov upper-xmm ,upper) - (.mov lower-xmm ,lower) - (.pcpyld result upper-xmm lower-xmm) - (the-as uint result) - ) - ) - -(defmacro as-type (obj type) - `(if (and (nonzero? ,obj) (type-type? (-> ,obj type) ,type)) - (the-as ,type ,obj) - ) - ) diff --git a/goal_src/kernel/gkernel.gc b/goal_src/kernel/gkernel.gc index 49abb161eb..74cd3550af 100644 --- a/goal_src/kernel/gkernel.gc +++ b/goal_src/kernel/gkernel.gc @@ -98,7 +98,7 @@ ;; all user code (that I know of) runs using *dram-stack* (define *dram-stack* (new 'global 'array 'uint8 DPROCESS_STACK_SIZE)) ;; note - this name is a bit confusing. The kernel-dram-stack is not the stack that the kernel runs in. -;; I think it refers to the fact that it's _not_ the scratchpad stack (which wasn't used anyway) +;; I think it refers to the fact that it's _not_ the scratchpad stack (defconstant *kernel-dram-stack* (&+ *dram-stack* DPROCESS_STACK_SIZE)) ;; I don't think this stack is used, but I'm not sure. diff --git a/goal_src/kernel/gstring.gc b/goal_src/kernel/gstring.gc index 13ecdfa001..55d3410327 100644 --- a/goal_src/kernel/gstring.gc +++ b/goal_src/kernel/gstring.gc @@ -5,11 +5,20 @@ ;; name in dgo: gstring ;; dgos: KERNEL -;; Note on strings: -;; the allocated length does not include an extra byte on the end for the null terminator! + +;; The GOAL string type is like a C string plus a length field. +;; The number of bytes stored is the length + 1 for the null terminator. +;; Note that string is a bit of a special type, and the compiler assumes there is no +;; child type of string ever created. + + + +;;;;;;;;;;;;;;;;;;;;;;;;; +;; String methods +;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod length string ((obj string)) - ; Get the length of a string. Like strlen + "Get the length of a string. Like strlen" (let ((str-ptr (-> obj data))) (while (!= 0 (-> str-ptr 0)) (set! str-ptr (the (pointer uint8) (&+ str-ptr 1))) @@ -19,9 +28,7 @@ ) (defmethod asize-of string ((obj string)) - ;; get the size in bytes of a string. - ;; BUG - string should probably be (-> obj type), not that it matters, I don't think - ;; anybody makes a subclass of string. + "get the size in bytes of a string." (+ (-> obj allocated-length) 1 (-> string size)) ) @@ -60,39 +67,43 @@ ) ) +;;;;;;;;;;;;;;;;;;;;;;;;; +;; String comparison +;;;;;;;;;;;;;;;;;;;;;;;;; + (defun string= ((str-a string) (str-b string)) "Does str-a hold the same data as str-b?. If either string is null, returns #f." - (local-vars (b-ptr (pointer uint8)) (a-ptr (pointer uint8))) - (set! a-ptr (-> str-a data)) - (set! b-ptr (-> str-b data)) - (if (or (zero? str-a) (zero? str-b)) - (return '#f) - ) - ;; loop until we reach the end of one string - (while (and (nonzero? (-> a-ptr 0)) (nonzero? (-> b-ptr 0))) - (if (!= (-> a-ptr 0) (-> b-ptr 0)) - (return '#f) + (let ((a-ptr (-> str-a data)) + (b-ptr (-> str-b data)) ) - (set! a-ptr (&-> a-ptr 1)) - (set! b-ptr (&-> b-ptr 1)) - ) - ;; only equal if both at the end. - (and (zero? (-> a-ptr 0)) (zero? (-> b-ptr 0))) + (if (or (zero? str-a) (zero? str-b)) + (return #f) + ) + (while (and (nonzero? (-> a-ptr 0)) (nonzero? (-> b-ptr 0))) + (if (!= (-> a-ptr 0) (-> b-ptr 0)) + (return #f) + ) + (set! a-ptr (&-> a-ptr 1)) + (set! b-ptr (&-> b-ptr 1)) + ) + ;; only equal if both end here. + (and (zero? (-> a-ptr 0)) (zero? (-> b-ptr 0))) + ) ) (defun string-charp= ((str string) (charp (pointer uint8))) "Is the data in str equal to the C string charp?" - (local-vars (str-ptr (pointer uint8))) - (set! str-ptr (-> str data)) - (while (and (nonzero? (-> str-ptr 0)) (nonzero? (-> charp 0))) - (if (!= (-> str-ptr 0) (-> charp 0)) - (return '#f) - ) - (set! str-ptr (&-> str-ptr 1)) - (set! charp (&-> charp 1)) - ) - (and (zero? (-> str-ptr 0)) (zero? (-> charp 0))) + (let ((str-ptr (-> str data))) + (while (and (nonzero? (-> str-ptr 0)) (nonzero? (-> charp 0))) + (if (!= (-> str-ptr 0) (-> charp 0)) + (return #f) + ) + (set! str-ptr (&-> str-ptr 1)) + (set! charp (&-> charp 1)) + ) + (and (zero? (-> str-ptr 0)) (zero? (-> charp 0))) + ) ) (defun name= ((arg0 basic) (arg1 basic)) @@ -100,8 +111,8 @@ This can use either strings or symbols" (cond ((= arg0 arg1) - "Either same symbols, or same string objects, fast check pass!" - '#t) + ;; Either same symbols, or same string objects, fast check pass! + #t) ((and (= (-> arg0 type) string) (= (-> arg1 type) string)) (string= (the-as string arg0) (the-as string arg1)) ) @@ -111,35 +122,38 @@ ((and (= (-> arg1 type) string) (= (-> arg0 type) symbol)) (string= (the-as string arg1) (symbol->string arg0)) ) + ;; no need to check symbol - symbol, that would have passed the first check. ) ) +;;;;;;;;;;;;;;;;;;;;;;;;; +;; String copying +;;;;;;;;;;;;;;;;;;;;;;;;; + (defun copyn-string<-charp ((str string) (charp (pointer uint8)) (len int)) "Copy data from a charp to a GOAL string. Copies len chars, plus a null." - (local-vars (str-ptr (pointer uint8)) (i int)) - (set! str-ptr (-> str data)) - (set! i 0) - (while (< i len) - (set! (-> str-ptr 0) (-> charp 0)) - (set! str-ptr (&-> str-ptr 1)) - (set! charp (&-> charp 1)) - (set! i (+ i 1)) + (let ((str-ptr (-> str data))) + (dotimes (i len) + (set! (-> str-ptr 0) (-> charp 0)) + (set! str-ptr (&-> str-ptr 1)) + (set! charp (&-> charp 1)) + ) + (set! (-> str-ptr 0) (the-as uint 0)) ) - (set! (-> str-ptr 0) 0) str ) (defun string<-charp ((str string) (charp (pointer uint8))) "Copy all chars from a char* to a GOAL string. Does NO length checking." - (local-vars (str-ptr (pointer uint8))) - (set! str-ptr (-> str data)) - (while (nonzero? (-> charp 0)) - (set! (-> str-ptr 0) (-> charp 0)) - (set! str-ptr (&-> str-ptr 1)) - (set! charp (&-> charp 1)) + (let ((str-ptr (-> str data))) + (while (nonzero? (-> charp 0)) + (set! (-> str-ptr 0) (-> charp 0)) + (set! str-ptr (&-> str-ptr 1)) + (set! charp (&-> charp 1)) + ) + (set! (-> str-ptr 0) (the-as uint 0)) ) - (set! (-> str-ptr 0) 0) str ) @@ -169,47 +183,38 @@ (defun cat-string<-string ((a string) (b string)) "Append b to a. No length checks" - (local-vars (a-ptr (pointer uint8)) (b-ptr (pointer uint8))) - (set! a-ptr (-> a data)) - (set! b-ptr (-> b data)) - ;; seek to the end of a - (while (nonzero? (-> a-ptr 0)) - (nop!) - (nop!) - (nop!) - (set! a-ptr (&-> a-ptr 1)) + (let ((a-ptr (-> a data))) + (let ((b-ptr (-> b data))) + (while (nonzero? (-> a-ptr 0)) + (nop!) + (nop!) + (nop!) + (set! a-ptr (&-> a-ptr 1)) + ) + (while (nonzero? (-> b-ptr 0)) + (set! (-> a-ptr 0) (-> b-ptr 0)) + (set! a-ptr (&-> a-ptr 1)) + (set! b-ptr (&-> b-ptr 1)) + ) + ) + (set! (-> a-ptr 0) (the-as uint 0)) ) - ;; append b - (while (nonzero? (-> b-ptr 0)) - (set! (-> a-ptr 0) (-> b-ptr 0)) - (set! a-ptr (&-> a-ptr 1)) - (set! b-ptr (&-> b-ptr 1)) - ) - ;; null terminate - (set! (-> a-ptr 0) 0) a ) (defun catn-string<-charp ((a string) (b (pointer uint8)) (len int)) "Append b to a, exactly len chars" - (local-vars (a-ptr (pointer uint8)) (i int) ) - (set! a-ptr (-> a data)) - ;; seek to end of a - (while (nonzero? (-> a-ptr 0)) - (nop!) - (nop!) - (nop!) - (set! a-ptr (&-> a-ptr 1)) + (let ((a-ptr (-> a data))) + (while (nonzero? (-> a-ptr 0)) + (set! a-ptr (&-> a-ptr 1)) + ) + (dotimes (i len) + (set! (-> a-ptr 0) (-> b 0)) + (set! a-ptr (&-> a-ptr 1)) + (set! b (&-> b 1)) + ) + (set! (-> a-ptr 0) (the-as uint 0)) ) - ;; append - (set! i 0) - (while (< i len) - (set! (-> a-ptr 0) (-> b 0)) - (set! a-ptr (&-> a-ptr 1)) - (set! b (&-> b 1)) - (set! i (+ i 1)) - ) - (set! (-> a-ptr 0) 0) a ) @@ -254,6 +259,10 @@ ) ) +;;;;;;;;;;;;;;;;;;;;;;;;; +;; String utilities +;;;;;;;;;;;;;;;;;;;;;;;;; + (defun charp-basename ((charp (pointer uint8))) "Like basename in C" (let ((ptr charp)) @@ -282,6 +291,10 @@ ) +;;;;;;;;;;;;;;;;;;;;;;;;; +;; String ordering +;;;;;;;;;;;;;;;;;;;;;;;;; + ;; NOTE: these string comparisons are a little broken. ;; ex: (string a data i) (-> b data i)) + (return #t) + ) + ((< (-> b data i) (-> a data i)) + (return #f) + ) ) - - ;; loop through chars, up until the minimum length. - (set! i 0) - (while (< i len) - (cond - ((< (-> a data i) (-> b data i)) (return '#t)) - ((< (-> b data i) (-> a data i)) (return '#f)) + ) ) - (set! i (+ i 1)) - ) - '#f + #f ) (defun string>? ((a string) (b string)) "In dictionary order, is a > b?" - (local-vars (i int) (len int)) - (set! len (min ((method-of-type string length) a) - ((method-of-type string length) b)) + (let ((len (min (length a) (length b)))) + (dotimes (i len) + (cond + ((< (-> a data i) (-> b data i)) + (return #f) + ) + ((< (-> b data i) (-> a data i)) + (return #t) + ) ) - (set! i 0) - (while (< i len) - (cond - ((< (-> a data i) (-> b data i)) (return '#f)) - ((< (-> b data i) (-> a data i)) (return '#t)) ) - (set! i (+ i 1)) ) - '#f + #f ) (defun string<=? ((a string) (b string)) - (local-vars (i int) (len int)) - (set! len (min ((method-of-type string length) a) - ((method-of-type string length) b)) - ) - (set! i 0) - (while - (< i len) - (cond - ((< (-> a data i) (-> b data i)) (return '#t)) - ((< (-> b data i) (-> a data i)) (return '#f)) + (let ((len (min (length a) (length b)))) + (dotimes (i len) + (cond + ((< (-> a data i) (-> b data i)) + (return #t) + ) + ((< (-> b data i) (-> a data i)) + (return #f) + ) + ) + ) ) - (set! i (+ i 1)) - ) - '#t + #t ) (defun string>=? ((a string) (b string)) - (local-vars (i int) (len int)) - (set! len (min ((method-of-type string length) a) - ((method-of-type string length) b)) + (let ((len (min (length a) (length b)))) + (dotimes (i len) + (cond + ((< (-> a data i) (-> b data i)) + (return #f) + ) + ((< (-> b data i) (-> a data i)) + (return #t) + ) ) - (set! i 0) - (while (< i len) - (cond - ((< (-> a data i) (-> b data i)) (return '#f)) - ((< (-> b data i) (-> a data i)) (return '#t)) ) - (set! i (+ i 1)) ) - '#t + #t ) +;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; String argument parsing +;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; temporary string for argument functions (define *string-tmp-str* (new 'global 'string 128 (the string #f))) @@ -480,63 +490,56 @@ The arguments can be in quotes or not. Removes argument from arg string, sucks up white space before the next one Outputs argument to a-str." - (local-vars - (arg-start (pointer uint8)) - (v1-11 (pointer uint8)) - (a0-6 symbol) - (a0-20 symbol) - (a1-3 (pointer uint8)) - (a1-9 (pointer uint8)) - (arg-word-start (pointer uint8)) - (arg-end (pointer uint8)) - ) - ;; seek up the beginning of a word. - (set! arg-word-start (string-skip-whitespace (-> arg data))) - (cond - ((= (-> arg-word-start 0) 34) ;; starts with quote - ;; seek past quote to first char of name - (set! arg-end (&-> arg-word-start 1)) - ;; now, find the end - (set! arg-start arg-end) - (while (and (nonzero? (-> arg-end 0)) - ;; (nonzero? (+ (-> arg-end 0) -34)) - (!= (-> arg-end 0) 34) ;; quote + + ;; seek to first arg + (let ((arg-word-start (string-skip-whitespace (-> arg data)))) + (cond + ((= (-> arg-word-start 0) 34) ;; starts with quote + ;; seek past quote + (let ((arg-end (&-> arg-word-start 1))) + ;; now find end + (let ((arg-start arg-end)) + (while (and (nonzero? (-> arg-end 0)) (!= (-> arg-end 0) 34)) ;; close quote + (set! arg-end (&-> arg-end 1)) + ) + ;; copy to output + (copyn-string<-charp a-str arg-start (&- arg-end (the-as uint arg-start))) + ) + + ;; if we got a close quote, seek past it. + (if (= (-> arg-end 0) 34) + (set! arg-end (&-> arg-end 1)) + ) + + ;; kill leading white space + (let ((a1-3 (string-skip-whitespace arg-end))) + (string-suck-up! arg a1-3) + ) + ) + (return #t) + ) + ((nonzero? (-> arg-word-start 0)) + (let ((v1-11 arg-word-start)) + ;; find end + (while (and + (nonzero? (-> arg-word-start 0)) + (!= (-> arg-word-start 0) 32) + (!= (-> arg-word-start 0) 9) + (!= (-> arg-word-start 0) 13) + (!= (-> arg-word-start 0) 10) ) - (set! arg-end (&-> arg-end 1)) + (set! arg-word-start (&-> arg-word-start 1)) + ) + (copyn-string<-charp a-str v1-11 (&- arg-word-start (the-as uint v1-11))) + ) + (let ((a1-9 (string-skip-whitespace arg-word-start))) + (string-suck-up! arg a1-9) + ) + (return #t) ) - - ;; copy to output. - (copyn-string<-charp a-str arg-start (- (the-as int arg-end) (the-as uint arg-start))) - - ;; if we got a close quote - (when (= (-> arg-end 0) 34) - ;; seek past it - (set! arg-end (&-> arg-end 1)) - ) - (set! a1-3 (string-skip-whitespace arg-end)) - (string-suck-up! arg a1-3) - (return '#t) - ) - ((nonzero? (-> arg-word-start 0)) - - (set! v1-11 arg-word-start) - (while - (and - (nonzero? (-> arg-word-start 0)) - (nonzero? (+ (-> arg-word-start 0) -32)) - (nonzero? (+ (-> arg-word-start 0) -9)) - (nonzero? (+ (-> arg-word-start 0) -13)) - (nonzero? (+ (-> arg-word-start 0) -10)) - ) - (set! arg-word-start (&-> arg-word-start 1)) - ) - (copyn-string<-charp a-str v1-11 (- (the-as int arg-word-start) (the-as uint v1-11))) - (set! a1-9 (string-skip-whitespace arg-word-start)) - (string-suck-up! arg a1-9) - (return '#t) - ) + ) ) - '#f + #f ) (defun string->int ((str string)) diff --git a/goalc/compiler/Compiler.h b/goalc/compiler/Compiler.h index 16069bf2be..fed49a3f09 100644 --- a/goalc/compiler/Compiler.h +++ b/goalc/compiler/Compiler.h @@ -285,7 +285,12 @@ class Compiler { StructureType* type); Val* generate_inspector_for_bitfield_type(const goos::Object& form, Env* env, BitFieldType* type); RegVal* compile_get_method_of_type(const goos::Object& form, - const TypeSpec& type, + const TypeSpec& compile_time_type, + RegVal* type_object, + const std::string& method_name, + Env* env); + RegVal* compile_get_method_of_type(const goos::Object& form, + const TypeSpec& compile_time_type, const std::string& method_name, Env* env); RegVal* compile_get_method_of_object(const goos::Object& form, diff --git a/goalc/compiler/compilation/Type.cpp b/goalc/compiler/compilation/Type.cpp index 93b49e65a9..aaf0ef931f 100644 --- a/goalc/compiler/compilation/Type.cpp +++ b/goalc/compiler/compilation/Type.cpp @@ -17,25 +17,28 @@ int get_offset_of_method(int id) { } // namespace /*! - * Given a type and method name (known at compile time), get the method. - * This can be used for method calls where the type is unknown at run time (non-virtual method call) + * Given a type and method name (known at compile time), get the method, from the given type object. + * To do method lookup, the given type must be the same as, or a child of, the given compile time + * type. */ -RegVal* Compiler::compile_get_method_of_type(const goos::Object& form, - const TypeSpec& type, +RegVal* Compiler::compile_get_method_of_type(const goos::Object& /*form*/, + const TypeSpec& compile_time_type, + RegVal* type, const std::string& method_name, Env* env) { - auto info = m_ts.lookup_method(type.base_type(), method_name); - info.type = info.type.substitute_for_method_call(type.base_type()); + auto info = m_ts.lookup_method(compile_time_type.base_type(), method_name); + info.type = info.type.substitute_for_method_call(compile_time_type.base_type()); auto offset_of_method = get_offset_of_method(info.id); + assert(type->type() == TypeSpec("type")); auto fe = get_parent_env_of_type(env); - auto typ = compile_get_symbol_value(form, type.base_type(), env)->to_gpr(env); + MemLoadInfo load_info; load_info.sign_extend = false; load_info.size = POINTER_SIZE; auto loc_type = m_ts.make_pointer_typespec(info.type); - auto loc = fe->alloc_val(loc_type, typ, offset_of_method); + auto loc = fe->alloc_val(loc_type, type, offset_of_method); auto di = m_ts.get_deref_info(loc_type); assert(di.can_deref); assert(di.mem_deref); @@ -46,6 +49,19 @@ RegVal* Compiler::compile_get_method_of_type(const goos::Object& form, return deref->to_reg(env); } +/*! + * Look up a method from the type, with the type specified at compile time. + * This can be used for method calls where the type can't be found at run time, but is known at + * compile time. (non-virtual method call) + */ +RegVal* Compiler::compile_get_method_of_type(const goos::Object& form, + const TypeSpec& compile_time_type, + const std::string& method_name, + Env* env) { + auto typ = compile_get_symbol_value(form, compile_time_type.base_type(), env)->to_gpr(env); + return compile_get_method_of_type(form, compile_time_type, typ, method_name, env); +} + /*! * Given an object, get a method. If at compile time we know it's a basic, we use its runtime * type to look up the method at runtime (virtual call). If we don't know it's a basic, we get the @@ -1091,6 +1107,8 @@ Val* Compiler::compile_method_of_type(const goos::Object& form, auto arg = args.unnamed.at(0); auto method_name = symbol_string(args.unnamed.at(1)); + // in order to do proper method lookup, we peek at the symbol that the user provided and see if + // its a type name if (arg.is_symbol()) { if (m_ts.fully_defined_type_exists(symbol_string(arg))) { return compile_get_method_of_type(form, m_ts.make_typespec(symbol_string(arg)), method_name, @@ -1101,6 +1119,15 @@ Val* Compiler::compile_method_of_type(const goos::Object& form, } } + // if the user didn't provide a symbol, but instead some expression that gives us a type, then use + // that, and do method lookup as if it was a plain object. + // this will let you do (method-of-type inspect) and get the inspect + // method, with the proper type, from the given type's method table. + auto user_type = compile_error_guard(arg, env)->to_gpr(env); + if (user_type->type() == TypeSpec("type")) { + return compile_get_method_of_type(form, TypeSpec("object"), user_type, method_name, env); + } + throw_compiler_error(form, "Cannot get method of type {}: the type is invalid", arg.print()); return get_none(); } diff --git a/test/offline/offline_test_main.cpp b/test/offline/offline_test_main.cpp index 1b3d71c514..170e1ca808 100644 --- a/test/offline/offline_test_main.cpp +++ b/test/offline/offline_test_main.cpp @@ -102,10 +102,6 @@ const std::unordered_set g_functions_to_skip_compiling = { "lognor", // weird PS2 specific debug registers: "breakpoint-range-set!", - // does weird stuff with the type system. - "print", - "printl", - "inspect", // inline assembly "valid?",