From 06918e1fea146d09e063216e45cdd59f2f60150c Mon Sep 17 00:00:00 2001 From: water111 <48171810+water111@users.noreply.github.com> Date: Sat, 5 Dec 2020 17:09:46 -0500 Subject: [PATCH] Implement `gkernel`: Part 1 (#150) * start gkernel implementation * progress * more of kernel * swap to new dispatcher, will it work on windows * update --- boot_kernel.sh | 6 + common/type_system/deftype.cpp | 12 +- decompiler/config/all-types.gc | 276 +-- doc/changelog.md | 10 +- game/kernel/kscheme.cpp | 1 + goal_src/goal-lib.gc | 33 + goal_src/kernel-defs.gc | 1 + goal_src/kernel/gcommon.gc | 12 + goal_src/kernel/gkernel-h.gc | 134 +- goal_src/kernel/gkernel.gc | 1714 ++++++++++++++++- goalc/compiler/CodeGenerator.cpp | 2 +- goalc/compiler/Compiler.cpp | 21 +- goalc/compiler/Compiler.h | 16 +- goalc/compiler/Env.cpp | 1 + goalc/compiler/Env.h | 4 + goalc/compiler/IR.cpp | 139 ++ goalc/compiler/IR.h | 56 + goalc/compiler/Util.cpp | 26 + goalc/compiler/compilation/Asm.cpp | 75 + goalc/compiler/compilation/Atoms.cpp | 12 +- goalc/compiler/compilation/Define.cpp | 55 +- goalc/compiler/compilation/Function.cpp | 4 +- goalc/compiler/compilation/Math.cpp | 7 +- goalc/compiler/compilation/Static.cpp | 11 + goalc/compiler/compilation/Type.cpp | 64 +- goalc/emitter/IGen.h | 6 +- .../variables/static-bitfield-field.gc | 17 + .../with_game/test-new-static-basic.gc | 6 +- test/goalc/test_variables.cpp | 4 + test/goalc/test_with_game.cpp | 2 +- 30 files changed, 2492 insertions(+), 235 deletions(-) create mode 100755 boot_kernel.sh create mode 100644 test/goalc/source_templates/variables/static-bitfield-field.gc diff --git a/boot_kernel.sh b/boot_kernel.sh new file mode 100755 index 000000000..d56d69122 --- /dev/null +++ b/boot_kernel.sh @@ -0,0 +1,6 @@ +#!/bin/bash + +# Directory of this script +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )" + +$DIR/build/game/gk -fakeiso -debug "$@" diff --git a/common/type_system/deftype.cpp b/common/type_system/deftype.cpp index 023f890d7..1dd840d96 100644 --- a/common/type_system/deftype.cpp +++ b/common/type_system/deftype.cpp @@ -192,22 +192,22 @@ void declare_method(Type* type, TypeSystem* type_system, const goos::Object& def } } - std::vector arg_types; + TypeSpec function_typespec("function"); + for_each_in_list(args, [&](const goos::Object& o) { if (o.is_symbol()) { - arg_types.emplace_back(symbol_string(o)); + function_typespec.add_arg(parse_typespec(type_system, o)); } else { auto next = cdr(&o); - arg_types.emplace_back(symbol_string(car(next))); + function_typespec.add_arg(parse_typespec(type_system, car(next))); if (!cdr(next)->is_empty_list()) { throw std::runtime_error("too many things in method def arg type: " + def.print()); }; } }); + function_typespec.add_arg(parse_typespec(type_system, return_type)); - auto info = type_system->add_method( - type, method_name, - type_system->make_function_typespec(arg_types, symbol_string(return_type))); + auto info = type_system->add_method(type, method_name, function_typespec); // check the method assert if (id != -1) { diff --git a/decompiler/config/all-types.gc b/decompiler/config/all-types.gc index aa0778b28..14a7a8f2d 100644 --- a/decompiler/config/all-types.gc +++ b/decompiler/config/all-types.gc @@ -188,14 +188,15 @@ (declare-type process basic) (declare-type stack-frame basic) +(declare-type cpu-thread basic) ;; gkernel-h (deftype thread (basic) ((name basic :offset-assert 4) (process process :offset-assert 8) (previous thread :offset-assert 12) - (suspend-hook basic :offset-assert 16) - (resume-hook basic :offset-assert 20) + (suspend-hook (function cpu-thread none) :offset-assert 16) + (resume-hook (function cpu-thread none) :offset-assert 20) (pc pointer :offset-assert 24) (sp pointer :offset-assert 28) (stack-top pointer :offset-assert 32) @@ -238,11 +239,12 @@ (parent (pointer process-tree) :offset-assert 12) (brother (pointer process-tree) :offset-assert 16) (child (pointer process-tree) :offset-assert 20) - (ppointer pointer :offset-assert 24) - (self basic :offset-assert 28) + (ppointer (pointer process-tree) :offset-assert 24) + (self process-tree :offset-assert 28) ) (:methods + (new ((allocation symbol) (type-to-make type) (name basic)) _type_ 0) (activate ((obj _type_) (dest process-tree) (name basic) (stack-top pointer)) basic 9) (deactivate ((obj _type_)) basic 10) (dummy-method-11 () none 11) @@ -260,10 +262,10 @@ ((pool basic :offset-assert #x20) (status basic :offset-assert #x24) (pid int32 :offset-assert #x28) - (main-thread thread :offset-assert #x2c) + (main-thread cpu-thread :offset-assert #x2c) (top-thread thread :offset-assert #x30) (entity basic :offset-assert #x34) - (state basic :offset-assert #x38) + (state state :offset-assert #x38) (trans-hook function :offset-assert #x3c) (post-hook function :offset-assert #x40) (event-hook function :offset-assert #x44) @@ -278,6 +280,7 @@ ) (:methods + (new ((allocation symbol) (type-to-make type) (name basic) (stack-size int)) _type_ 0) (activate ((obj process) (dest process-tree) (name basic) (stack-top pointer)) basic 9) (deactivate ((obj process)) basic 10) (dummy-method-11 () none 11) @@ -296,8 +299,9 @@ ;; nothing new! ) (:methods - (get-process ((pool dead-pool) (type-to-make type) (stack-size integer)) process 14) - (return-process ((pool dead-pool) (proc process)) process-tree 15) + (new ((allocation symbol) (type-to-make type) (count int) (stack-size int) (name basic)) _type_ 0) + (get-process ((pool _type_) (type-to-make type) (stack-size int)) process 14) + (return-process ((pool _type_) (proc process)) none 15) ) :size-assert #x20 :method-count-assert 16 @@ -333,17 +337,18 @@ ) (:methods - (compact ((this dead-pool-heap) (count integer)) none 16) + (new ((allocation symbol) (type-to-make type) (name basic) (allocated-length int) (heap-size int)) _type_ 0) + (compact ((this dead-pool-heap) (count int)) none 16) (shrink-heap ((this dead-pool-heap) (proc process)) dead-pool-heap 17) - (churn ((this dead-pool-heap) (count integer)) none 18) - (memory-used ((this dead-pool-heap)) integer 19) - (memory-total ((this dead-pool-heap)) integer 20) - (gap-size ((this dead-pool-heap) (rec dead-pool-heap-rec)) integer 21) + (churn ((this dead-pool-heap) (count int)) none 18) + (memory-used ((this dead-pool-heap)) int 19) + (memory-total ((this dead-pool-heap)) int 20) + (gap-size ((this dead-pool-heap) (rec dead-pool-heap-rec)) int 21) (gap-location ((this dead-pool-heap) (rec dead-pool-heap-rec)) pointer 22) (find-gap ((this dead-pool-heap) (rec dead-pool-heap-rec)) dead-pool-heap-rec 23) - (find-gap-by-size ((this dead-pool-heap) (size integer)) dead-pool-heap-rec 24) - (memory-free ((this dead-pool-heap)) integer 25) - (compact-time ((this dead-pool-heap)) integer 26) + (find-gap-by-size ((this dead-pool-heap) (size int)) dead-pool-heap-rec 24) + (memory-free ((this dead-pool-heap)) int 25) + (compact-time ((this dead-pool-heap)) uint 26) ) :method-count-assert 27 @@ -367,6 +372,11 @@ (freg float 6 :offset-assert 20) (rreg uint128 8 :offset-assert 48) ) + + (:methods + (new ((allocation symbol) (type-to-make type) (name symbol) (func function) (params (pointer uint64))) object 0) + ) + :method-count-assert 9 :size-assert #xb0 :flag-assert #x9000000b0 @@ -422,10 +432,129 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~; -(define-extern search-process-tree (function process-tree (function symbol object) object)) -(define-extern kill-by-name (function object process-tree symbol)) +(define-extern *kernel-version* binteger) +(define-extern *irx-version* binteger) +(define-extern *kernel-boot-mode* symbol) +(define-extern *kernel-boot-level* symbol) +(define-extern *deci-count* int) +(define-extern *last-loado-length* int) +(define-extern *last-loado-global-usage* int) +(define-extern *last-loado-debug-usage* int) +(define-extern *kernel-packages* pair) +(define-extern load-package (function string kheap pair)) +(define-extern unload-package (function string pair)) +(define-extern *kernel-context* kernel-context) +(define-extern *dram-stack* (pointer uint8)) +(define-extern *null-kernel-context* kernel-context) + +(define-extern remove-exit (function stack-frame)) +(define-extern stream<-process-mask (function object int object)) +(define-extern *master-mode* symbol) +(define-extern *pause-lock* symbol) +(define-extern inspect-process-heap (function process symbol)) +(define-extern *kernel-sp* pointer) +(define-extern return-from-thread (function none)) +(define-extern return-from-thread-dead (function none)) +(define-extern reset-and-call (function thread function object)) + +(define-extern *debug-dead-pool* dead-pool-heap) +(define-extern *null-process* process) +(define-extern *vis-boot* basic) +(define-extern *stdcon* basic) ;; todo, more specific + +(define-extern *global-search-name* basic) +(define-extern *global-search-count* int) (define-extern process-by-name (function object process-tree process)) +(define-extern process-not-name (function object process-tree process)) +(define-extern process-count (function process-tree int)) +(define-extern kill-by-name (function object process-tree symbol)) +(define-extern kill-by-type (function object process-tree symbol)) +(define-extern kill-not-name (function object process-tree symbol)) +(define-extern kill-not-type (function object process-tree symbol)) + +(define-extern iterate-process-tree (function process-tree (function object object) kernel-context object)) +(define-extern search-process-tree (function process-tree (function process-tree object) process)) +(define-extern execute-process-tree (function process-tree (function object object) kernel-context object)) + +(define-extern change-parent (function process-tree process-tree process-tree)) + (define-extern *active-pool* process-tree) +(define-extern kernel-dispatcher (function (function object))) +(define-extern inspect-process-tree (function process-tree int int symbol process-tree)) + + +;;(define-extern stack-frame object) ;; unknown type +(define-extern state type) +;;(define-extern dead-pool-heap-rec object) ;; unknown type +;;(define-extern dead-pool object) ;; unknown type +;;(define-extern catch-frame object) ;; unknown type +;;(define-extern thread object) ;; unknown type +;;(define-extern handle object) ;; unknown type +;;(define-extern cpu-thread object) ;; unknown type +;;(define-extern dead-pool-heap object) ;; unknown type +(define-extern kernel-context type) +;;(define-extern protect-frame object) ;; unknown type +;;(define-extern event-message-block object) ;; unknown type +;;(define-extern process-tree object) ;; unknown type +;;(define-extern *listener-process* object) ;; unknown type +;;(define-extern *entity-pool* object) ;; unknown type +;;(define-extern *default-pool* object) ;; unknown type +;;(define-extern malloc object) ;; unknown type +;;(define-extern ready object) ;; unknown type +;;(define-extern *camera-pool* object) ;; unknown type +(define-extern throw-dispatch function) +;;(define-extern game object) ;; unknown type +(define-extern run-function-in-process function) +(define-extern throw function) +;;(define-extern *nk-dead-pool* object) ;; unknown type +(define-extern change-to-last-brother function) +;;(define-extern *pickup-dead-pool* object) ;; unknown type +;;(define-extern *camera-master-dead-pool* object) ;; unknown type +(define-extern set-to-run function) +;;(define-extern default-pool object) ;; unknown type +;;(define-extern listener object) ;; unknown type +;;(define-extern target-pool object) ;; unknown type +(define-extern set-to-run-bootstrap function) +;;(define-extern *camera-dead-pool* object) ;; unknown type +;;(define-extern process object) ;; unknown type +(define-extern previous-brother function) +;;(define-extern dead-state object) ;; unknown type +;;(define-extern debug object) ;; unknown type +;;(define-extern *16k-dead-pool* object) ;; unknown type +(define-extern entity-deactivate-handler function) +;;(define-extern *target-pool* object) ;; unknown type +;;(define-extern entity-pool object) ;; unknown type +;;(define-extern main object) ;; unknown type +(define-extern change-brother function) +;;(define-extern *active-pool* object) ;; unknown type +;;(define-extern display-pool object) ;; unknown type +;;(define-extern *target-dead-pool* object) ;; unknown type +;;(define-extern *4k-dead-pool* object) ;; unknown type +;;(define-extern *default-dead-pool* object) ;; unknown type +;;(define-extern *8k-dead-pool* object) ;; unknown type +;;(define-extern *display-pool* object) ;; unknown type +;;(define-extern active-pool object) ;; unknown type +;;(define-extern *dead-pool-list* object) ;; unknown type +;;(define-extern camera-pool object) ;; unknown type +;;(define-extern suspended object) ;; unknown type +;;(define-extern dgo-load object) ;; unknown type +;;(define-extern initialize-dead object) ;; unknown type +;;(define-extern #f object) ;; unknown type +;;(define-extern waiting-to-run object) ;; unknown type +;;(define-extern *stdcon0* object) ;; unknown type +;;(define-extern initialize-go object) ;; unknown type +;;(define-extern trans object) ;; unknown type +;;(define-extern code object) ;; unknown type +;;(define-extern *listener-function* object) ;; unknown type +;;(define-extern *stdcon1* object) ;; unknown type +;;(define-extern initialize object) ;; unknown type +(define-extern process-disconnect function) +;;(define-extern *debug-draw-pauseable* object) ;; unknown type +;;(define-extern _empty_ object) ;; unknown type +;;(define-extern running object) ;; unknown type +;;(define-extern *enable-method-set* object) ;; unknown type +;;(define-extern post object) ;; unknown type +;;(define-extern dead object) ;; unknown type ;; pskernel (deftype lowmemmap (structure) @@ -31087,119 +31216,8 @@ ;; KERNEL -(define-extern *kernel-packages* pair) -;;(define-extern stack-frame object) ;; unknown type -(define-extern state type) -;;(define-extern dead-pool-heap-rec object) ;; unknown type -;;(define-extern dead-pool object) ;; unknown type -;;(define-extern catch-frame object) ;; unknown type -;;(define-extern thread object) ;; unknown type -;;(define-extern handle object) ;; unknown type -;;(define-extern cpu-thread object) ;; unknown type -;;(define-extern dead-pool-heap object) ;; unknown type -(define-extern kernel-context type) -;;(define-extern protect-frame object) ;; unknown type -;;(define-extern event-message-block object) ;; unknown type -;;(define-extern process-tree object) ;; unknown type -;;(define-extern *listener-process* object) ;; unknown type -;;(define-extern *entity-pool* object) ;; unknown type -;;(define-extern *default-pool* object) ;; unknown type -(define-extern iterate-process-tree function) -;;(define-extern malloc object) ;; unknown type -;;(define-extern *deci-count* object) ;; unknown type -;;(define-extern ready object) ;; unknown type -;;(define-extern *camera-pool* object) ;; unknown type -(define-extern throw-dispatch function) -;;(define-extern game object) ;; unknown type -(define-extern run-function-in-process function) -(define-extern throw function) -;;(define-extern *nk-dead-pool* object) ;; unknown type -(define-extern kill-by-type function) -(define-extern change-to-last-brother function) -;;(define-extern *pickup-dead-pool* object) ;; unknown type -;;(define-extern *camera-master-dead-pool* object) ;; unknown type -(define-extern load-package (function string kheap pair)) -(define-extern set-to-run function) -;;(define-extern *master-mode* object) ;; unknown type -;;(define-extern default-pool object) ;; unknown type -(define-extern return-from-thread-dead function) -;;(define-extern listener object) ;; unknown type -(define-extern process-count function) -;;(define-extern target-pool object) ;; unknown type -(define-extern set-to-run-bootstrap function) -(define-extern return-from-thread function) -;;(define-extern *camera-dead-pool* object) ;; unknown type -;;(define-extern *last-loado-debug-usage* object) ;; unknown type -;;(define-extern process object) ;; unknown type -(define-extern remove-exit function) -(define-extern previous-brother function) -(define-extern execute-process-tree function) -;;(define-extern dead-state object) ;; unknown type -;;(define-extern debug object) ;; unknown type -;;(define-extern *16k-dead-pool* object) ;; unknown type -(define-extern entity-deactivate-handler function) -;;(define-extern *null-process* object) ;; unknown type -(define-extern inspect-process-heap function) -;;(define-extern *target-pool* object) ;; unknown type -;;(define-extern *global-search-name* object) ;; unknown type -;;(define-extern *kernel-boot-mode* object) ;; unknown type -;;(define-extern entity-pool object) ;; unknown type -(define-extern kill-not-type function) -;;(define-extern *kernel-context* object) ;; unknown type -;;(define-extern *kernel-boot-level* object) ;; unknown type -;;(define-extern main object) ;; unknown type -(define-extern change-brother function) -;;(define-extern *null-kernel-context* object) ;; unknown type -(define-extern kill-not-name function) -;;(define-extern *active-pool* object) ;; unknown type -;;(define-extern *dram-stack* object) ;; unknown type -;;(define-extern *irx-version* object) ;; unknown type -;;(define-extern *pause-lock* object) ;; unknown type -;;(define-extern display-pool object) ;; unknown type -;;(define-extern *target-dead-pool* object) ;; unknown type -;;(define-extern *vis-boot* object) ;; unknown type -;;(define-extern *debug-dead-pool* object) ;; unknown type -;;(define-extern *last-loado-length* object) ;; unknown type -;;(define-extern *4k-dead-pool* object) ;; unknown type -;;(define-extern *default-dead-pool* object) ;; unknown type -(define-extern kernel-dispatcher (function (function object))) -;;(define-extern *8k-dead-pool* object) ;; unknown type -(define-extern unload-package (function string pair)) -(define-extern reset-and-call function) -(define-extern process-not-name function) -;;(define-extern *display-pool* object) ;; unknown type -;;(define-extern *kernel-version* object) ;; unknown type -;;(define-extern active-pool object) ;; unknown type -;;(define-extern *dead-pool-list* object) ;; unknown type -;;(define-extern *global-search-count* object) ;; unknown type -;;(define-extern *last-loado-global-usage* object) ;; unknown type -(define-extern stream<-process-mask function) -(define-extern change-parent function) -(define-extern inspect-process-tree function) -;;(define-extern camera-pool object) ;; unknown type -;;(define-extern suspended object) ;; unknown type -;;(define-extern dgo-load object) ;; unknown type -;;(define-extern initialize-dead object) ;; unknown type -;;(define-extern #f object) ;; unknown type -;;(define-extern waiting-to-run object) ;; unknown type -;;(define-extern *stdcon0* object) ;; unknown type -;;(define-extern initialize-go object) ;; unknown type -;;(define-extern *stdcon* object) ;; unknown type -;;(define-extern trans object) ;; unknown type -;;(define-extern code object) ;; unknown type -;;(define-extern *listener-function* object) ;; unknown type -;;(define-extern *stdcon1* object) ;; unknown type -;;(define-extern initialize object) ;; unknown type -;;(define-extern *kernel-sp* object) ;; unknown type -(define-extern process-disconnect function) -;;(define-extern *debug-draw-pauseable* object) ;; unknown type -;;(define-extern _empty_ object) ;; unknown type -;;(define-extern running object) ;; unknown type -;;(define-extern *enable-method-set* object) ;; unknown type -;;(define-extern post object) ;; unknown type -;;(define-extern dead object) ;; unknown type (define-extern install-default-debug-handler function) (define-extern return-from-exception function) ;;(define-extern lowmemmap object) ;; unknown type diff --git a/doc/changelog.md b/doc/changelog.md index 67c9c54ac..a6a6b6703 100644 --- a/doc/changelog.md +++ b/doc/changelog.md @@ -65,4 +65,12 @@ - Added inline assembly `.ret`, `.sub`, `.push`, and `.pop`. - Added `rlet` to declare register variables. - Added `:color #f` option to inline assembly forms to exclude them from the coloring system. -- Added `asm-func` to declare for purely assembly functions. \ No newline at end of file +- Added `asm-func` to declare for purely assembly functions. +- Enum values now work where constant integers are expected. +- The boolean values `#f` and `#t` now are gotten as symbol objects, not values of symbols. +- In a static field initialization, you can use `#f` and `#t` instead of `'#f` and `'#t` +- Added `no-typecheck` option to define. +- Reworked type checking for `set!`. You may now use `#f` for non-numeric types. +- Fixed a bug where arguments to a method were unmodifiable. +- Fixed a bug where multiple anonymous lambda functions in the same file would throw a compiler error related to function name uniqueness. +- Method declarations can now use compound types. Previously they could only use simple types due to a mistake in deftype parser. \ No newline at end of file diff --git a/game/kernel/kscheme.cpp b/game/kernel/kscheme.cpp index eccf1abbe..9b1a3b93d 100644 --- a/game/kernel/kscheme.cpp +++ b/game/kernel/kscheme.cpp @@ -827,6 +827,7 @@ u64 new_type(u32 symbol, u32 parent, u64 flags) { // BUG! This uses the child method count, but should probably use the parent method count. for (u32 i = 0; i < n_methods; i++) { + // for (u32 i = 0; i < Ptr(parent)->num_methods; i++) { child_slots[i] = parent_slots[i]; } diff --git a/goal_src/goal-lib.gc b/goal_src/goal-lib.gc index ede0d2205..d7cd14e29 100644 --- a/goal_src/goal-lib.gc +++ b/goal_src/goal-lib.gc @@ -179,6 +179,26 @@ ) ) +;; Define a new function, but only if we're debugging. +;; TODO - should place the function in the debug segment! +(defmacro defun-debug (name bindings &rest body) + `(if *debug-segment* + ,(if (and + (> (length body) 1) ;; more than one thing in function + (string? (first body)) ;; first thing is a string + ) + ;; then it's a docstring and we ignore it. + `(define ,name (lambda :name ,name :segment debug ,bindings ,@(cdr body))) + ;; otherwise don't ignore it. + `(define ,name (lambda :name ,name :segment debug ,bindings ,@body)) + ) + + ;; function not loaded, set function to the nothing function. + ;; we don't typecheck this. + (define :no-typecheck #t ,name nothing) + ) + ) + (defmacro while (test &rest body) (with-gensyms (reloop test-exit) `(begin @@ -212,6 +232,15 @@ ) ) +(defmacro countdown (var &rest body) + `(let ((,(first var) ,(second var))) + (while (!= ,(first var) 0) + (set! ,(first var) (- ,(first var) 1)) + ,@body + ) + ) + ) + ;; Backup some values, and restore after executing body. ;; Non-dynamic (nonlocal jumps out of body will skip restore) (defmacro protect (defs &rest body) @@ -340,6 +369,10 @@ `(eq? ,thing 0) ) +(defmacro nonzero? (thing) + `(neq? ,thing 0) + ) + (defmacro &+! (val amount) `(set! ,val (&+ ,val ,amount)) ) diff --git a/goal_src/kernel-defs.gc b/goal_src/kernel-defs.gc index 8156a3d0a..f5a102e49 100644 --- a/goal_src/kernel-defs.gc +++ b/goal_src/kernel-defs.gc @@ -104,6 +104,7 @@ (define-extern *listener-function* (function object)) ;; kernel-dispatcher ;; kernel-packages +(define-extern *print-column* binteger) ;; *print-column* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/goal_src/kernel/gcommon.gc b/goal_src/kernel/gcommon.gc index c79af2ade..79a934a5e 100644 --- a/goal_src/kernel/gcommon.gc +++ b/goal_src/kernel/gcommon.gc @@ -592,4 +592,16 @@ ) ) dst + ) + + +(defun print-tree-bitmask ((bitmask int) (len int)) + "The purpose of this function is unknown" + (dotimes (i len #f) + (if (zero? (logand bitmask 1)) + (format #t " ") + (format #t "| ") + ) + (set! bitmask (ash bitmask -1)) + ) ) \ No newline at end of file diff --git a/goal_src/kernel/gkernel-h.gc b/goal_src/kernel/gkernel-h.gc index 57508d4a4..73e263d5b 100644 --- a/goal_src/kernel/gkernel-h.gc +++ b/goal_src/kernel/gkernel-h.gc @@ -103,6 +103,10 @@ `(format 0 ,@args) ) +(defmacro msg-warn (&rest args) + `(format 0 ,@args) + ) + ;; todo process pointer ;; todo process memory usage ;; with pp @@ -141,14 +145,16 @@ (declare-type process basic) (declare-type stack-frame basic) +(declare-type state basic) +(declare-type cpu-thread basic) ; DANGER - this type is created in kscheme.cpp. It has room for 12 methods and size 0x28 bytes. (deftype thread (basic) ((name basic :offset-assert 4) ;; name of the thread (usually a symbol?) (process process :offset-assert 8) ;; process that the thread belongs to (previous thread :offset-assert 12) ;; previous thread that was running in the process - (suspend-hook basic :offset-assert 16) ;; function to suspend this thread - (resume-hook basic :offset-assert 20) ;; function to resume this thread + (suspend-hook (function cpu-thread none) :offset-assert 16) ;; function to suspend this thread + (resume-hook (function cpu-thread none) :offset-assert 20) ;; function to resume this thread (pc pointer :offset-assert 24) ;; program counter of the thread (sp pointer :offset-assert 28) ;; stack pointer of the thread (actual stack) (stack-top pointer :offset-assert 32) ;; top of the thread's stack (actual stack) @@ -195,11 +201,12 @@ (parent (pointer process-tree) :offset-assert 12) (brother (pointer process-tree) :offset-assert 16) (child (pointer process-tree) :offset-assert 20) - (ppointer pointer :offset-assert 24) - (self basic :offset-assert 28) + (ppointer (pointer process-tree) :offset-assert 24) + (self process-tree :offset-assert 28) ) (:methods + (new ((allocation symbol) (type-to-make type) (name basic)) _type_ 0) (activate ((obj _type_) (dest process-tree) (name basic) (stack-top pointer)) basic 9) (deactivate ((obj _type_)) basic 10) (dummy-method-11 () none 11) @@ -218,10 +225,10 @@ ((pool basic :offset-assert #x20) (status basic :offset-assert #x24) (pid int32 :offset-assert #x28) - (main-thread thread :offset-assert #x2c) + (main-thread cpu-thread :offset-assert #x2c) (top-thread thread :offset-assert #x30) (entity basic :offset-assert #x34) - (state basic :offset-assert #x38) + (state state :offset-assert #x38) (trans-hook function :offset-assert #x3c) (post-hook function :offset-assert #x40) (event-hook function :offset-assert #x44) @@ -236,6 +243,7 @@ ) (:methods + (new ((allocation symbol) (type-to-make type) (name basic) (stack-size int)) _type_ 0) (activate ((obj process) (dest process-tree) (name basic) (stack-top pointer)) basic 9) (deactivate ((obj process)) basic 10) (dummy-method-11 () none 11) @@ -255,8 +263,9 @@ ;; nothing new! ) (:methods - (get-process ((pool dead-pool) (type-to-make type) (stack-size integer)) process 14) - (return-process ((pool dead-pool) (proc process)) process-tree 15) + (new ((allocation symbol) (type-to-make type) (count int) (stack-size int) (name basic)) _type_ 0) + (get-process ((pool _type_) (type-to-make type) (stack-size int)) process 14) + (return-process ((pool _type_) (proc process)) none 15) ) :size-assert #x20 :method-count-assert 16 @@ -298,17 +307,18 @@ (process-list dead-pool-heap-rec :inline :dynamic :offset-assert 104) ) (:methods - (compact ((this dead-pool-heap) (count integer)) none 16) + (new ((allocation symbol) (type-to-make type) (name basic) (allocated-length int) (heap-size int)) _type_ 0) + (compact ((this dead-pool-heap) (count int)) none 16) (shrink-heap ((this dead-pool-heap) (proc process)) dead-pool-heap 17) - (churn ((this dead-pool-heap) (count integer)) none 18) - (memory-used ((this dead-pool-heap)) integer 19) - (memory-total ((this dead-pool-heap)) integer 20) - (gap-size ((this dead-pool-heap) (rec dead-pool-heap-rec)) integer 21) + (churn ((this dead-pool-heap) (count int)) none 18) + (memory-used ((this dead-pool-heap)) int 19) + (memory-total ((this dead-pool-heap)) int 20) + (gap-size ((this dead-pool-heap) (rec dead-pool-heap-rec)) int 21) (gap-location ((this dead-pool-heap) (rec dead-pool-heap-rec)) pointer 22) (find-gap ((this dead-pool-heap) (rec dead-pool-heap-rec)) dead-pool-heap-rec 23) - (find-gap-by-size ((this dead-pool-heap) (size integer)) dead-pool-heap-rec 24) - (memory-free ((this dead-pool-heap)) integer 25) - (compact-time ((this dead-pool-heap)) integer 26) + (find-gap-by-size ((this dead-pool-heap) (size int)) dead-pool-heap-rec 24) + (memory-free ((this dead-pool-heap)) int 25) + (compact-time ((this dead-pool-heap)) uint 26) ) :size-assert #x68 @@ -340,6 +350,10 @@ (freg float 6 :offset-assert 20) ;; saved floating point registers from "catch" statement (rreg uint128 8 :offset-assert 48) ;; saved GPRs from "catch" statement (ugh they are 128s) ) + + (:methods + (new ((allocation symbol) (type-to-make type) (name symbol) (func function) (params (pointer uint64))) object 0) + ) :size-assert #xb0 :method-count-assert 9 :flag-assert #x9000000b0 @@ -354,7 +368,46 @@ :flag-assert #x900000010 ) -;; handle (todo, need bitfield types) +(deftype handle (uint64) + ((process (pointer process) :offset 0) ;; todo, more specific type + (pid int32 :offset 32) + (u64 uint64 :offset 0) + ) + :flag-assert #x900000008 + ) + +(defmethod inspect handle ((obj handle)) + (format #t "[~8x] ~A~%" 'handle) + (format #t "~Tprocess: #x~x~%" (-> obj process)) + (format #t "~Tpid: ~D~%" (-> obj pid)) + obj + ) + + +(defmacro get-process-from-handle (handle) + ;; the actual implementation is more clever than this. + `(if (-> ,handle process) + (let ((proc (-> (-> ,handle process)))) + (if (= (-> ,handle pid) + (-> proc pid)) + proc + ) + ) + ) + ) + +(defmethod print handle ((obj handle)) + ;; the get-process-from-handle macro can't deal with + ;; a 0 in the process field, so we check it manually here. + (if (nonzero? (-> obj u64)) + (format #t "#" + (get-process-from-handle obj) + (-> obj pid) + ) + (format #t "#") + ) + obj + ) ;; GOAL State. A Process can be in a State. (deftype state (protect-frame) ; state is a protect frame so we can "exit" it with cleanup @@ -383,4 +436,51 @@ :size-assert #x48 :method-count-assert 9 :flag-assert #x900000048 + ) + +(defmacro as-process (ppointer) + `(if ,ppointer + (-> (-> ,ppointer) self) + ) + ) + +(defmacro as-ppointer (proc) + ;"safely get a (pointer process) from a process, returning #f if invalid." + `(if ,proc + (-> ,proc ppointer) + ) + ) + +(defmacro process-stack-used (proc) + ;; get how much stack the top thread of a process has used. + `(- (the int (-> ,proc top-thread stack-top)) + (the int (-> ,proc top-thread sp)) + ) + ) + +(defmacro process-stack-size (proc) + ;; get how much stack the top thread of a process has + `(-> ,proc top-thread stack-size) + ) + +(defmacro process-heap-used (proc) + ;; get how much heap a process has used. + `(- (-> ,proc allocated-length) + (- (the int (-> ,proc heap-top)) + (the int (-> ,proc heap-cur)) + ) + ) + ) + +(defmacro process-heap-size (proc) + ;; get how much heap a process has + `(the int (-> ,proc allocated-length)) + ) + +(defmacro process-mask? (mask enum-value) + `(!= 0 (logand ,mask (process-mask ,enum-value))) + ) + +(defmacro process-mask-set! (mask enum-value) + `(set! ,mask (logior ,mask (process-mask ,enum-value))) ) \ No newline at end of file diff --git a/goal_src/kernel/gkernel.gc b/goal_src/kernel/gkernel.gc index 4e752290a..57409bd54 100644 --- a/goal_src/kernel/gkernel.gc +++ b/goal_src/kernel/gkernel.gc @@ -5,11 +5,16 @@ ;; name in dgo: gkernel ;; dgos: KERNEL +;; Fwd +(define-extern change-parent (function process-tree process-tree process-tree)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; System Globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; HACK ADDED +(define *use-old-listener-print* #t) + ;; Set version number symbols (define *kernel-version* (the binteger (logior (ash *kernel-major-version* 16) *kernel-minor-version*))) (define *irx-version* (the binteger (logior (ash *irx-major-version* 16) *irx-minor-version*))) @@ -79,16 +84,17 @@ ;; The kernel context is a global which stores the state of the kernel. (define *kernel-context* (new 'static 'kernel-context - :prevent-from-run #x41 ;; todo, bitfield enum types + :prevent-from-run (process-mask execute sleep) :next-pid 2 - :current-process '#f - :relocating-process '#f - :low-memory-message '#t + :current-process #f + :relocating-process #f + :low-memory-message #t ) ) ;; the main stack for running GOAL code! -(define *dram-stack* (new 'global 'array 'uint8 #x3800)) ;;DPROCESS_STACK_SIZE +(define *dram-stack* (new 'global 'array 'uint8 DPROCESS_STACK_SIZE)) +(defconstant *kernel-dram-stack* (&+ *dram-stack* DPROCESS_STACK_SIZE)) ;; I don't think this stack is used, but I'm not sure. (set! (-> *kernel-context* fast-stack-top) *scratch-memory-top*) @@ -98,32 +104,14 @@ (define *null-kernel-context* (new 'static 'kernel-context)) -(defun kernel-dispatcher () - "Kernel Dispatcher Function. This gets called from the main loop in kboot.cpp's KernelCheckAndDispatch" - - ;; check if we have a new listener function to run - (when *listener-function* - ;; we do! enable method-set for debug purposes - (+! *enable-method-set* 1) - - ;; execute and print result - (let ((result (*listener-function*))) - (format #t "~D~%" result) - ) - (+! *enable-method-set* -1) - - ;; clear the pending function. - (set! *listener-function* (the (function object) #f)) - ) - ) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Thread and CPU Thread ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; A GOAL thread represents the execute of code in a process. +; A GOAL thread represents the execution of code in a process. ; Each process has a "main thread", which is suspended and resumed. ; A process may also execute various temporary threads which always run until completion. +; A "temporary thread" cannot suspend and resume, but a "main thread" can. ; The currently executing thread of a process is the "top-thread". ; Some GOAL threads also have the ability to "back up" their stack, while others are "temporary". @@ -188,14 +176,17 @@ ;; first, let's see if we're doing the main or temp thread (let* ((obj (cond ((-> parent-process top-thread) - ;; temp thread. + ;; we're allocating a temporary thread, the main thread already exists. + ;; we can stash the cpu-thread structure at the bottom of the stack. + ;; we assume the smaller PROCESS_STACK_SIZE (the cpu-thread (&+ stack-top (- PROCESS_STACK_SIZE) *gtype-basic-offset* )) ) (else - ;; the main thread + ;; the main thread. We need the main thread's cpu-thread to stick around, so we put it in the + ;; process heap. (let ((alloc (align16 (-> parent-process heap-cur)))) ;; start at heap cur, aligned ;; bump heap to include our thread + its stack (set! (-> parent-process heap-cur) (the pointer (+ alloc (-> type-to-make size) stack-size))) @@ -236,6 +227,1671 @@ (the int (+ (-> obj type size) (-> obj stack-size))) ) -;; todo remove-exit +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Remove Exit +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; todo stream<-process-mask +(defun remove-exit () + "This is likely a defbehavior for process. + Pops a single stack frame, if there is one." + (rlet ((self :reg r13 :type process)) + (when (-> self stack-frame-top) + (set! (-> self stack-frame-top) (-> self stack-frame-top next)) + ) + ) + ) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Process Tree +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; GOAL processes are stored in a left child, right sibling tree. +;; The base class of process is process-tree. +;; Each process-tree element has a process-mask which indicates what type of node it is. + +(defun-debug stream<-process-mask (stream (mask int)) + "Print out a process mask. This function may have been auto-generated?" + ; 24 + (if (not (eq? 0 (logand mask (process-mask death)))) + (format stream "death ")) + ; 23 + (if (not (eq? 0 (logand mask (process-mask attackable)))) + (format stream "attackable ")) + ; 22 + (if (not (eq? 0 (logand mask (process-mask projectile)))) + (format stream "projectile ")) + ; 21 + (if (not (eq? 0 (logand mask (process-mask entity)))) + (format stream "entity ")) + ; 20 + (if (not (eq? 0 (logand mask (process-mask ambient)))) + (format stream "ambient ")) + ; 19 + (if (not (eq? 0 (logand mask (process-mask platform)))) + (format stream "platform ")) + ; 18 + (if (not (eq? 0 (logand mask (process-mask camera)))) + (format stream "camera ")) + ; 17 + (if (not (eq? 0 (logand mask (process-mask enemy)))) + (format stream "enemy ")) + ; 16 + (if (not (eq? 0 (logand mask (process-mask collectable)))) + (format stream "collectable ")) + ; 15 + (if (not (eq? 0 (logand mask (process-mask crate)))) + (format stream "crate ")) + ; 14 + (if (not (eq? 0 (logand mask (process-mask sidekick)))) + (format stream "sidekick ")) + ; 13 + (if (not (eq? 0 (logand mask (process-mask target)))) + (format stream "target ")) + ; 12 + (if (not (eq? 0 (logand mask (process-mask movie-subject)))) + (format stream "movie-subject ")) + ; 11 + (if (not (eq? 0 (logand mask (process-mask movie)))) + (format stream "movie ")) + ; 10 + (if (not (eq? 0 (logand mask (process-mask going)))) + (format stream "going ")) + ; 9 + (if (not (eq? 0 (logand mask (process-mask heap-shrunk)))) + (format stream "heap-shrunk ")) + ; 8 + (if (not (eq? 0 (logand mask (process-mask process-tree)))) + (format stream "process-tree ")) + ; 7 + (if (not (eq? 0 (logand mask (process-mask sleep-code)))) + (format stream "sleep-code ")) + ; 6 + (if (not (eq? 0 (logand mask (process-mask sleep)))) + (format stream "sleep ")) + ; 5 + (if (not (eq? 0 (logand mask (process-mask actor-pause)))) + (format stream "actor-pause ")) + ; 4 + (if (not (eq? 0 (logand mask (process-mask progress)))) + (format stream "progress ")) + ; 3 + (if (not (eq? 0 (logand mask (process-mask menu)))) + (format stream "menu ")) + ; 2 + (if (not (eq? 0 (logand mask (process-mask pause)))) + (format stream "pause ")) + ; 1 + (if (not (eq? 0 (logand mask (process-mask draw)))) + (format stream "draw ")) + ; 0 + (if (not (eq? 0 (logand mask (process-mask execute)))) + (format stream "execute ")) + ) + +;; game state +(define *master-mode* 'game) +(define *pause-lock* #f) + +(defmethod new process-tree ((allocation symbol) (type-to-make type) (name basic)) + "Create a process-tree node" + ;; allocate + (let ((obj (object-new))) + (set! (-> obj name) name) + (set! (-> obj mask) (process-mask process-tree)) + (set! (-> obj parent) #f) + (set! (-> obj brother) #f) + (set! (-> obj child) #f) + + (set! (-> obj self) obj) + (set! (-> obj ppointer) (&-> obj self)) + obj + ) + ) + +(defmethod inspect process-tree ((obj process-tree)) + "Inspect a process-tree node." + (format #t "[~8x] ~A~%" obj (-> obj type)) + (format #t "~Tname: ~S~%" (-> obj name)) + (format #t "~Tmask: #x~X~%" (-> obj mask)) + (format #t "~Tparent: ~A~%" (as-process (-> obj parent))) + (format #t "~Tbrother: ~A~%" (as-process (-> obj brother))) + (format #t "~Tchild: ~A~%" (as-process (-> obj child))) + obj + ) + + +(defmethod new process ((allocation symbol) (type-to-make type) (name basic) (stack-size int)) + "Allocate a new process. + The process stack is initially set to the entire process memory." + (let ((obj (if (eq? (-> allocation type) symbol) + (object-new (the int (+ (-> process size) stack-size))) ;; symbol, allocate on heap + (the process (&+ allocation *gtype-basic-offset*))))) ;; treat as address. + + ;; initialize + (set! (-> obj name) name) + (set! (-> obj status) 'dead) + (set! (-> obj pid) 0) + (set! (-> obj pool) #f) + (set! (-> obj allocated-length) stack-size) + (set! (-> obj top-thread) #f) + (set! (-> obj main-thread) #f) + + ;; set up the heap to start at the stack + (set! (-> obj heap-cur) (-> obj stack)) + (set! (-> obj heap-base) (-> obj stack)) + + ;; and end at the end of the stack. + (set! (-> obj heap-top) (&-> (-> obj stack) (-> obj allocated-length))) + ;;;;;;;;;;;;;;;;;;;;;;;;; + ;; heap top-base bug + ;;;;;;;;;;;;;;;;;;;;;;;;; + ;; original there was something like (set! (-> heap-top-base) (-> heap-top)) + ;; but this overlaps with the stack-frame-top and did nothing. + ;; this is likely because they added the concept of heap "top" to kheaps in + ;; general, but not to process heaps. + + ;; setup state stuff + (set! (-> obj stack-frame-top) #f) + (set! (-> obj state) #f) + (set! (-> obj next-state) #f) + (set! (-> obj entity) #f) + + ;; setup handlers + (set! (-> obj trans-hook) #f) + (set! (-> obj post-hook) #f) + (set! (-> obj event-hook) #f) + + ;; setup process tree + (set! (-> obj parent) #f) + (set! (-> obj brother) #f) + (set! (-> obj child) #f) + + ;; setup reference stuff. + (set! (-> obj self) obj) + (set! (-> obj ppointer) (&-> obj self)) + obj + ) + ) + +(defun inspect-process-heap ((obj process)) + "Inspect the heap of a process." + (let ((ptr (&+ (-> obj heap-base) *gtype-basic-offset*))) ; point to first basic + ;; loop over objects + (while (< (the int ptr) (the int (-> obj heap-cur))) + ;; inspect the object + (inspect (the basic ptr)) + ;; seek to the next object on the heap. + (set! ptr (&+ ptr (align16 (asize-of (the basic ptr))))) + ) + ) + ) + +(defmethod inspect process ((obj process)) + (format #t "[~8x] ~A~%" obj (-> obj type)) + (format #t "~Tname: ~S~%" (-> obj name)) + (format #t "~Tmask: #x~X~%" (-> obj mask)) + (format #t "~Tstatus: ~A~%" (-> obj status)) + (format #t "~Tmain-thread: ~A~%" (-> obj main-thread)) + (format #t "~Ttop-thread: ~A~%" (-> obj top-thread)) + (format #t "~Tentity: ~A~%" (-> obj entity)) + (format #t "~Tstate: ~A~%" (-> obj state)) + (format #t "~Tnext-state: ~A~%" (-> obj next-state)) + (format #t "~Ttrans-hook: ~A~%" (-> obj trans-hook)) + (format #t "~Tpost-hook: ~A~%" (-> obj post-hook)) + (format #t "~Tevent-hook: ~A~%" (-> obj event-hook)) + (format #t "~Tparent: ~A~%" (as-process (-> obj parent))) + (format #t "~Tbrother: ~A~%" (as-process (-> obj brother))) + (format #t "~Tchild: ~A~%" (as-process (-> obj child))) + (format #t "~Tconnection-list: ~`connectable`P~%" (-> obj connection-list)) + (format #t "~Tstack-frame-top: ~A~%" (-> obj stack-frame-top)) + (format #t "~Theap-base: #x~X~%" (-> obj heap-base)) + (format #t "~Theap-top: #x~X~%" (-> obj heap-top)) + (format #t "~Theap-cur: #x~X~%" (-> obj heap-cur)) + + ;; print all objects on the process heap + (protect (*print-column*) + (+! *print-column* *tab-size*) + (format #t "----~%") + (inspect-process-heap obj) + (format #t "----~%") + ) + + (format #t "~Tallocated-length: ~D~%" (-> obj allocated-length)) + (format #t "~Tstack[~D] @ #x~X~%" (-> obj allocated-length) (-> obj stack)) + obj + ) + +(defmethod asize-of process ((obj process)) + (the int (+ (-> process size) (-> obj allocated-length))) + ) + +(defmethod print process ((obj process)) + (format #t "#<~A ~S ~A :state ~S " + (-> obj type) + (-> obj name) + (-> obj status) + (when (-> obj state) (-> obj state name))) + + (format #t ":stack ~D/~D :heap ~D/~D @ #x~X>" + (process-stack-used obj) + (process-stack-size obj) + (process-heap-used obj) + (process-heap-size obj) + obj + ) + obj + ) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Context Suspend And Resume - Kernel +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; the following functions are used for going from the kernel to temporary threads and back. +;; saved registers: rbx, rbp, r10, r11, r12 + +;; DANGER - THE KERNEL DOES NOT SAVE ITS FLOATING POINT CONTEXT!!!! + +;; we use this to store a GOAL pointer to the kernel's stack pointer when executing user code. +;; to get back to the kernel, we use this global symbol. +(define-extern *kernel-sp* pointer) + +(defun return-from-thread () + "Context switch to the saved kernel context now. + This is intended to be jumped to with the ret instruction + at the end of a normal function, so this should preserve rax." + (declare (asm-func none) + ;(print-asm) + ) + (rlet ((sp :reg rsp :type uint) + (off :reg r15 :type uint) + (s0 :reg rbx :type uint) + (s1 :reg rbp :type uint) + (s2 :reg r10 :type uint) + (s3 :reg r11 :type uint) + (s4 :reg r12 :type uint) + ) + ;; get the kernel stack pointer as a GOAL pointer + (.load-sym :sext #f sp *kernel-sp*) + ;; convert it back to a real pointer + (.add sp off) + + ;; restore saved registers... + ;; without coloring system because this is "cheating". + (.pop :color #f s4) + (.pop :color #f s3) + (.pop :color #f s2) + (.pop :color #f s1) + (.pop :color #f s0) + ;; return to the kernel function that called the user code + (.ret) + ) + ) + +(defun return-from-thread-dead () + "Like return from thread, but we clean up our process with deactivate first. + The return register is not preserved here, instead we return the value of deactivate" + (declare (asm-func none) + ;(print-asm) + ) + (rlet ((pp :reg r13 :type process) + (sp :reg rsp :type uint) + (off :reg r15 :type uint) + (s0 :reg rbx :type uint) + (s1 :reg rbp :type uint) + (s2 :reg r10 :type uint) + (s3 :reg r11 :type uint) + (s4 :reg r12 :type uint) + ) + + ;; first call the deactivate method. + (deactivate pp) + ;; get the kernel stack pointer as a GOAL pointer + (.load-sym :sext #f sp *kernel-sp*) + ;; convert it back to a real pointer + (.add sp off) + + ;; restore saved registers... + ;; without coloring system because this is "cheating". + (.pop :color #f s4) + (.pop :color #f s3) + (.pop :color #f s2) + (.pop :color #f s1) + (.pop :color #f s0) + ;; return to the kernel function that called the user code + (.ret) + ) + ) + +(defun reset-and-call ((obj thread) (func function)) + "Make the given thread the top thread, reset the stack, and call the function. + Sets up a return trampoline so when the function returns it will return to the + kernel context." + (declare (asm-func object) + ;(print-asm) + ) + + (rlet ((pp :reg r13 :type process) + (sp :reg rsp :type uint) + (off :reg r15 :type uint) + (s0 :reg rbx :type uint) + (s1 :reg rbp :type uint) + (s2 :reg r10 :type uint) + (s3 :reg r11 :type uint) + (s4 :reg r12 :type uint) + (temp :reg rax :type uint) + ) + + ;; set up the process pointer + (set! pp (-> obj process)) + ;; mark the process as running and set its top thread + (set! (-> pp status) 'running) + (set! (-> pp top-thread) obj) + + ;; save the current kernel regs + (.push :color #f s0) + (.push :color #f s1) + (.push :color #f s2) + (.push :color #f s3) + (.push :color #f s4) + + ;; make rsp a GOAL pointer + (.sub sp off) + ;; and store it + (set! *kernel-sp* (the pointer sp)) ;; todo, asm form here? + + ;; setup the rsp for the new thread + (set! sp (the uint (-> obj stack-top))) + (.add sp off) + + ;; push the return trampoline to the stack for the user code to return to + ;(.push 0) ;; for 16-byte stack alignment. + (set! temp (the uint return-from-thread)) + (.add temp off) + (.push temp) + ;; and call the function! + (.add func off) + (.jr func) + ) + ) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Context Suspend And Resume - Thread +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; these are for resuming and suspending a thread. + +(defmethod thread-suspend cpu-thread ((unused cpu-thread)) + "Suspend the thread and return to the kernel." + + (declare (asm-func none) + ;(print-asm) + ) + + ;; we begin this function with the thread object in pp. + ;; not sure why we do this, maybe at one point suspending didn't clobber + ;; temp registers? + (rlet ((obj :reg r13 :type cpu-thread) + (temp :reg rax :type uint) + (off :reg r15 :type uint) + (sp :reg rsp :type uint) + (s0 :reg rbx :type uint) + (s1 :reg rbp :type uint) + (s2 :reg r10 :type uint) + (s3 :reg r11 :type uint) + (s4 :reg r12 :type uint)) + + ;; get the return address pushed by "call" + (.pop temp) + ;; convert to a GOAL address + (.sub temp off) + ;; store return address in thread + (set! (-> obj pc) (the pointer temp)) + + ;; convert our stack pointer to a GOAL address + (.sub sp off) + ;; store in thread. + (set! (-> obj sp) (the pointer sp)) + + ;; back up registers + (.mov :color #f temp s0) + (set! (-> obj rreg 0) temp) + (.mov :color #f temp s1) + (set! (-> obj rreg 1) temp) + (.mov :color #f temp s2) + (set! (-> obj rreg 2) temp) + (.mov :color #f temp s3) + (set! (-> obj rreg 3) temp) + (.mov :color #f temp s4) + (set! (-> obj rreg 4) temp) + + ;; todo, back up fprs + + ;; get our process + (let ((proc (-> obj process))) + (when (> (process-stack-used proc) (-> obj stack-size)) + (break) ;; too much stack has been used and we can't suspend! + ) + + ;; mark the process as suspended and copy the stack + (set! (-> proc status) 'suspended) + (let ((cur (the (pointer uint64) (-> obj stack-top))) + (save (&+ (the (pointer uint64) (-> obj stack)) (-> obj stack-size))) + ) + (while (> (the int cur) (the int sp)) + (set! cur (the (pointer uint64) (&- cur 8))) + (set! save (the (pointer uint64) (&- save 8))) + (set! (-> save) (-> cur)) + ) + ) + ) + + ;; actually setting pp to 0 + (set! obj (the cpu-thread 0)) + + ;; get the kernel stack pointer as a GOAL pointer + (.load-sym :sext #f sp *kernel-sp*) + ;; convert it back to a real pointer + (.add sp off) + + ;; restore saved registers... + ;; without coloring system because this is "cheating". + (.pop :color #f s4) + (.pop :color #f s3) + (.pop :color #f s2) + (.pop :color #f s1) + (.pop :color #f s0) + ;; return to the kernel function that called the user code + (.ret) + ) + (none) + ) + + +(defmethod thread-resume cpu-thread ((thread-to-resume cpu-thread)) + (declare (asm-func none) + ;(print-asm) + ) + + (rlet ((obj :reg r13 :type cpu-thread) + (temp :reg rax :type uint) + (off :reg r15 :type uint) + (sp :reg rsp :type uint) + (s0 :reg rbx :type uint) + (s1 :reg rbp :type uint) + (s2 :reg r10 :type uint) + (s3 :reg r11 :type uint) + (s4 :reg r12 :type uint)) + + ;; save the current kernel regs + (.push :color #f s0) + (.push :color #f s1) + (.push :color #f s2) + (.push :color #f s3) + (.push :color #f s4) + + ;; make rsp a GOAL pointer + (.sub sp off) + ;; and store it + (set! *kernel-sp* (the pointer sp)) ;; todo, asm form here? + + ;; temp, stash thread in process-pointer + (set! obj thread-to-resume) + + ;; set stack pointer for the thread. + (set! sp (the uint (-> obj sp))) + + ;; restore the stack. + (let ((cur (the (pointer uint64) (-> obj stack-top))) + (restore (&+ (the (pointer uint64) (-> obj stack)) (-> obj stack-size))) + ) + (while (> (the int cur) (the int sp)) + (set! cur (the (pointer uint64) (&- cur 8))) + (set! restore (the (pointer uint64) (&- restore 8))) + (set! (-> cur) (-> restore)) + ) + ) + + ;; offset sp after we're done looking at it. + (.add sp off) + + ;; setup process + (set! (-> (-> obj process) top-thread) obj) + (set! (-> (-> obj process) status) 'running) + + ;; restore reg + (set! temp (-> obj rreg 0)) + (.mov :color #f s0 temp) + (set! temp (-> obj rreg 1)) + (.mov :color #f s1 temp) + (set! temp (-> obj rreg 2)) + (.mov :color #f s2 temp) + (set! temp (-> obj rreg 3)) + (.mov :color #f s3 temp) + (set! temp (-> obj rreg 4)) + (.mov :color #f s4 temp) + + ;; todo restore fpr. + + (set! temp (the uint (-> obj pc))) + (.add temp off) + (set! obj (the cpu-thread (-> obj process))) + (.jr temp) + ) + (none) + ) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Process Dead Pool +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; a dead-pool is a collection of processes of fixed size that you can get processes from. + +(define-extern *debug-dead-pool* dead-pool-heap) + +(defmethod new dead-pool ((allocation symbol) (type-to-make type) (count int) (stack-size int) (name basic)) + "Create a pool of count dead processes, each with a fixed size stack-size" + (let ((obj (object-new))) + ;; setup process naming + (set! (-> obj name) name) + (set! (-> obj mask) (process-mask process-tree)) + ;; setup process tree + (set! (-> obj parent) #f) + (set! (-> obj brother) #f) + (set! (-> obj child) #f) + ;; setup ref + (set! (-> obj self) obj) + (set! (-> obj ppointer) (&-> obj self)) + + (dotimes (i count) + ;; create each process + (let ((old-bro (-> obj child)) + (next ((method process new) allocation process 'dead stack-size))) + (set! (-> obj child) (as-ppointer next)) + (set! (-> next parent) (as-ppointer obj)) + (set! (-> next pool) obj) + (set! (-> next brother) old-bro) + ) + ) + obj + ) + ) + +(defmethod get-process dead-pool ((obj dead-pool) (type-to-make type) (stack-size int)) + "Get a process from this dead pool of the given type." + (let ((proc (-> obj child))) + + (when (and (not proc) *debug-segment* (neq? obj *debug-dead-pool*)) + ;; we failed, but we're in debug mode and not looking at the debug pool + ;; try again from the debug pool and warn if this works + (set! proc (the (pointer process-tree) (get-process *debug-dead-pool* type-to-make stack-size))) + (when proc + (format 0 "WARNING: ~A ~A had to be allocated from the debug pool, because ~A was empty.~%" + type-to-make (as-process proc) (-> obj name)) + ) + ;; there's a bug here. proc is a process here, but will be used as a process pointer. + ;; let's just kill the program here. + ;; this is likely a copy-paste bug from get-process dead-pool-heap. + (break) + ) + + (cond + (proc + ;; success! set our type and return. + (set! (-> (-> proc) type) type-to-make) + (the process (-> proc)) ;; cast from process-tree to process. + ) + (else + (format 0 "WARNING: ~A ~A could not be allocated, because ~A was empty.~%" + type-to-make (as-process proc) (-> obj name)) + (the process #f) + ) + ) + ) + ) + + +(defmethod return-process dead-pool ((obj dead-pool) (proc process)) + "Return a process to its pool once you are done with it." + (change-parent proc obj) + (none) + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Process Dead Pool Heap +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; a dead-pool-heap is a chunk of memory where you can allocate variable sized processes. +; these processes start out with a lot of memory, then shrink their heap (compact) to the size +; they actually need. To avoid heap fragmentation, the dead-pool-heap system will relocate +; processes. This requires that you implement the relocate method on your process. + +(define-extern *null-process* process) + +(defmethod new dead-pool-heap ((allocation symbol) (type-to-make type) (name basic) (allocated-length int) (heap-size int)) + "Create a new dead pool heap. It will support allocated-length processes and have a total heap size of heap-size" + (let ((obj (object-new (+ (the int (-> type-to-make size)) + (align16 (* allocated-length 12)) + heap-size)))) + (set! (-> obj name) name) + (set! (-> obj mask) (process-mask process-tree)) + (set! (-> obj allocated-length) allocated-length) + (set! (-> obj parent) #f) + (set! (-> obj brother) #f) + (set! (-> obj child) #f) + + (set! (-> obj self) obj) + (set! (-> obj ppointer) (&-> obj self)) + + ;; initialize each process handle + ;; build them into a linked list of null-process + (countdown (i allocated-length) + (let ((rec (-> obj process-list i))) + (set! (-> rec process) *null-process*) + (set! (-> rec next) (-> obj process-list (+ i 1))) + ) + ) + + ;; set up the dead-list + (set! (-> obj dead-list next) (-> obj process-list 0)) + (set! (-> obj alive-list process) #f) ;; likely typo here, should be dead-list + (set! (-> obj process-list (- allocated-length 1) next) #f) + + ;; nothing is alive + (set! (-> obj last) (-> obj alive-list)) + (set! (-> obj alive-list next) #f) + (set! (-> obj alive-list process) #f) + (set! (-> obj first-gap) (-> obj alive-list)) + (set! (-> obj first-shrink) #f) + + ;; setup the heap. It just begins after the process records. + (set! (-> obj heap base) (the pointer (align16 (-> obj process-list allocated-length)))) + (set! (-> obj heap current) (-> obj heap base)) + (set! (-> obj heap top) (&+ (-> obj heap base) heap-size)) + (set! (-> obj heap top-base) (-> obj heap top)) + obj + ) + ) + +(defmethod gap-location dead-pool-heap ((obj dead-pool-heap) (rec dead-pool-heap-rec)) + "Get the gap after the given process. + If root of the alive list is given, will give the first gap between the heap and the first process. + If there is no gap, may point to the next process. Not 16-byte aligned." + (cond + ((-> rec process) + (the pointer (&+ (-> rec process) (-> process size) (-> rec process allocated-length) (- *gtype-basic-offset*))) + ;; start of proc end of type data process's heap basic offset + ) + (else + (-> obj heap base) + ) + ) + ) + +(defmethod gap-size dead-pool-heap ((obj dead-pool-heap) (rec dead-pool-heap-rec)) + "Determine the size between the given process and the next process or end of the heap. + If you give the first rec, it will given the gap between the beginning of the heap and the next process." + (the int + (cond + ((-> rec process) + ;; compute the end of my process (no basic offset) + (let ((my-end (&+ (-> rec process) (-> process size) (-> rec process allocated-length)))) + (if (-> rec next) + ;; if there's a next process, look at the difference to the next (basic offsets cancel) + (&- (-> rec next process) my-end) + ;; no next process, look at the top of the heap. + (&- (-> obj heap top) (&+ my-end *gtype-basic-offset*)) + ) + ) + ) + (else + (if (-> rec next) + (&- (-> rec next process) (&+ (-> obj heap base) *gtype-basic-offset*)) + (&- (-> obj heap top) (-> obj heap base))) + ) + ) + ) + ) + +(defmethod find-gap dead-pool-heap ((obj dead-pool-heap) (rec dead-pool-heap-rec)) + "Start at the given record and find the closest gap after it. Returns the rec + which has the gap after it. If no gaps, returns the last rec." + (while (and (-> rec next) (zero? (gap-size obj rec))) + ; no gap here! + (set! rec (-> rec next)) + ) + rec + ) + + +(defmethod inspect dead-pool-heap ((obj dead-pool-heap)) + "Inspect a dead-pool-heap and all of the recs and their gaps" + (format #t "[~8x] ~A~%" obj (-> obj type)) + (format #t "~Tname: ~A~%" (-> obj name)) + (format #t "~Tmask: ~D~%" (-> obj mask)) + (format #t "~Tparent: #x~X~%" (-> obj parent)) + (format #t "~Tbrother: #x~X~%" (-> obj brother)) + (format #t "~Tchild: #x~X~%" (-> obj child)) + (format #t "~Tppointer: #x~X~%" (-> obj ppointer)) + (format #t "~Tself: ~A~%" (-> obj self)) + (format #t "~Tallocated-length: ~D~%" (-> obj allocated-length)) + (format #t "~Theap: #~%" (-> obj heap)) + (format #t "~Tfirst-gap: #~%" (-> obj first-gap)) + (format #t "~Tfirst-shrink: #~%" (-> obj first-shrink)) + (format #t "~Talive-list: #~%" (-> obj alive-list)) + (format #t "~Tlast: #~%" (-> obj last)) + (format #t "~Tdead-list: #~%" (-> obj dead-list)) + + ;; here we consider the free memory to be all of the stuff after the last process. + ;; we don't consider random gaps to be "free". + ;; this means you can do a single allocation of free bytes and it will always succeed. + (let* ((total (the int (&- (-> obj heap top) (-> obj heap base)))) + (free (if (-> obj last) + (gap-size obj (-> obj last)) + total)) + ) + (format #t "~Tprocess-list[0] @ #x~X ~D/~D bytes used~%" (-> obj process-list) (- total free) total) + ) + + (let ((rec (-> obj alive-list)) + (i 0) + ) + (while rec + (when (-> rec process) + (format #t "~T [~3D] # ~A~%" i rec (-> rec process)) + ) + (let ((gap (gap-size obj rec))) + (unless (zero? gap) + (format #t "~T gap: ~D bytes @ #x~X~%" gap (gap-location obj rec))) + ) + (set! rec (-> rec next)) + (+! i 1) + ) + ) + + obj) + +(defmethod asize-of dead-pool-heap ((obj dead-pool-heap)) + "Get our total size. Uses the heap top as the end." + (- (the int (-> obj heap top)) (the int obj) *gtype-basic-offset*) + ) + +(defmethod memory-used dead-pool-heap ((obj dead-pool-heap)) + "Get the amount of memory used. This includes gaps between processes." + (if (-> obj last) + ; we have at least one process, get the not-last-gap memory + (- (memory-total obj) (gap-size obj (-> obj last))) + ; no processes. + 0 + ) + ) + +(defmethod memory-total dead-pool-heap ((obj dead-pool-heap)) + "Get the total amount of memory for processes" + (the int (&- (-> obj heap top) (-> obj heap base))) + ) + +(defmethod memory-free dead-pool-heap ((obj dead-pool-heap)) + "Get the total memory free." + (let ((top (-> obj heap top))) + (if (-> obj last) + ; get the last gap size + (gap-size obj (-> obj last)) + ; otherwise just the whole heap. + (the int (&- top (-> obj heap base))) + ) + ) + ) + +(defmethod compact-time dead-pool-heap ((obj dead-pool-heap)) + "Access the compact time field." + (-> obj compact-time) + ) + +(defmethod find-gap-by-size dead-pool-heap ((obj dead-pool-heap) (size int)) + "Find a gap which will fit at least size bytes. Returns the rec for the proc before the gap. + Will return a #f rec if there's no gap big enough." + ; start our search at first-gap + (let ((rec (-> obj first-gap))) + (while (and rec (< (gap-size obj rec) size)) + ;; nope, not big enough. + (set! rec (-> rec next)) + ) + rec + ) + ) + +(define-extern *vis-boot* basic) + +(defmethod get-process dead-pool-heap ((obj dead-pool-heap) (type-to-make type) (stack-size int)) + "Allocate a process" + + ;; get a record for the new process + (let ((rec (-> obj dead-list next)) + ;; will eventually hold our new process + (proc (the process #f)) + ;; find the rec which has a big enough gap + (insert (find-gap-by-size obj (+ (the int (-> process size)) stack-size))) + ) + + (cond + ;; check we got both a record and a gap + ((and rec insert) + + ;; pop the record off of the list + (set! (-> obj dead-list next) (-> rec next)) + + ;; splice it into the alive list in the right spot + (let ((next (-> insert next))) + ;; after the gap rec + (set! (-> insert next) rec) + ;; us to the process after the gap + (set! (-> rec next) next) + + ;; link the proc after us back + (when next + (set! (-> next prev) rec) + ) + ;; and us back to the proc before the gap + (set! (-> rec prev) insert) + + ;; if we are inserting after the last process, we should update the last. + (when (eq? insert (-> obj last)) + (set! (-> obj last) rec) + ) + + ;; get the gap + (set! proc (the process (gap-location obj insert))) + ;; and allocate! The method new does the offset for us. + (set! proc ((method process new) (the symbol proc) process 'process stack-size)) + + ;; update our rec to contain this process. + (set! (-> rec process) proc) + ;; and the ppointer should point to the rec, not the processs, so we can track the process if it moves. + (set! (-> proc ppointer) (&-> rec process)) + + ;; if we used the first gap, update first gap + (when (eq? (-> obj first-gap) insert) + (set! (-> obj first-gap) (find-gap obj rec)) + ) + + ;; we haven't shrunk yet. If we don't have a first-shrink, or we are before it, + ;; mark us as first shrink. + (when (or (not (-> obj first-shrink)) + (< (the int proc) (the int (-> obj first-shrink process))) + ) + (set! (-> obj first-shrink) rec) + ) + + ;; update tree stuff. + (set! (-> proc parent) (-> obj ppointer)) + (set! (-> proc pool) obj) + (set! (-> obj child) (&-> rec process)) + ) + + ) + (else + ;; allocation failed! try again on the debug heap if we're debugging. + (when (and *debug-segment* (not (eq? obj *debug-dead-pool*))) + (set! proc (get-process *debug-dead-pool* type-to-make stack-size)) + (when (and proc *vis-boot*) + (format 0 "WARNING: ~A ~A had to be allocated from the debug pool, because ~A was empty.~%" type-to-make proc (-> obj name))) + ) + + ) + ) + + (cond + (proc + ;; success! set type and return. + (set! (-> proc type) type-to-make) + ) + (else + ;; failure. complain. + (format 0 "WARNING: ~A ~A could not be allocated, because ~A was empty.~%" type-to-make proc (-> obj name)) + ) + ) + + proc) + ) + +(defmethod return-process dead-pool-heap ((obj dead-pool-heap) (proc process)) + "Return a process to a dead pool heap" + + ;; check we are returning to the correct pool + (unless (eq? obj (-> proc pool)) + (format 0 "ERROR: process ~A does not belong to dead-pool-heap ~A.~%" proc obj) + ) + + ;; reclaim us. + (change-parent proc obj) + + ;; we don't maintain a real tree for a dead-pool-heap, so undo any change to child + ;; done by change-parent + (set! (-> obj child) #f) + + ;; we know our ppointer is really a rec for a dead-pool-heap process, so we can use + ;; this trick to quickly find our rec. + (let ((rec (the dead-pool-heap-rec (-> proc ppointer)))) + + ;; if we are at or below the first gap, update first gap. + (when (or (eq? (-> obj first-gap) rec) + (< (the int (gap-location obj rec)) (the int (gap-location obj (-> obj first-gap)))) + ) + (set! (-> obj first-gap) (-> rec prev)) + ) + + + ;; update the first-shrink. We aren't smart about this and just move it backward. + (when (eq? (-> obj first-shrink) rec) + (set! (-> obj first-shrink) (-> rec prev)) + (when (not (-> obj first-shrink process)) + (set! (-> obj first-shrink) #f)) + ) + + ;; remove us from list + (set! (-> rec prev next) (-> rec next)) + (cond + ((-> rec next) + ;; update links + (set! (-> rec next prev) (-> rec prev)) + ) + (else + ;; we were last, update that. + (set! (-> obj last) (-> rec prev)) + ) + ) + + ;; insert at the front of the dead list. + (set! (-> rec next) (-> obj dead-list next)) + (set! (-> obj dead-list next) rec) + (set! (-> rec process) *null-process*) + + (none) + ) + ) + +(defmethod shrink-heap dead-pool-heap ((obj dead-pool-heap) (proc process)) + "Shrink the heap of a process. + This resizes the process heap to be the exact size it is currently using." + (when proc + ;; get our rec. + (let ((rec (the dead-pool-heap-rec (-> proc ppointer)))) + ;; check if it's ok to shrink + (unless (or (process-mask? (-> proc mask) heap-shrunk) ;; already shrunk + (and (not (-> proc next-state)) ;; uninitialized + (not (-> proc state))) ;; uninitialized + ) + ;; shrink! + (set! (-> proc allocated-length) (the int (&- (-> proc heap-cur) (-> proc stack)))) + (set! (-> proc heap-top) (&-> (-> proc stack) (-> proc allocated-length))) + + ;; update first gap + (when (< (the int proc) (the int (gap-location obj (-> obj first-gap)))) + (set! (-> obj first-gap) (find-gap obj rec)) + ) + + ;; mark us as shrunk + (process-mask-set! (-> proc mask) heap-shrunk) + ) + + ;; update first shrink + (when (eq? (-> obj first-shrink) rec) + (set! (-> obj first-shrink) (-> rec next)) + ) + ) + ) + obj + ) + +(define-extern *stdcon* basic) ;; todo, more specific + +(defmethod compact dead-pool-heap ((obj dead-pool-heap) (count int)) + "Do heap compaction. The count argument tells us how much work to do. + If the heap is very full we will automatically do more work than requested." + + ;; first we see how much memory is in use. + (let ((free (memory-free obj)) + (total (memory-total obj)) + ) + (let ((perc (/ (the float free) (the float total)))) + (cond + ((< perc 0.1) + ;; 90% full! set count very large to try to fix this and complain. + (set! count 1000) + (when (and *debug-segment* (-> *kernel-context* low-memory-message)) + (format *stdcon* "~3LLow Actor Memory~%~0L") + ) + ) + ((< perc 0.2) + ;; 80% full, try 4x harder + (set! count (* count 4)) + ) + ((< perc 0.3) + ;; 70% full, try 2x harder + (set! count (* count 2)) + ) + ) + ) + ) + + ;; update stats + (set! (-> obj compact-count-targ) count) + (set! (-> obj compact-count) 0) + + ;; and do compaction! + (countdown (ii count) + + ;; first try to shrink a heap. + (let ((shrink (-> obj first-shrink))) + (when (not shrink) + ;; not sure when this happens, but reset shrink if we need to. + (set! shrink (set! (-> obj first-shrink) (-> obj alive-list next))) + ) + (when shrink + ;; do a shrink! + (shrink-heap obj (-> shrink process)) + ) + ) + + ;; now find the first gap + (let ((gap (-> obj first-gap))) + ;; and the thing after it + (when (-> gap next) + (let ((proc (-> gap next process)) + (size (gap-size obj gap))) + (unless (zero? size) + (format #t "[kernel] Relocating process ~A by ~D.~%" proc (- size)) + (when (< size 0) + ;; bug! + (break) + ) + + ;; try shrinking before relocating. + (shrink-heap obj proc) + ;; relocate! + (relocate proc (- size)) + ;; update first gap + (set! (-> obj first-gap) (find-gap obj gap)) + ;; and update stats. + (+! (-> obj compact-count) 1) + ) + ) + ) + ) + ) + + (none) + ) + +(defmethod churn dead-pool-heap ((obj dead-pool-heap) (count int)) + "Mess with the heap" + + (countdown (ii count) + (let ((rec (-> obj alive-list next))) + (when rec + (when (or (eq? (-> obj first-gap) rec) + (< (the int (gap-location obj rec)) (the int (gap-location obj (-> obj first-gap)))) + ) + (set! (-> obj first-gap) (-> rec prev))) + + + (when (eq? (-> obj first-shrink) rec) + (set! (-> obj first-shrink) (-> rec prev)) + (when (not (-> obj first-shrink process)) + (set! (-> obj first-shrink) #f)) + ) + + (set! (-> rec prev next) (-> rec next)) + (cond + ((-> rec next) + (set! (-> rec next prev) (-> rec prev)) + ) + (else + (set! (-> obj last) (-> rec prev)) + ) + ) + + (let* ((insert (-> obj last)) + (next (-> insert next)) + ) + + (set! (-> insert next) rec) + (set! (-> rec next) next) + (when next + (set! (-> next prev) rec)) + (set! (-> rec prev) insert) + + (set! (-> obj last) rec) + (set! (-> rec process) (relocate (-> rec process) (the int (&- (gap-location obj insert) + (the int (&- (-> rec process) *gtype-basic-offset*)))))) + ) + ) + ) + ) + + (none) + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Process Finding +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; GOAL lambdas aren't real lambdas, so you have to do this. +(define *global-search-name* (the basic #f)) +(define *global-search-count* 0) + +(define-extern search-process-tree (function process-tree (function process-tree object) process)) +(define-extern iterate-process-tree (function process-tree (function object object) kernel-context object)) +(define-extern execute-process-tree (function process-tree (function object object) kernel-context object)) + +(defun process-by-name (name (pool process-tree)) + "Look up a process in the given pool by name" + (set! *global-search-name* (the basic name)) + (the process (search-process-tree pool (lambda ((var process)) + (name= (-> var name) *global-search-name*)))) + ) + +(defun process-not-name (name (pool process-tree)) + "Look up a process with not the given name." + (set! *global-search-name* (the basic name)) + (the process (search-process-tree pool (lambda ((var process)) + (not (name= (-> var name) *global-search-name*))))) + ) + +(defun process-count ((this process-tree)) + "Count number of processes in the given tree using iterate-process-tree" + (set! *global-search-count* 0) + (iterate-process-tree this + (lambda ((obj process)) + (+! *global-search-count* 1) + #t) + *null-kernel-context*) + *global-search-count*) + +(defun kill-by-name (name (pool process-tree)) + "Call deactivate on all process with the given name." + (let ((proc (the process-tree #f))) + (while (set! proc (process-by-name name pool)) + (deactivate proc) + ) + ) + ) + +(defun kill-by-type (type (pool process-tree)) + "Call deactivate on all processes with the given type" + (break) ; this is sketchy. + (set! *global-search-name* (the basic type)) + (let ((proc (the process-tree #f))) + (while (set! proc (search-process-tree pool (lambda ((var process)) + (= (the type *global-search-name*) + (-> var type))))) + (deactivate proc) + ) + ) + ) + +(defun kill-not-name (name (pool process-tree)) + "Call deactivate on all processes that don't match the name" + (let ((proc (the process-tree #f))) + (while (set! proc (process-not-name name pool)) + (deactivate proc) + ) + ) + ) + +(defun kill-not-type (type (pool process-tree)) + "Call deactivate on all prcesses that don't match the given type" + (break) ;; this function is weird. + (set! *global-search-name* (the basic type)) + (let ((proc (the process-tree #f))) + (while (set! proc (search-process-tree pool (lambda ((var process)) + (!= (the type *global-search-name*) + (-> var type))))) + (deactivate proc) + ) + ) + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Process Iterating +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod run-logic? process ((obj process)) + "Return if the process should be run or not." + #t) + +;; the following three functions recursively iterate through process trees. + +(defun iterate-process-tree ((obj process-tree) (func (function object object)) (context kernel-context)) + "Call func on all processes that aren't a process-tree. If func returns 'dead, stop. + The kernel-context is ignored." + (let ((ret (or (process-mask? (-> obj mask) process-tree) + (func obj)))) + (cond + ((eq? ret 'dead) + ;; stop. + ) + (else + ;; iterate through brothers + (let ((brother (-> obj child))) + (while brother + ;; kinda weird, we use the brother from _before_ recursing. + (let ((old-brother (-> (-> brother) brother))) + (iterate-process-tree (-> brother) func context) + (set! brother old-brother) + ) + ) + ) + ) + ) + ret + ) + ) + +(defun execute-process-tree ((obj process-tree) (func (function object object)) (context kernel-context)) + "Like iterate, but also requires that prevent-from-run's mask doesn't block, and that run-logic? + is true in order to call the function." + + ;; check mask for tree, mask for prevent, run-logic?, then run! + (let ((ret (or (process-mask? (-> obj mask) process-tree) + (not (and (or (zero? (logand (-> context prevent-from-run) (-> obj mask)))) + (run-logic? obj))) + (func obj) + ))) + + ;; run on our children + (cond + ((eq? ret 'dead) + ) + (else (let ((brother (-> obj child))) + (while brother + (let ((temp (-> (-> brother) brother))) + (execute-process-tree (-> brother) func context) + (set! brother temp)) + ) + ) + ) + ) + ret) + ) + + +(defun search-process-tree ((obj process-tree) (func (function process-tree object))) + "Find the first process which func return true on. Won't find process-tree's (by mask)" + + ;; reject process-tree + (unless (process-mask? (-> obj mask) process-tree) + ;; is this a match? + (when (func obj) + (return-from #f (the process obj)) + ) + ) + + ;; not a match, check out children + (let ((brother (-> obj child))) + (while brother + (let ((temp (-> (-> brother) brother))) + (let ((ret (search-process-tree (-> brother) func))) + (when ret + (return-from #f (the process ret)) + ) + ) + (set! brother temp) + ) + ) + ) + (the process #f) + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Kernel Dispatcher +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-extern *listener-process* process) +(define-extern *active-pool* process-tree) +(define-extern *stdcon0* basic) ; more specific? +(define-extern *stdcon1* basic) ; more specific? +(define-extern *debug-draw-pauseable* symbol) + +(defun kernel-dispatcher () + "Run the kernel! + " + + (when *listener-function* + (let ((result (reset-and-call (-> *listener-process* main-thread) *listener-function*))) + (if *use-old-listener-print* + (format #t "~D~%" result result result) + (format #t "~D #x~X ~F ~A~%" result result result result) + ) + ) + (set! *listener-function* #f) + (+! *enable-method-set* -1) + ) + + + (execute-process-tree + *active-pool* + (lambda ((obj process)) + (format 0 "Call to dispatcher lambda!~%") + (let ((context *kernel-context*)) + + (cond + ((or (eq? (-> obj status) 'waiting-to-run) + (eq? (-> obj status) 'suspended)) + + ;; we should run! + ;; set current process to us + (set! (-> context current-process) obj) + + ;; update pause junk for this run + (cond + ((process-mask? (-> obj mask) pause) + ;; we're paused. + (set! *stdcon* *stdcon1*) + (set! *debug-draw-pauseable* #t) + ) + (else + (set! *stdcon* *stdcon0*) + (set! *debug-draw-pauseable* #f) + ) + ) + + ;; TRANS + (cond + ((-> obj trans-hook) + ;; we have a trans hook defined. let's create a thread and run it. we can reuse the stack of the main-thread + ;; it is safe to do this because the main-thread is currently suspended or hasn't run yet. + ;; hack process -> global new todo + (let ((trans (new 'global 'cpu-thread obj 'trans PROCESS_STACK_SAVE_SIZE (-> obj main-thread stack-top)))) + ;; call the function in the thread. + (reset-and-call trans (-> obj trans-hook)) + ;; remove the cpu-thread + (delete trans) + ;; check for deadness + (when (eq? (-> obj status) 'dead) + (set! (-> context current-process) #f) + (return-from #f 'dead) + ) + ) + ) + ) + + ;; MAIN CODE + (if (process-mask? (-> obj mask) sleep-code) + ;; we're sleeping. Move us to suspended, in case we were in waiting to run. + (set! (-> obj status) 'suspended) + ;; not sleeping. call resume hook + ((-> obj main-thread resume-hook) (-> obj main-thread)) + ) + ;; check for deadness + (cond + ((eq? (-> obj status) 'dead) + ;; oops we died. return 'dead + (set! (-> context current-process) #f) + 'dead + ) + (else + ;; not dead. + ;; POST CODE + (cond + ((-> obj post-hook) + ;; hack process -> global new todo + (let ((post (new 'global 'cpu-thread obj 'post PROCESS_STACK_SAVE_SIZE *kernel-dram-stack*))) + (reset-and-call post (-> obj post-hook)) + (delete post) + (when (eq? (-> obj status) 'dead) + ;; oops we died. + (set! (-> context current-process) #f) + (return-from #f 'dead) + ) + (set! (-> obj status) 'suspended) + ) + ) + ) + (set! (-> context current-process) #f) + #f + ) + ) + ) + + ((eq? (-> obj status) 'dead) + 'dead) + ) + ) + ) + *kernel-context* + ) + + ;; todo, remove this and replace it with the rest of the kernel dispatcher. + (set! *listener-function* (the (function object) #f)) + ) + +(define-extern inspect-process-tree (function process-tree int int symbol process-tree)) +(defun inspect-process-tree ((obj process-tree) (level int) (mask int) (detail symbol)) + "Debug print a pocess-tree" + (print-tree-bitmask mask (+ 0 level)) + + ;; print us + (cond + (detail + (format #t "__________________~%") + ;; this is here, but I removed it because it prints at the wrong indent and looks weird. + ;(format #t "~S~A~%" (if (zero? level) "" "+---") obj) + (protect (*print-column*) + (set! *print-column* (the binteger (* level 4))) + (inspect obj) + ) + ) + (else + (format #t "~S~A~%" (if (zero? level) "" "+---") obj) + ) + ) + + ;; print our children + (let ((child (-> obj child))) + (while child + (inspect-process-tree (-> child) (+ level 1) (if (not (-> (-> child) brother)) mask (logior mask (ash 1 (+ 1 level)))) detail) + (set! child (-> (-> child) brother)) + ) + ) + obj + ) + +(defmacro set-u128-as-u64! (dst src) + `(set! (-> (the (pointer uint64) (& ,dst))) + ,src + ) + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Stack Frame Stuff (TODO) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The GOAL kernel supports dynamic throw and catch. +;; The catch frames are managed per process (you can't throw to a frame outside your process) +;; But otherwise it is fully dynamic. + +; (defmethod new catch-frame ((allocation symbol) (type-to-make type) (name symbol) (func function) (param-block (pointer uint64))) +; "Run func in a catch frame with the given 8 parameters. +; The return value is the result of the function. +; The allocation must be an address" +; (declare (asm-func object) +; (print-asm) +; ) + +; (rlet ((pp :reg r13 :type process) +; (temp :reg rax :type uint) +; (off :reg r15 :type uint) +; (sp :reg rsp :type uint) +; (s0 :reg rbx :type uint) +; (s1 :reg rbp :type uint) +; (s2 :reg r10 :type uint) +; (s3 :reg r11 :type uint) +; (s4 :reg r12 :type uint) +; (a0 :reg rdi :type uint) +; (a1 :reg rsi :type uint) +; (a2 :reg rdx :type uint) +; (a3 :reg rcx :type uint) +; (a4 :reg r8 :type uint) +; (a5 :reg r9 :type uint) +; (a6 :reg r10 :type uint) +; (a7 :reg r11 :type uint) +; ) + +; ;; we treat the allocation as an address. +; (let ((obj (the catch-frame (&+ allocation *gtype-basic-offset*)))) +; ;; setup catch frame +; (set! (-> obj type) type-to-make) +; (set! (-> obj name) name) +; ;; get the return address +; (.pop temp) +; (.push temp) +; ;; make it a GOAL address so it fits in 32 bitys +; (.sub temp off) +; ;; store it +; (set! (-> obj ra) (the int temp)) + +; ;; todo, do we need a stack offset here? +; (set! temp sp) +; (.sub temp off) +; (set! (-> obj sp) (the int sp)) + +; ;; back up registers +; (.mov :color #f temp s0) +; (set-u128-as-u64! (-> obj rreg 0) temp) +; (.mov :color #f temp s1) +; (set-u128-as-u64! (-> obj rreg 1) temp) +; (.mov :color #f temp s2) +; (set-u128-as-u64! (-> obj rreg 2) temp) +; (.mov :color #f temp s3) +; (set-u128-as-u64! (-> obj rreg 3) temp) +; (.mov :color #f temp s4) +; (set-u128-as-u64! (-> obj rreg 4) temp) +; ;; todo save fprs + +; ;; push this stack frame +; (set! (-> obj next) (-> pp stack-frame-top)) +; (set! (-> pp stack-frame-top) obj) + +; (let ((ret ((the-super-u64-fucntion func) +; ;(-> param-block 0) +; (-> param-block) +; ;(-> param-block 1) +; (-> (&+ param-block 8)) +; (-> (&+ param-block 16)) +; (-> (&+ param-block 24)) +; ;(-> (&+ param-block 32)) +; ; (-> param-block 5) +; )) +; ) + +; ; (set! (-> pp stack-frame-top) (-> pp stack-frame-top next)) +; ) +; ) +; ) +; ;; the code in here may throw at any point in time, without properly resetting saved registers. +; ;; so we should save them ourself. + +; (the object #f) +; ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Tree Stuff +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun change-parent ((obj process-tree) (new-parent process-tree)) + "Make obj a child of new-parent" + (let ((parent (-> obj parent))) + ;; parent is a ppointer. + + ;; need to remove obj from its current parent + (when parent + (let ((proc (-> (-> parent) child))) + (if (eq? (as-process proc) obj) + ;; case where we're the first child is easy! + (set! (-> (-> parent) child) (-> obj brother)) + ;; otherwise, look through brothers to find us. + (begin + (while (not (eq? (as-process (-> (-> proc) brother)) obj)) + (set! proc (-> (-> proc) brother)) + ) + ;; ok, got us, splice out of list. + (set! (-> (-> proc) brother) (-> obj brother)) + ) + ) + ) + ) + + ;; add to new parent + (set! (-> obj parent) (-> new-parent ppointer)) + (set! (-> obj brother) (-> new-parent child)) + (set! (-> new-parent child) (-> obj ppointer)) + obj + ) + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Process Globals +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(let ((obj (define *listener-process* (new 'global 'process 'listener 2048)))) + (set! (-> obj status) 'ready) + (set! (-> obj pid) 1) + ;; allocation symbol is actually process, but it's ignored so this is ok for now. + (set! (-> obj main-thread) (new 'global 'cpu-thread obj 'main 256 *kernel-dram-stack*)) + ) + +;; these are unknown +(define *null-process* (new 'global 'process 'listener 16)) +(define *vis-boot* #f) + +;; a few pools of fixed size processes that are shared. +(define *16k-dead-pool* (new 'global 'dead-pool 1 (* 16 1024) '*16k-dead-pool*)) +(define *8k-dead-pool* (new 'global 'dead-pool 1 (* 8 1024) '*8k-dead-pool*)) +(define *4k-dead-pool* (new 'global 'dead-pool 4 (* 4 1024) '*4k-dead-pool*)) + +;; some very important process pools +(define *target-dead-pool* (new 'global 'dead-pool 1 (* 48 1024) '*target-dead-pool*)) +(define *camera-dead-pool* (new 'global 'dead-pool 7 (* 4 1024) '*camera-dead-pool*)) +(define *camera-master-dead-pool* (new 'global 'dead-pool 1 (* 8 1024) '*camera-master-dead-pool*)) + +(if *debug-segment* + (define *debug-dead-pool* (new 'debug 'dead-pool-heap '*debug-dead-pool* 768 (* 1024 1024))) + ) + +(define *nk-dead-pool* (new 'global 'dead-pool-heap '*nk-dead-pool* 768 PROCESS_HEAP_SIZE)) +(define *default-dead-pool* (the dead-pool *nk-dead-pool*)) +(define *pickup-dead-pool* (the dead-pool *nk-dead-pool*)) + +;; todo dead pool list + +(define *active-pool* (new 'global 'process-tree 'active-pool)) +(change-parent (define *display-pool* (new 'global 'process-tree 'display-pool)) *active-pool*) +(change-parent (define *camera-pool* (new 'global 'process-tree 'camera-pool)) *active-pool*) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Temp Hacks +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; (defun kernel-dispatcher () +; "Kernel Dispatcher Function. This gets called from the main loop in kboot.cpp's KernelCheckAndDispatch" + +; ;; check if we have a new listener function to run +; (when *listener-function* +; ;; we do! enable method-set for debug purposes +; (+! *enable-method-set* 1) + +; ;; execute and print result +; (let ((result (*listener-function*))) +; (format #t "~D~%" result) +; ) +; (+! *enable-method-set* -1) + +; ;; clear the pending function. +; (set! *listener-function* (the (function object) #f)) +; ) +; ) diff --git a/goalc/compiler/CodeGenerator.cpp b/goalc/compiler/CodeGenerator.cpp index c476024ae..92ec8c45a 100644 --- a/goalc/compiler/CodeGenerator.cpp +++ b/goalc/compiler/CodeGenerator.cpp @@ -28,7 +28,7 @@ std::vector CodeGenerator::run() { if (function_names.find(f->name()) == function_names.end()) { function_names.insert(f->name()); } else { - printf("Failed to codegen, there are two functions with internal names %s\n", + printf("Failed to codegen, there are two functions with internal names [%s]\n", f->name().c_str()); throw std::runtime_error("Failed to codegen."); } diff --git a/goalc/compiler/Compiler.cpp b/goalc/compiler/Compiler.cpp index 8ce60dfeb..3d08109a6 100644 --- a/goalc/compiler/Compiler.cpp +++ b/goalc/compiler/Compiler.cpp @@ -297,5 +297,24 @@ void Compiler::typecheck(const goos::Object& form, const TypeSpec& actual, const std::string& error_message) { (void)form; - m_ts.typecheck(expected, actual, error_message, true, true); + if (!m_ts.typecheck(expected, actual, error_message, true, false)) { + throw_compiler_error(form, "Typecheck failed"); + } +} + +/*! + * Like typecheck, but will allow Val* to be #f if the destination isn't a number. + * Also will convert to register types for the type checking. + */ +void Compiler::typecheck_reg_type_allow_false(const goos::Object& form, + const TypeSpec& expected, + const Val* actual, + const std::string& error_message) { + if (!m_ts.typecheck(m_ts.make_typespec("number"), expected, "", false, false)) { + auto as_sym_val = dynamic_cast(actual); + if (as_sym_val && as_sym_val->name() == "#f") { + return; + } + } + typecheck(form, expected, coerce_to_reg_type(actual->type()), error_message); } \ No newline at end of file diff --git a/goalc/compiler/Compiler.h b/goalc/compiler/Compiler.h index 08ea8edfc..1112dd713 100644 --- a/goalc/compiler/Compiler.h +++ b/goalc/compiler/Compiler.h @@ -47,7 +47,7 @@ class Compiler { bool get_true_or_false(const goos::Object& form, const goos::Object& boolean); bool try_getting_macro_from_goos(const goos::Object& macro_name, goos::Object* dest); void set_bitfield(const goos::Object& form, BitFieldVal* dst, RegVal* src, Env* env); - Val* do_set(const goos::Object& form, Val* dst, RegVal* src, Env* env); + Val* do_set(const goos::Object& form, Val* dst, RegVal* src_in_reg, Val* src, Env* env); Val* compile_goos_macro(const goos::Object& o, const goos::Object& macro_obj, const goos::Object& rest, @@ -99,6 +99,10 @@ class Compiler { const TypeSpec& expected, const TypeSpec& actual, const std::string& error_message = ""); + void typecheck_reg_type_allow_false(const goos::Object& form, + const TypeSpec& expected, + const Val* actual, + const std::string& error_message = ""); TypeSpec parse_typespec(const goos::Object& src); bool is_local_symbol(const goos::Object& obj, Env* env); @@ -137,6 +141,11 @@ class Compiler { Val* to_math_type(const goos::Object& form, Val* in, MathMode mode, Env* env); bool is_none(Val* in); emitter::Register parse_register(const goos::Object& code); + u64 enum_lookup(const goos::Object& form, + const GoalEnum& e, + const goos::Object& rest, + bool throw_on_error, + bool* success); Val* compile_enum_lookup(const goos::Object& form, const GoalEnum& e, const goos::Object& rest, @@ -231,7 +240,10 @@ class Compiler { Val* compile_asm_push(const goos::Object& form, const goos::Object& rest, Env* env); Val* compile_asm_pop(const goos::Object& form, const goos::Object& rest, Env* env); Val* compile_asm_sub(const goos::Object& form, const goos::Object& rest, Env* env); - + Val* compile_asm_add(const goos::Object& form, const goos::Object& rest, Env* env); + Val* compile_asm_load_sym(const goos::Object& form, const goos::Object& rest, Env* env); + Val* compile_asm_jr(const goos::Object& form, const goos::Object& rest, Env* env); + Val* compile_asm_mov(const goos::Object& form, const goos::Object& rest, Env* env); // Atoms // Block diff --git a/goalc/compiler/Env.cpp b/goalc/compiler/Env.cpp index 3534b13c0..8b2834b9b 100644 --- a/goalc/compiler/Env.cpp +++ b/goalc/compiler/Env.cpp @@ -159,6 +159,7 @@ std::string FileEnv::print() { void FileEnv::add_function(std::unique_ptr fe) { assert(fe->idx_in_file == -1); fe->idx_in_file = m_functions.size(); + assert(!fe->name().empty()); m_functions.push_back(std::move(fe)); } diff --git a/goalc/compiler/Env.h b/goalc/compiler/Env.h index c3435a501..eb9922add 100644 --- a/goalc/compiler/Env.h +++ b/goalc/compiler/Env.h @@ -96,6 +96,9 @@ class FileEnv : public Env { void debug_print_tl(); const std::vector>& functions() { return m_functions; } const std::vector>& statics() { return m_statics; } + std::string get_anon_function_name() { + return "anon-function-" + std::to_string(m_anon_func_counter++); + } const FunctionEnv& top_level_function() { assert(m_top_level_func); return *m_top_level_func; @@ -110,6 +113,7 @@ class FileEnv : public Env { std::vector> m_functions; std::vector> m_statics; std::unique_ptr m_no_emit_env = nullptr; + int m_anon_func_counter = 0; // statics FunctionEnv* m_top_level_func = nullptr; diff --git a/goalc/compiler/IR.cpp b/goalc/compiler/IR.cpp index dc494132b..5fc079586 100644 --- a/goalc/compiler/IR.cpp +++ b/goalc/compiler/IR.cpp @@ -1080,4 +1080,143 @@ void IR_AsmSub::do_codegen(emitter::ObjectGenerator* gen, } else { gen->add_instr(IGen::sub_gpr64_gpr64(get_no_color_reg(m_dst), get_no_color_reg(m_src)), irec); } +} + +/////////////////////// +// AsmAdd +/////////////////////// + +IR_AsmAdd::IR_AsmAdd(bool use_coloring, const RegVal* dst, const RegVal* src) + : IR_Asm(use_coloring), m_dst(dst), m_src(src) {} + +std::string IR_AsmAdd::print() { + return fmt::format(".add{} {}, {}", get_color_suffix_string(), m_dst->print(), m_src->print()); +} + +RegAllocInstr IR_AsmAdd::to_rai() { + RegAllocInstr rai; + if (m_use_coloring) { + rai.write.push_back(m_dst->ireg()); + rai.read.push_back(m_dst->ireg()); + rai.read.push_back(m_src->ireg()); + } + return rai; +} + +void IR_AsmAdd::do_codegen(emitter::ObjectGenerator* gen, + const AllocationResult& allocs, + emitter::IR_Record irec) { + if (m_use_coloring) { + gen->add_instr( + IGen::add_gpr64_gpr64(get_reg(m_dst, allocs, irec), get_reg(m_src, allocs, irec)), irec); + } else { + gen->add_instr(IGen::add_gpr64_gpr64(get_no_color_reg(m_dst), get_no_color_reg(m_src)), irec); + } +} + +/////////////////////// +// AsmGetSymbolValue +/////////////////////// + +IR_GetSymbolValueAsm::IR_GetSymbolValueAsm(bool use_coloring, + const RegVal* dest, + std::string sym_name, + bool sext) + : IR_Asm(use_coloring), m_dest(dest), m_sym_name(std::move(sym_name)), m_sext(sext) {} + +std::string IR_GetSymbolValueAsm::print() { + return fmt::format(".load-sym{} {} [{}]", get_color_suffix_string(), m_dest->print(), m_sym_name); +} + +RegAllocInstr IR_GetSymbolValueAsm::to_rai() { + RegAllocInstr rai; + if (m_use_coloring) { + rai.write.push_back(m_dest->ireg()); + } + return rai; +} + +void IR_GetSymbolValueAsm::do_codegen(emitter::ObjectGenerator* gen, + const AllocationResult& allocs, + emitter::IR_Record irec) { + auto dst_reg = m_use_coloring ? get_reg(m_dest, allocs, irec) : get_no_color_reg(m_dest); + if (m_sext) { + auto instr = + gen->add_instr(IGen::load32s_gpr64_gpr64_plus_gpr64_plus_s32( + dst_reg, gRegInfo.get_st_reg(), gRegInfo.get_offset_reg(), 0x0badbeef), + irec); + gen->link_instruction_symbol_mem(instr, m_sym_name); + } else { + auto instr = + gen->add_instr(IGen::load32u_gpr64_gpr64_plus_gpr64_plus_s32( + dst_reg, gRegInfo.get_st_reg(), gRegInfo.get_offset_reg(), 0x0badbeef), + irec); + gen->link_instruction_symbol_mem(instr, m_sym_name); + } +} + +/////////////////////// +// AsmJumpReg +/////////////////////// + +IR_JumpReg::IR_JumpReg(bool use_coloring, const RegVal* src) : IR_Asm(use_coloring), m_src(src) {} + +std::string IR_JumpReg::print() { + return fmt::format(".jr{} {}", get_color_suffix_string(), m_src->print()); +} + +RegAllocInstr IR_JumpReg::to_rai() { + RegAllocInstr rai; + if (m_use_coloring) { + rai.read.push_back(m_src->ireg()); + } + return rai; +} + +void IR_JumpReg::do_codegen(emitter::ObjectGenerator* gen, + const AllocationResult& allocs, + emitter::IR_Record irec) { + auto src_reg = m_use_coloring ? get_reg(m_src, allocs, irec) : get_no_color_reg(m_src); + gen->add_instr(IGen::jmp_r64(src_reg), irec); +} + +/////////////////////// +// AsmRegSet +/////////////////////// + +IR_RegSetAsm::IR_RegSetAsm(bool use_color, const RegVal* dst, const RegVal* src) + : IR_Asm(use_color), m_dst(dst), m_src(src) {} + +std::string IR_RegSetAsm::print() { + return fmt::format(".mov{} {} {}", get_color_suffix_string(), m_dst->print(), m_src->print()); +} + +RegAllocInstr IR_RegSetAsm::to_rai() { + RegAllocInstr rai; + if (m_use_coloring) { + rai.write.push_back(m_dst->ireg()); + rai.read.push_back(m_src->ireg()); + } + return rai; +} + +void IR_RegSetAsm::do_codegen(emitter::ObjectGenerator* gen, + const AllocationResult& allocs, + emitter::IR_Record irec) { + auto val_reg = m_use_coloring ? get_reg(m_src, allocs, irec) : get_no_color_reg(m_src); + auto dest_reg = m_use_coloring ? get_reg(m_dst, allocs, irec) : get_no_color_reg(m_dst); + + if (val_reg == dest_reg) { + gen->add_instr(IGen::null(), irec); + } else if (val_reg.is_gpr() && dest_reg.is_gpr()) { + gen->add_instr(IGen::mov_gpr64_gpr64(dest_reg, val_reg), irec); + } else if (val_reg.is_xmm() && dest_reg.is_gpr()) { + gen->add_instr(IGen::movd_gpr32_xmm32(dest_reg, val_reg), irec); + } else if (val_reg.is_gpr() && dest_reg.is_xmm()) { + gen->add_instr(IGen::movd_xmm32_gpr32(dest_reg, val_reg), irec); + } else if (val_reg.is_xmm() && dest_reg.is_xmm()) { + gen->add_instr(IGen::mov_xmm32_xmm32(dest_reg, val_reg), irec); + } else { + assert(false); + } } \ No newline at end of file diff --git a/goalc/compiler/IR.h b/goalc/compiler/IR.h index 3b33427f2..0da77f13a 100644 --- a/goalc/compiler/IR.h +++ b/goalc/compiler/IR.h @@ -430,4 +430,60 @@ class IR_AsmSub : public IR_Asm { const RegVal* m_src = nullptr; }; +class IR_AsmAdd : public IR_Asm { + public: + IR_AsmAdd(bool use_coloring, const RegVal* dst, const RegVal* src); + std::string print() override; + RegAllocInstr to_rai() override; + void do_codegen(emitter::ObjectGenerator* gen, + const AllocationResult& allocs, + emitter::IR_Record irec) override; + + private: + const RegVal* m_dst = nullptr; + const RegVal* m_src = nullptr; +}; + +class IR_GetSymbolValueAsm : public IR_Asm { + public: + IR_GetSymbolValueAsm(bool use_coloring, const RegVal* dest, std::string sym_name, bool sext); + std::string print() override; + RegAllocInstr to_rai() override; + void do_codegen(emitter::ObjectGenerator* gen, + const AllocationResult& allocs, + emitter::IR_Record irec) override; + + protected: + const RegVal* m_dest = nullptr; + std::string m_sym_name; + bool m_sext = false; +}; + +class IR_JumpReg : public IR_Asm { + public: + IR_JumpReg(bool use_coloring, const RegVal* src); + std::string print() override; + RegAllocInstr to_rai() override; + void do_codegen(emitter::ObjectGenerator* gen, + const AllocationResult& allocs, + emitter::IR_Record irec) override; + + protected: + const RegVal* m_src = nullptr; +}; + +class IR_RegSetAsm : public IR_Asm { + public: + IR_RegSetAsm(bool use_color, const RegVal* dst, const RegVal* src); + std::string print() override; + RegAllocInstr to_rai() override; + void do_codegen(emitter::ObjectGenerator* gen, + const AllocationResult& allocs, + emitter::IR_Record irec) override; + + protected: + const RegVal* m_dst = nullptr; + const RegVal* m_src = nullptr; +}; + #endif // JAK_IR_H diff --git a/goalc/compiler/Util.cpp b/goalc/compiler/Util.cpp index cf1dcb5ff..cecf88a93 100644 --- a/goalc/compiler/Util.cpp +++ b/goalc/compiler/Util.cpp @@ -161,6 +161,32 @@ bool Compiler::try_getting_constant_integer(const goos::Object& in, int64_t* out return true; } + if (in.is_pair()) { + auto head = in.as_pair()->car; + if (head.is_symbol()) { + auto head_sym = head.as_symbol(); + auto enum_kv = m_enums.find(head_sym->name); + if (enum_kv != m_enums.end()) { + bool success; + u64 as_enum = enum_lookup(in, enum_kv->second, in.as_pair()->cdr, false, &success); + if (success) { + *out = as_enum; + return true; + } + } + } + } + + if (in.is_symbol()) { + auto global_constant = m_global_constants.find(in.as_symbol()); + if (global_constant != m_global_constants.end()) { + // recursively get constant integer, so we can have constants set to constants, etc. + if (try_getting_constant_integer(global_constant->second, out, env)) { + return true; + } + } + } + // todo, try more things like constants before giving up. return false; } diff --git a/goalc/compiler/compilation/Asm.cpp b/goalc/compiler/compilation/Asm.cpp index 4248c3b75..58529c7a0 100644 --- a/goalc/compiler/compilation/Asm.cpp +++ b/goalc/compiler/compilation/Asm.cpp @@ -151,4 +151,79 @@ Val* Compiler::compile_asm_sub(const goos::Object& form, const goos::Object& res auto src = compile_error_guard(args.unnamed.at(1), env)->to_gpr(env); env->emit_ir(color, dest, src); return get_none(); +} + +Val* Compiler::compile_asm_add(const goos::Object& form, const goos::Object& rest, Env* env) { + auto args = get_va(form, rest); + va_check(form, args, {{}, {}}, {{"color", {false, goos::ObjectType::SYMBOL}}}); + bool color = true; + if (args.has_named("color")) { + color = get_true_or_false(form, args.named.at("color")); + } + auto dest = compile_error_guard(args.unnamed.at(0), env)->to_gpr(env); + if (!dest->settable()) { + throw_compiler_error(form, "Cannot .add this. Got a {}.", dest->print()); + } + auto src = compile_error_guard(args.unnamed.at(1), env)->to_gpr(env); + env->emit_ir(color, dest, src); + return get_none(); +} + +Val* Compiler::compile_asm_load_sym(const goos::Object& form, const goos::Object& rest, Env* env) { + auto args = get_va(form, rest); + va_check( + form, args, {{}, {goos::ObjectType::SYMBOL}}, + {{"sext", {false, goos::ObjectType::SYMBOL}}, {"color", {false, goos::ObjectType::SYMBOL}}}); + auto& sym_name = args.unnamed.at(1).as_symbol()->name; + auto sym_kv = m_symbol_types.find(sym_name); + if (sym_kv == m_symbol_types.end()) { + throw_compiler_error(form, "Cannot find a symbol named {}.", sym_name); + } + auto ts = sym_kv->second; + bool sext = m_ts.lookup_type(ts)->get_load_signed(); + if (args.has_named("sext")) { + sext = get_true_or_false(form, args.named.at("sext")); + } + + bool color = true; + if (args.has_named("color")) { + color = get_true_or_false(form, args.named.at("color")); + } + + auto dest = compile_error_guard(args.unnamed.at(0), env)->to_gpr(env); + if (!dest->settable()) { + throw_compiler_error(form, "Cannot .load-sym this. Got a {}.", dest->print()); + } + + env->emit_ir(color, dest, sym_name, sext); + return get_none(); +} + +Val* Compiler::compile_asm_jr(const goos::Object& form, const goos::Object& rest, Env* env) { + auto args = get_va(form, rest); + va_check(form, args, {{}}, {{"color", {false, goos::ObjectType::SYMBOL}}}); + bool color = true; + if (args.has_named("color")) { + color = get_true_or_false(form, args.named.at("color")); + } + + auto src = compile_error_guard(args.unnamed.at(0), env)->to_gpr(env); + env->emit_ir(color, src); + return get_none(); +} + +Val* Compiler::compile_asm_mov(const goos::Object& form, const goos::Object& rest, Env* env) { + auto args = get_va(form, rest); + va_check(form, args, {{}, {}}, {{"color", {false, goos::ObjectType::SYMBOL}}}); + bool color = true; + if (args.has_named("color")) { + color = get_true_or_false(form, args.named.at("color")); + } + auto dest = compile_error_guard(args.unnamed.at(0), env)->to_gpr(env); + if (!dest->settable()) { + throw_compiler_error(form, "Cannot .mov this. Got a {}.", dest->print()); + } + auto src = compile_error_guard(args.unnamed.at(1), env)->to_gpr(env); + env->emit_ir(color, dest, src); + return get_none(); } \ No newline at end of file diff --git a/goalc/compiler/compilation/Atoms.cpp b/goalc/compiler/compilation/Atoms.cpp index 66c4c9350..2b09b5e7b 100644 --- a/goalc/compiler/compilation/Atoms.cpp +++ b/goalc/compiler/compilation/Atoms.cpp @@ -18,9 +18,11 @@ static const std::unordered_map< {".push", &Compiler::compile_asm_push}, {".pop", &Compiler::compile_asm_pop}, {"rlet", &Compiler::compile_rlet}, - // {".jmp", &Compiler::compile_asm}, + {".jr", &Compiler::compile_asm_jr}, {".sub", &Compiler::compile_asm_sub}, - // {".ret-reg", &Compiler::compile_asm}, + {".add", &Compiler::compile_asm_add}, + {".load-sym", &Compiler::compile_asm_load_sym}, + {".mov", &Compiler::compile_asm_mov}, // BLOCK FORMS {"top-level", &Compiler::compile_top_level}, @@ -254,6 +256,12 @@ Val* Compiler::compile_get_symbol_value(const goos::Object& form, Val* Compiler::compile_symbol(const goos::Object& form, Env* env) { auto name = symbol_string(form); + // optimization to look these up as symbol objects, not getting the value of a symbol. + // so you don't have to type '#f, '#t everywhere to get the best performance. + if (name == "#t" || name == "#f") { + return compile_get_sym_obj(name, env); + } + // see if the symbol is defined in any enclosing symbol macro envs (mlet's). auto mlet_env = get_parent_env_of_type(env); while (mlet_env) { diff --git a/goalc/compiler/compilation/Define.cpp b/goalc/compiler/compilation/Define.cpp index 02b2dc79a..015cecaf5 100644 --- a/goalc/compiler/compilation/Define.cpp +++ b/goalc/compiler/compilation/Define.cpp @@ -11,7 +11,8 @@ */ Val* Compiler::compile_define(const goos::Object& form, const goos::Object& rest, Env* env) { auto args = get_va(form, rest); - va_check(form, args, {goos::ObjectType::SYMBOL, {}}, {}); + va_check(form, args, {goos::ObjectType::SYMBOL, {}}, + {{"no-typecheck", {false, goos::ObjectType::SYMBOL}}}); auto& sym = args.unnamed.at(0); auto& val = args.unnamed.at(1); @@ -43,7 +44,13 @@ Val* Compiler::compile_define(const goos::Object& form, const goos::Object& rest if (existing_type == m_symbol_types.end()) { m_symbol_types[sym.as_symbol()->name] = in_gpr->type(); } else { - typecheck(form, existing_type->second, in_gpr->type(), "define on existing symbol"); + bool do_typecheck = true; + if (args.has_named("no-typecheck")) { + do_typecheck = !get_true_or_false(form, args.named.at("no-typecheck")); + } + if (do_typecheck) { + typecheck(form, existing_type->second, in_gpr->type(), "define on existing symbol"); + } } if (!sym_val->settable()) { @@ -122,13 +129,18 @@ void Compiler::set_bitfield(const goos::Object& form, BitFieldVal* dst, RegVal* } env->emit(std::make_unique(IntegerMathKind::OR_64, original, temp)); - do_set(form, dst->parent(), original, env); + do_set(form, dst->parent(), original, original, env); } /*! * The internal "set" logic. + * The source is provided both as the directly Val* from compilation and as a RegVal*. + * This is a bit weird, but is required to do things in exactly the same order as GOAL, but + * makes us able to check if the source is #f, which is allowed to bypass type checking in some + * cases. If the source is unavailable, you can just put the same thing for src_in_reg and src, but + * you'll lose the ability to detect and accept #f as a null reference. */ -Val* Compiler::do_set(const goos::Object& form, Val* dest, RegVal* source, Env* env) { +Val* Compiler::do_set(const goos::Object& form, Val* dest, RegVal* src_in_reg, Val* src, Env* env) { if (!dest->settable()) { throw_compiler_error(form, "Cannot set! {} because it is not settable.", dest->print()); } @@ -140,8 +152,8 @@ Val* Compiler::do_set(const goos::Object& form, Val* dest, RegVal* source, Env* if (as_mem_deref) { auto dest_type = coerce_to_reg_type(as_mem_deref->type()); - if (dest_type != TypeSpec("uint") || source->type() != TypeSpec("int")) { - typecheck(form, dest_type, source->type(), "set! memory"); + if (dest_type != TypeSpec("uint") || coerce_to_reg_type(src->type()) != TypeSpec("int")) { + typecheck_reg_type_allow_false(form, dest_type, src, "set! memory"); } // setting somewhere in memory @@ -151,31 +163,31 @@ Val* Compiler::do_set(const goos::Object& form, Val* dest, RegVal* source, Env* // if it is a constant offset, we can use a fancy x86-64 addressing mode to simplify auto ti = m_ts.lookup_type(as_mem_deref->type()); env->emit(std::make_unique( - source, base_as_mco->offset, base_as_mco->base->to_gpr(env), ti->get_load_size())); - return source; + src_in_reg, base_as_mco->offset, base_as_mco->base->to_gpr(env), ti->get_load_size())); + return src_in_reg; } else { // nope, the pointer to dereference is some compliated thing. auto ti = m_ts.lookup_type(as_mem_deref->type()); - env->emit( - std::make_unique(source, 0, base->to_gpr(env), ti->get_load_size())); - return source; + env->emit(std::make_unique(src_in_reg, 0, base->to_gpr(env), + ti->get_load_size())); + return src_in_reg; } } else if (as_pair) { // this could probably be part of MemoryDerefVal and not a special case here. - env->emit(std::make_unique(source, as_pair->is_car ? -2 : 2, + env->emit(std::make_unique(src_in_reg, as_pair->is_car ? -2 : 2, as_pair->base->to_gpr(env), 4)); - return source; + return src_in_reg; } else if (as_reg) { - typecheck(form, as_reg->type(), source->type(), "set! lexical variable"); - env->emit(std::make_unique(as_reg, source)); - return source; + typecheck_reg_type_allow_false(form, as_reg->type(), src, "set! lexical variable"); + env->emit(std::make_unique(as_reg, src_in_reg)); + return src_in_reg; } else if (as_sym_val) { - typecheck(form, as_sym_val->type(), source->type(), "set! global symbol"); - auto result_in_gpr = source->to_gpr(env); + typecheck_reg_type_allow_false(form, as_sym_val->type(), src, "set! global symbol"); + auto result_in_gpr = src_in_reg->to_gpr(env); env->emit(std::make_unique(as_sym_val->sym(), result_in_gpr)); return result_in_gpr; } else if (as_bitfield) { - set_bitfield(form, as_bitfield, source, env); + set_bitfield(form, as_bitfield, src_in_reg, env); return get_none(); } @@ -195,7 +207,8 @@ Val* Compiler::compile_set(const goos::Object& form, const goos::Object& rest, E // todo, I don't know if this is the correct order or not. Right now the value is computed // and to_reg'd first, then the destination is computed, if the destination requires math to // compute. - auto source = compile_error_guard(args.unnamed.at(1), env)->to_reg(env); + auto source = compile_error_guard(args.unnamed.at(1), env); + auto source_reg = source->to_reg(env); auto dest = compile_error_guard(destination, env); - return do_set(form, dest, source, env); + return do_set(form, dest, source_reg, source, env); } \ No newline at end of file diff --git a/goalc/compiler/compilation/Function.cpp b/goalc/compiler/compilation/Function.cpp index bf2b5a377..3ea792303 100644 --- a/goalc/compiler/compilation/Function.cpp +++ b/goalc/compiler/compilation/Function.cpp @@ -135,9 +135,9 @@ Val* Compiler::compile_lambda(const goos::Object& form, const goos::Object& rest // compile a function! First create a unique name... std::string function_name = lambda.debug_name; if (function_name.empty()) { - function_name = fmt::format("anonymous-function-{}", obj_env->functions().size()); + function_name = obj_env->get_anon_function_name(); } - auto new_func_env = std::make_unique(env, lambda.debug_name); + auto new_func_env = std::make_unique(env, function_name); new_func_env->set_segment(segment); // set up arguments diff --git a/goalc/compiler/compilation/Math.cpp b/goalc/compiler/compilation/Math.cpp index f99737623..6cf729a31 100644 --- a/goalc/compiler/compilation/Math.cpp +++ b/goalc/compiler/compilation/Math.cpp @@ -67,7 +67,9 @@ Val* Compiler::number_to_binteger(const goos::Object& form, Val* in, Env* env) { RegVal* input = in->to_reg(env); auto sa = fe->make_gpr(m_ts.make_typespec("int")); env->emit(std::make_unique(sa, 3)); - return compile_variable_shift(form, input, sa, env, IntegerMathKind::SHLV_64); + auto result = compile_variable_shift(form, input, sa, env, IntegerMathKind::SHLV_64); + result->set_type(m_ts.make_typespec("binteger")); + return result; } throw_compiler_error(form, "Cannot convert a {} to a binteger.", in->type().print()); return nullptr; @@ -115,7 +117,8 @@ Val* Compiler::compile_add(const goos::Object& form, const goos::Object& rest, E auto first_type = first_val->type(); auto math_type = get_math_mode(first_type); switch (math_type) { - case MATH_INT: { + case MATH_INT: + case MATH_BINT: { auto result = env->make_gpr(first_type); env->emit(std::make_unique(result, first_val->to_gpr(env))); diff --git a/goalc/compiler/compilation/Static.cpp b/goalc/compiler/compilation/Static.cpp index 1fd1739d1..461947b45 100644 --- a/goalc/compiler/compilation/Static.cpp +++ b/goalc/compiler/compilation/Static.cpp @@ -196,6 +196,17 @@ Val* Compiler::compile_new_static_structure_or_basic(const goos::Object& form, assert(deref_info.can_deref); assert(deref_info.load_size == 4); + // the linker needs to see a -1 in order to know to insert a symbol pointer + // instead of just the symbol table offset. + u32 linker_val = 0xffffffff; + memcpy(obj->data.data() + field_offset, &linker_val, 4); + } else if (field_value.is_symbol() && + (field_value.as_symbol()->name == "#t" || field_value.as_symbol()->name == "#f")) { + obj->add_symbol_record(symbol_string(field_value), field_offset); + assert(deref_info.mem_deref); + assert(deref_info.can_deref); + assert(deref_info.load_size == 4); + // the linker needs to see a -1 in order to know to insert a symbol pointer // instead of just the symbol table offset. u32 linker_val = 0xffffffff; diff --git a/goalc/compiler/compilation/Type.cpp b/goalc/compiler/compilation/Type.cpp index c3a164ba5..bdcd79007 100644 --- a/goalc/compiler/compilation/Type.cpp +++ b/goalc/compiler/compilation/Type.cpp @@ -289,7 +289,7 @@ Val* Compiler::compile_defmethod(const goos::Object& form, const goos::Object& _ } else { // type of argument is specified auto param_args = get_va(o, o); - va_check(o, param_args, {goos::ObjectType::SYMBOL, goos::ObjectType::SYMBOL}, {}); + va_check(o, param_args, {goos::ObjectType::SYMBOL, {}}, {}); GoalArg parm; parm.name = symbol_string(param_args.unnamed.at(0)); @@ -327,6 +327,7 @@ Val* Compiler::compile_defmethod(const goos::Object& form, const goos::Object& _ IRegConstraint constr; constr.instr_idx = 0; // constraint at function start auto ireg = new_func_env->make_ireg(lambda.params.at(i).type, emitter::RegKind::GPR); + ireg->mark_as_settable(); constr.ireg = ireg->ireg(); constr.desired_register = emitter::gRegInfo.get_arg_reg(i); new_func_env->params[lambda.params.at(i).name] = ireg; @@ -855,48 +856,75 @@ Val* Compiler::compile_defenum(const goos::Object& form, const goos::Object& _re return get_none(); } -Val* Compiler::compile_enum_lookup(const goos::Object& form, - const GoalEnum& e, - const goos::Object& rest, - Env* env) { +u64 Compiler::enum_lookup(const goos::Object& form, + const GoalEnum& e, + const goos::Object& rest, + bool throw_on_error, + bool* success) { + *success = true; if (e.is_bitfield) { - int64_t value = 0; + uint64_t value = 0; for_each_in_list(rest, [&](const goos::Object& o) { auto kv = e.entries.find(symbol_string(o)); if (kv == e.entries.end()) { - throw_compiler_error(form, "The value {} was not found in enum.", o.print()); + if (throw_on_error) { + throw_compiler_error(form, "The value {} was not found in enum.", o.print()); + } else { + *success = false; + return; + } } value |= (1 << kv->second); }); - auto result = compile_integer(value, env); - result->set_type(e.base_type); - return result; + return value; } else { - int64_t value = 0; + uint64_t value = 0; bool got = false; for_each_in_list(rest, [&](const goos::Object& o) { if (got) { - throw_compiler_error(form, "Invalid enum lookup."); + if (throw_on_error) { + throw_compiler_error(form, "Invalid enum lookup."); + } else { + *success = false; + return; + } } auto kv = e.entries.find(symbol_string(o)); if (kv == e.entries.end()) { - throw_compiler_error(form, "The value {} was not found in enum.", o.print()); + if (throw_on_error) { + throw_compiler_error(form, "The value {} was not found in enum.", o.print()); + } else { + *success = false; + return; + } } value = kv->second; got = true; }); if (!got) { - throw_compiler_error(form, "Invalid enum lookup."); + if (throw_on_error) { + throw_compiler_error(form, "Invalid enum lookup."); + } else { + *success = false; + } } - auto result = compile_integer(value, env); - result->set_type(e.base_type); - return result; + return value; } +} - return get_none(); +Val* Compiler::compile_enum_lookup(const goos::Object& form, + const GoalEnum& e, + const goos::Object& rest, + Env* env) { + bool success; + u64 value = enum_lookup(form, e, rest, true, &success); + assert(success); + auto result = compile_integer(value, env); + result->set_type(e.base_type); + return result; } bool GoalEnum::operator==(const GoalEnum& other) const { diff --git a/goalc/emitter/IGen.h b/goalc/emitter/IGen.h index a2b1132ea..3a2ed06a7 100644 --- a/goalc/emitter/IGen.h +++ b/goalc/emitter/IGen.h @@ -1281,9 +1281,11 @@ class IGen { } /*! - * Call a function stored in a 64-bit gpr + * Jump to an x86-64 address stored in a 64-bit gpr. */ - static Instruction jmp_r64(uint8_t reg) { + static Instruction jmp_r64(Register reg_) { + assert(reg_.is_gpr()); + auto reg = reg_.hw_id(); Instruction instr(0xff); if (reg >= 8) { instr.set(REX(false, false, false, true)); diff --git a/test/goalc/source_templates/variables/static-bitfield-field.gc b/test/goalc/source_templates/variables/static-bitfield-field.gc new file mode 100644 index 000000000..d4a77205b --- /dev/null +++ b/test/goalc/source_templates/variables/static-bitfield-field.gc @@ -0,0 +1,17 @@ +(defenum my-bitfield :bitfield #t :type uint32 + (zero 0) ; 1 + (one 1) ; 2 + (two 2) ; 4 + (three 3) ; 8 + (four 4) ; 16 + ) + + +(deftype test-static-bitfield-type (basic) + ((a uint32) + (field uint32)) + ) + +(let ((obj (new 'static 'test-static-bitfield-type :a 12 :field (my-bitfield one three)))) + (+ (-> obj a ) (-> obj field)) + ) \ No newline at end of file diff --git a/test/goalc/source_templates/with_game/test-new-static-basic.gc b/test/goalc/source_templates/with_game/test-new-static-basic.gc index d31351961..fc3790ca5 100644 --- a/test/goalc/source_templates/with_game/test-new-static-basic.gc +++ b/test/goalc/source_templates/with_game/test-new-static-basic.gc @@ -4,10 +4,12 @@ ((s8 int8) (s16 int16) (thing basic) + (thing-2 basic) + (thing-3 basic) (u64 uint64)) ) -(define test-static-basic (new 'static 'static-test-basic-type :s8 -122 :s16 -23123 :u64 434343 :thing 'bean)) +(define test-static-basic (new 'static 'static-test-basic-type :s8 -122 :s16 -23123 :u64 434343 :thing 'bean :thing-2 #t :thing-3 #f)) (expect-true (< (the int test-static-basic) (-> debug current))) ;; should be in debug segment? (expect-true (> (the int test-static-basic) (-> debug base))) @@ -16,6 +18,8 @@ (expect-true (= (-> test-static-basic s16) -23123)) (expect-true (= (-> test-static-basic u64) 434343)) (expect-true (eq? (-> test-static-basic thing) 'bean)) +(expect-true (eq? (-> test-static-basic thing-2) #t)) +(expect-true (eq? (-> test-static-basic thing-3) #f)) (expect-true (neq? (-> test-static-basic thing) 'not-bean)) (expect-true (eq? (-> test-static-basic type symbol) 'static-test-basic-type)) (expect-true (eq? (-> test-static-basic type) static-test-basic-type)) diff --git a/test/goalc/test_variables.cpp b/test/goalc/test_variables.cpp index 07e99b378..a46959be7 100644 --- a/test/goalc/test_variables.cpp +++ b/test/goalc/test_variables.cpp @@ -81,4 +81,8 @@ TEST_F(VariableTests, Bitfields) { TEST_F(VariableTests, InlineAsm) { runner.run_static_test(env, testCategory, "inline-asm.static.gc", {"1\n"}); +} + +TEST_F(VariableTests, StaticBitfieldField) { + runner.run_static_test(env, testCategory, "static-bitfield-field.gc", {"22\n"}); } \ No newline at end of file diff --git a/test/goalc/test_with_game.cpp b/test/goalc/test_with_game.cpp index 952585c43..515f1fc82 100644 --- a/test/goalc/test_with_game.cpp +++ b/test/goalc/test_with_game.cpp @@ -259,7 +259,7 @@ TEST_F(WithGameTests, NewStaticStructureIntegers) { TEST_F(WithGameTests, NewStaticBasic) { runner.run_static_test(env, testCategory, "test-new-static-basic.gc", - get_test_pass_string("new-static-basic", 9)); + get_test_pass_string("new-static-basic", 11)); } TEST_F(WithGameTests, VectorDot) {