From aac3985a614b280a7391a3c3f3648cc8e0b92e1d Mon Sep 17 00:00:00 2001 From: Felix Brendel Date: Tue, 10 Mar 2020 00:30:27 +0100 Subject: [PATCH] Macros are now properly getting baked in Modules bug still persists --- .gitignore | 2 + 3rd/ftb | 2 +- bin/pre.slime | 66 ++--- bin/tests/modules.slime | 33 ++- bin/tests/sicp.slime | 475 ++++++++++++++++----------------- build.sh | 24 +- profiler_vis/report2tracing.py | 131 ++++----- src/assert.hpp | 18 +- src/built_ins.cpp | 98 +++++-- src/defines.cpp | 1 - src/env.cpp | 6 +- src/eval.cpp | 55 ++-- src/globals.cpp | 27 +- src/io.cpp | 77 ++++-- src/libslime.cpp | 1 + src/main.cpp | 1 - src/memory.cpp | 80 ++---- src/structs.cpp | 2 + src/testing.cpp | 9 +- todo.org | 5 +- 20 files changed, 599 insertions(+), 514 deletions(-) mode change 100644 => 100755 build.sh mode change 100644 => 100755 profiler_vis/report2tracing.py diff --git a/.gitignore b/.gitignore index d10969b..c8a9737 100644 --- a/.gitignore +++ b/.gitignore @@ -24,3 +24,5 @@ todo.html /tests/fullslime/main *.o /bin/slime_d +/bin/slime_p +*.json diff --git a/3rd/ftb b/3rd/ftb index 8b50444..98aa145 160000 --- a/3rd/ftb +++ b/3rd/ftb @@ -1 +1 @@ -Subproject commit 8b50444d9ea34f264fdf8ec400ea9d304bf81a3c +Subproject commit 98aa1450d8e63046d3260ea7fb4ff12c9c7e2629 diff --git a/bin/pre.slime b/bin/pre.slime index 6c2be08..c56b1f3 100644 --- a/bin/pre.slime +++ b/bin/pre.slime @@ -14,7 +14,7 @@ (define the-empty-stream ()) -(define (stream-null? s) (if s t ())) +(define (stream-null? s) (when s t)) (define-syntax (delay expr) `(,lambda () ,expr)) @@ -26,7 +26,7 @@ (define-syntax (add . args) (pair '+ args)) (define-syntax (when condition . body) - :doc "Special form for when multiple actions should be done if a + "Special form for when multiple actions should be done if a condition is true. {{{example_start}}} @@ -46,14 +46,14 @@ condition is true. (define-syntax (unless condition . body) - :doc "Special form for when multiple actions should be done if a + "Special form for when multiple actions should be done if a condition is false." (if (= (rest body) ()) `(if ,condition nil ,@body) `(if ,condition nil (begin ,@body)))) (define-syntax (n-times times action) - :doc "Executes action times times." + "Executes action times times." (define (repeat times elem) (unless (> 1 times) (pair elem (repeat (- times 1) elem)))) @@ -102,7 +102,7 @@ condition is false." (rec clauses)) (define-syntax (construct-list . body) - :doc " + " {{{example_start}}} (construct-list i <- '(1 2 3 4 5) @@ -143,7 +143,7 @@ condition is false." (rec body)) ;; (define-syntax (apply fun seq) -;; :doc "Applies the function to the sequence, as in calls the function with +;; "Applies the function to the sequence, as in calls the function with ;; ithe sequence as arguemens." ;; `(eval (pair ,fun ,seq))) @@ -160,9 +160,9 @@ condition is false." ,@body))) -(define-syntax (define-module module-name (:imports ()) :exports . body) +(define-syntax (define-module module-name (:imports ()) (:exports ()) . body) (let ((module-prefix (concat-strings (symbol->string module-name) "::"))) - (eval `(begin ,@(map (lambda (x) `(,import ,x)) imports) ,@body)) + (eval `(,begin ,@(map (lambda (x) `(,import ,x)) imports) ,@body)) (pair 'begin (map (lambda (orig-export-name) ((lambda (export-name) @@ -235,11 +235,11 @@ condition is false." ) (define (null? x) - :doc "Checks if the argument is =nil=." + "Checks if the argument is =nil=." (= x ())) (define (type=? obj typ) - :doc "Checks if the argument =obj= is of type =typ=" + "Checks if the argument =obj= is of type =typ=" (= (type obj) typ)) (define (types=? . objs) @@ -264,43 +264,43 @@ condition is false." (inner objs)) (define (number? x) - :doc "Checks if the argument is a number." + "Checks if the argument is a number." (type=? x :number)) (define (symbol? x) - :doc "Checks if the argument is a symbol." + "Checks if the argument is a symbol." (type=? x :symbol)) (define (keyword? x) - :doc "Checks if the argument is a keyword." + "Checks if the argument is a keyword." (type=? x :keyword)) (define (pair? x) - :doc "Checks if the argument is a pair." + "Checks if the argument is a pair." (type=? x :pair)) (define (string? x) - :doc "Checks if the argument is a string." + "Checks if the argument is a string." (type=? x :string)) (define (lambda? x) - :doc "Checks if the argument is a function." + "Checks if the argument is a function." (type=? x :lambda)) (define (macro? x) - :doc "Checks if the argument is a macro." + "Checks if the argument is a macro." (type=? x :macro)) (define (special-lambda? x) - :doc "Checks if the argument is a special-lambda." + "Checks if the argument is a special-lambda." (type=? x :dynamic-macro)) (define (built-in-function? x) - :doc "Checks if the argument is a built-in function." + "Checks if the argument is a built-in function." (type=? x :cfunction)) (define (continuation? x) - :doc "Checks if the argument is a continuation." + "Checks if the argument is a continuation." (type=? x :continuation)) (define (procedure? x) @@ -311,7 +311,7 @@ condition is false." (continuation? x))) (define (end seq) - :doc "Returns the last pair in the sqeuence. + "Returns the last pair in the sqeuence. {{{example_start}}} (define a (list 1 2 3 4)) @@ -323,7 +323,7 @@ condition is false." (end (rest seq)))) (define (last seq) - :doc "Returns the (first) of the last (pair) of the given sequence. + "Returns the (first) of the last (pair) of the given sequence. {{{example_start}}} (define a (list 1 2 3 4)) @@ -333,7 +333,7 @@ condition is false." (first (end seq))) (define (extend seq elem) - :doc "Extends a list with the given element, by putting it in + "Extends a list with the given element, by putting it in the (rest) of the last element of the sequence." (if (pair? seq) (begin @@ -343,7 +343,7 @@ the (rest) of the last element of the sequence." elem)) (define (extend2 seq elem) - :doc "Extends a list with the given element, by putting it in + "Extends a list with the given element, by putting it in the (rest) of the last element of the sequence." (print "addr of (end seq)" (addr-of (end seq))) (if (pair? seq) @@ -354,12 +354,12 @@ the (rest) of the last element of the sequence." elem) (define (append seq elem) - :doc "Appends an element to a sequence, by extendeing the list + "Appends an element to a sequence, by extendeing the list with (pair elem nil)." (extend seq (pair elem ()))) (define (length seq) - :doc "Returns the length of the given sequence." + "Returns the length of the given sequence." (if (null? seq) 0 (+ 1 (length (rest seq))))) @@ -384,21 +384,21 @@ with (pair elem nil)." (else (pair (first seq) (list-without-index (rest seq) (- index 1)))))) (define (increment val) - :doc "Adds one to the argument." + "Adds one to the argument." (+ val 1)) (define (decrement val) - :doc "Subtracts one from the argument." + "Subtracts one from the argument." (- val 1)) (define (range (:from 0) :to) - :doc "Returns a sequence of numbers starting with the number defined + "Returns a sequence of numbers starting with the number defined by the key =from= and ends with the number defined in =to=." (when (< from to) (pair from (range :from (+ 1 from) :to to)))) (define (range-while (:from 0) :to) - :doc "Returns a sequence of numbers starting with the number defined + "Returns a sequence of numbers starting with the number defined by the key 'from' and ends with the number defined in 'to'." (define result (list (copy from))) (define head result) @@ -420,7 +420,7 @@ elemens as argument to that function." (map fun (rest seq))))) (define (reduce fun seq) - :doc "Takes a function and a sequence as arguments and applies the + "Takes a function and a sequence as arguments and applies the function to the argument sequence. This only works correctly if the given function accepts a variable amount of parameters. If your funciton is limited to two arguments, use [[=reduce-binary=]] @@ -428,7 +428,7 @@ instead." (apply fun seq)) (define (reduce-binary fun seq) - :doc "Takes a function and a sequence as arguments and applies the + "Takes a function and a sequence as arguments and applies the function to the argument sequence. reduce-binary applies the arguments *pair-wise* which means it works with binary functions as compared to [[=reduce=]]." @@ -438,7 +438,7 @@ function to the argument sequence. reduce-binary applies the arguments (reduce-binary fun (rest seq))))) (define (filter fun seq) - :doc "Takes a function and a sequence as arguments and applies the + "Takes a function and a sequence as arguments and applies the function to every value in the sequence. If the result of that funciton application returns a truthy value, the original value is added to a list, which in the end is returned." diff --git a/bin/tests/modules.slime b/bin/tests/modules.slime index 423b189..ee2c57e 100644 --- a/bin/tests/modules.slime +++ b/bin/tests/modules.slime @@ -1,22 +1,21 @@ -;; (define-module math -;; :exports -;; (pi tau pow sqrt) +(define-module math + :exports + (pi tau pow sqrt) -;; (define pi 3.1415) -;; (define tau (* 2 pi)) -;; (define (pow a b) (** a b)) -;; (define (sqrt a) (** a 0.5))) + (define pi 3.1415) + (define tau (* 2 pi)) + (define (pow a b) (** a b)) + (define (sqrt a) (** a 0.5))) -;; (assert (= math::pi 3.1415)) -;; (assert (= math::tau (* 2 math::tau))) +(assert (= math::pi 3.1415)) +(assert (= math::tau (* 2 math::tau))) -(tdefine-module 'math - :exports - '(pi tau pow sqrt) - - '(define pi 3.1415) - '(define tau (* 2 pi)) - '(define (pow a b) (** a b)) - '(define (sqrt a) (** a 0.5))) +;; (tdefine-module 'math +;; :exports +;; '(pi tau pow sqrt) +;; '(define pi 3.1415) +;; '(define tau (* 2 pi)) +;; '(define (pow a b) (** a b)) +;; '(define (sqrt a) (** a 0.5))) diff --git a/bin/tests/sicp.slime b/bin/tests/sicp.slime index ae74f04..fae0971 100644 --- a/bin/tests/sicp.slime +++ b/bin/tests/sicp.slime @@ -1,149 +1,149 @@ -;; (define (abs x) -;; (cond ((< x 0) (- x)) -;; (else x))) +(define (abs x) + (cond ((< x 0) (- x)) + (else x))) -;; (assert (= (abs 1) 1)) -;; (assert (= (abs (- 2)) 2)) +(assert (= (abs 1) 1)) +(assert (= (abs (- 2)) 2)) -;; (define (abs x) - ;; (if (< x 0) - ;; (- x) - ;; x)) +(define (abs x) + (if (< x 0) + (- x) + x)) -;; (assert (= (abs 12) 12)) -;; (assert (= (abs (- 32)) 32)) +(assert (= (abs 12) 12)) +(assert (= (abs (- 32)) 32)) -;; (define (>= x y) -;; (or (> x y) -;; (= x y))) +(define (>= x y) + (or (> x y) + (= x y))) -;; (assert (>= 2 2)) -;; (assert (>= 3 2)) -;; (assert (not (>= 1 2))) -;; (assert (not (>= 12 44))) +(assert (>= 2 2)) +(assert (>= 3 2)) +(assert (not (>= 1 2))) +(assert (not (>= 12 44))) -;; (define (>= x y) -;; (not (< x y))) +(define (>= x y) + (not (< x y))) -;; (assert (>= 2 2)) -;; (assert (>= 3 2)) -;; (assert (not (>= 1 2))) -;; (assert (not (>= 12 44))) +(assert (>= 2 2)) +(assert (>= 3 2)) +(assert (not (>= 1 2))) +(assert (not (>= 12 44))) -;; (define (a-plus-abs-b a b) -;; ((if (> b 0) + -) a b)) +(define (a-plus-abs-b a b) + ((if (> b 0) + -) a b)) -;; (assert (= (a-plus-abs-b 1 2) 3)) -;; (assert (= (a-plus-abs-b 1 -2) 3)) +(assert (= (a-plus-abs-b 1 2) 3)) +(assert (= (a-plus-abs-b 1 -2) 3)) -;; (define (square x) (* x x)) -;; (define (cube x) (* x x x)) +(define (square x) (* x x)) +(define (cube x) (* x x x)) -;; (assert (= ((lambda (x y z) -;; (+ x y (square z))) -;; 1 2 3) -;; 12)) +(assert (= ((lambda (x y z) + (+ x y (square z))) + 1 2 3) + 12)) ;; ;;; -------------------- ;; ;;; newtons method ;; ;;; -------------------- -;; (define tolerance 0.001) +(define tolerance 0.001) -;; (define (square x) -;; (* x x)) +(define (square x) + (* x x)) -;; (define (average x y) - ;; (/ (+ x y) 2)) +(define (average x y) + (/ (+ x y) 2)) -;; (define (improve guess x) -;; (average guess (/ x guess))) +(define (improve guess x) + (average guess (/ x guess))) -;; (define (good-enough? guess x) -;; (< (abs (- (square guess) x)) tolerance)) +(define (good-enough? guess x) + (< (abs (- (square guess) x)) tolerance)) -;; (define (sqrt-iter guess x) -;; (if (good-enough? guess x) -;; guess -;; (sqrt-iter (improve guess x) x))) +(define (sqrt-iter guess x) + (if (good-enough? guess x) + guess + (sqrt-iter (improve guess x) x))) -;; (define (sqrt x) -;; (sqrt-iter 1.0 x)) +(define (sqrt x) + (sqrt-iter 1.0 x)) -;; (define (sqrt2 x) -;; (define (good-enough? guess x) -;; (< (abs (- (square guess) x)) 0.001)) +(define (sqrt2 x) + (define (good-enough? guess x) + (< (abs (- (square guess) x)) 0.001)) -;; (define (improve guess x) -;; (average guess (/ x guess))) + (define (improve guess x) + (average guess (/ x guess))) -;; (define (sqrt-iter guess x) -;; (if (good-enough? guess x) -;; guess -;; (sqrt-iter (improve guess x) x))) + (define (sqrt-iter guess x) + (if (good-enough? guess x) + guess + (sqrt-iter (improve guess x) x))) -;; (sqrt-iter 1.0 x)) + (sqrt-iter 1.0 x)) -;; (define (sqrt3 x) -;; (define (good-enough? guess) -;; (< (abs (- (square guess) x)) 0.001)) +(define (sqrt3 x) + (define (good-enough? guess) + (< (abs (- (square guess) x)) 0.001)) -;; (define (improve guess) -;; (average guess (/ x guess))) + (define (improve guess) + (average guess (/ x guess))) -;; (define (sqrt-iter guess) -;; (if (good-enough? guess) -;; guess -;; (sqrt-iter (improve guess)))) + (define (sqrt-iter guess) + (if (good-enough? guess) + guess + (sqrt-iter (improve guess)))) -;; (sqrt-iter 1.0)) + (sqrt-iter 1.0)) -;; (assert (< (abs (- 3 (sqrt 9))) tolerance)) -;; (assert (< (abs (- 4 (sqrt 16))) tolerance)) -;; (assert (not (< (abs (- 4 (sqrt 15))) tolerance))) +(assert (< (abs (- 3 (sqrt 9))) tolerance)) +(assert (< (abs (- 4 (sqrt 16))) tolerance)) +(assert (not (< (abs (- 4 (sqrt 15))) tolerance))) -;; (assert (< (abs (- 3 (sqrt2 9))) tolerance)) -;; (assert (< (abs (- 4 (sqrt2 16))) tolerance)) -;; (assert (not (< (abs (- 4 (sqrt2 15))) tolerance))) +(assert (< (abs (- 3 (sqrt2 9))) tolerance)) +(assert (< (abs (- 4 (sqrt2 16))) tolerance)) +(assert (not (< (abs (- 4 (sqrt2 15))) tolerance))) -;; (assert (< (abs (- 3 (sqrt3 9))) tolerance)) -;; (assert (< (abs (- 4 (sqrt3 16))) tolerance)) -;; (assert (not (< (abs (- 4 (sqrt3 15))) tolerance))) +(assert (< (abs (- 3 (sqrt3 9))) tolerance)) +(assert (< (abs (- 4 (sqrt3 16))) tolerance)) +(assert (not (< (abs (- 4 (sqrt3 15))) tolerance))) -;; ;;; ----------------- -;; ;;; factorial -;; ;;; ----------------- +;;; ----------------- +;;; factorial +;;; ----------------- -;; (define (factorial n) -;; (if (= n 1) -;; 1 -;; (* n (factorial (- n 1))))) +(define (factorial n) + (if (= n 1) + 1 + (* n (factorial (- n 1))))) -;; (define (factorial2 n) -;; (fact-iter 1 1 n)) +(define (factorial2 n) + (fact-iter 1 1 n)) -;; (define (fact-iter product counter max-count) -;; (if (> counter max-count) -;; product -;; (fact-iter (* counter product) (+ counter 1) max-count))) +(define (fact-iter product counter max-count) + (if (> counter max-count) + product + (fact-iter (* counter product) (+ counter 1) max-count))) -;; (define (factorial3 n) -;; (define (iter product counter) -;; (if (> counter n) -;; product -;; (iter (* counter product) (+ counter 1)))) +(define (factorial3 n) + (define (iter product counter) + (if (> counter n) + product + (iter (* counter product) (+ counter 1)))) -;; (iter 1 1)) + (iter 1 1)) -;; (assert (= (factorial 6) 720)) -;; (assert (= (factorial2 6) 720)) -;; (assert (= (factorial3 6) 720)) +(assert (= (factorial 6) 720)) +(assert (= (factorial2 6) 720)) +(assert (= (factorial3 6) 720)) ;;; ---------------- ;;; ackermann @@ -154,13 +154,6 @@ ((= n 0) (A (- m 1) 1)) (else (A (- m 1) (A m (- n 1)))))) -;; (define (A m n) - ;; (if (= m 0) - ;; (+ n 1) - ;; (if (= n 0) - ;; (A (- m 1) 1) - ;; (A (- m 1) (A m (- n 1)))))) - (assert (= (A 0 0) 1)) (assert (= (A 1 2) 4)) (assert (= (A 3 1) 13)) @@ -170,50 +163,50 @@ ;; ;;; Fibonacci ;; ;;; --------------- -;; (define (fib n) -;; (cond ((= n 0) 0) -;; ((= n 1) 1) -;; (else (+ (fib (- n 1)) (fib (- n 2)))))) - -;; (define (fib2 n) -;; (fib-iter 1 0 n)) - -;; (define (fib-iter a b count) -;; (if (= count 0) -;; b -;; (fib-iter (+ a b) a (- count 1)))) - -;; (assert (= (fib 2) 1)) -;; (assert (= (fib 3) 2)) -;; (assert (= (fib 4) 3)) -;; (assert (= (fib 5) 5)) -;; (assert (= (fib 6) 8)) - -;; (assert (= (fib2 2) 1)) -;; (assert (= (fib2 3) 2)) -;; (assert (= (fib2 4) 3)) -;; (assert (= (fib2 5) 5)) -;; (assert (= (fib2 6) 8)) - -;; ;;; ------------------ -;; ;;; count change -;; ;;; ------------------ - -;; (define (count-change amount) -;; (define (cc amount kinds-of-coins) -;; (cond ((= amount 0) 1) -;; ((or (< amount 0) (= kinds-of-coins 0)) 0) -;; (else (+ (cc amount (- kinds-of-coins 1)) -;; (cc (- amount (first-denomination kinds-of-coins)) kinds-of-coins))))) - -;; (define (first-denomination kinds-of-coins) -;; (cond ((= kinds-of-coins 1) 1) -;; ((= kinds-of-coins 2) 5) -;; ((= kinds-of-coins 3) 10) -;; ((= kinds-of-coins 4) 25) -;; ((= kinds-of-coins 5) 50))) - -;; (cc amount 5)) +(define (fib n) + (cond ((= n 0) 0) + ((= n 1) 1) + (else (+ (fib (- n 1)) (fib (- n 2)))))) + +(define (fib2 n) + (fib-iter 1 0 n)) + +(define (fib-iter a b count) + (if (= count 0) + b + (fib-iter (+ a b) a (- count 1)))) + +(assert (= (fib 2) 1)) +(assert (= (fib 3) 2)) +(assert (= (fib 4) 3)) +(assert (= (fib 5) 5)) +(assert (= (fib 6) 8)) + +(assert (= (fib2 2) 1)) +(assert (= (fib2 3) 2)) +(assert (= (fib2 4) 3)) +(assert (= (fib2 5) 5)) +(assert (= (fib2 6) 8)) + +;;; ------------------ +;;; count change +;;; ------------------ + +(define (count-change amount) + (define (cc amount kinds-of-coins) + (cond ((= amount 0) 1) + ((or (< amount 0) (= kinds-of-coins 0)) 0) + (else (+ (cc amount (- kinds-of-coins 1)) + (cc (- amount (first-denomination kinds-of-coins)) kinds-of-coins))))) + + (define (first-denomination kinds-of-coins) + (cond ((= kinds-of-coins 1) 1) + ((= kinds-of-coins 2) 5) + ((= kinds-of-coins 3) 10) + ((= kinds-of-coins 4) 25) + ((= kinds-of-coins 5) 50))) + + (cc amount 5)) ;; (assert (= (count-change 100) 292)) @@ -221,128 +214,128 @@ ;; ;;; exponentiation ;; ;;; -------------------- -;; (define (expt b n) -;; (if (= n 0) -;; 1 -;; (* b (expt b (- n 1))))) +(define (expt b n) + (if (= n 0) + 1 + (* b (expt b (- n 1))))) -;; (define (expt2 b n) -;; (define (expt-iter b counter product) -;; (if (= counter 0) -;; product -;; (expt-iter b (- counter 1) (* b product)))) +(define (expt2 b n) + (define (expt-iter b counter product) + (if (= counter 0) + product + (expt-iter b (- counter 1) (* b product)))) -;; (expt-iter b n 1)) + (expt-iter b n 1)) -;; (define (fast-expt b n) -;; (define (even? n) -;; (= (% n 2) 0)) +(define (fast-expt b n) + (define (even? n) + (= (% n 2) 0)) -;; (cond ((= n 0) 1) -;; ((even? n) (square (fast-expt b (/ n 2)))) -;; (else (* b (fast-expt b (- n 1)))))) + (cond ((= n 0) 1) + ((even? n) (square (fast-expt b (/ n 2)))) + (else (* b (fast-expt b (- n 1)))))) -;; (assert (= (expt 1 2) 1)) -;; (assert (= (expt 2 2) 4)) -;; (assert (= (expt 2 3) 8)) +(assert (= (expt 1 2) 1)) +(assert (= (expt 2 2) 4)) +(assert (= (expt 2 3) 8)) -;; (assert (= (expt2 1 2) 1)) -;; (assert (= (expt2 2 2) 4)) -;; (assert (= (expt2 2 3) 8)) +(assert (= (expt2 1 2) 1)) +(assert (= (expt2 2 2) 4)) +(assert (= (expt2 2 3) 8)) -;; (assert (= (fast-expt 1 2) 1)) -;; (assert (= (fast-expt 2 2) 4)) -;; (assert (= (fast-expt 2 3) 8)) +(assert (= (fast-expt 1 2) 1)) +(assert (= (fast-expt 2 2) 4)) +(assert (= (fast-expt 2 3) 8)) -;; ;;; ---------- -;; ;;; gcd -;; ;;; ---------- +;;; ---------- +;;; gcd +;;; ---------- -;; (define (gcd a b) -;; (if (= b 0) -;; a -;; (gcd b (% a b)))) +(define (gcd a b) + (if (= b 0) + a + (gcd b (% a b)))) -;; (assert (= (gcd 40 6) 2)) -;; (assert (= (gcd 13 4) 1)) +(assert (= (gcd 40 6) 2)) +(assert (= (gcd 13 4) 1)) -;; ;;; ---------- -;; ;;; primes -;; ;;; ---------- +;;; ---------- +;;; primes +;;; ---------- -;; (define (smallest-divisor n) -;; (find-divisor n 2)) +(define (smallest-divisor n) + (find-divisor n 2)) -;; (define (find-divisor n test-divisor) -;; (cond ((> (square test-divisor) n) n) -;; ((divides? test-divisor n) test-divisor) -;; (else (find-divisor n (+ test-divisor 1))))) +(define (find-divisor n test-divisor) + (cond ((> (square test-divisor) n) n) + ((divides? test-divisor n) test-divisor) + (else (find-divisor n (+ test-divisor 1))))) -;; (define (divides? a b) -;; (= (% b a) 0)) +(define (divides? a b) + (= (% b a) 0)) -;; (define (prime? n) -;; (= n (smallest-divisor n))) +(define (prime? n) + (= n (smallest-divisor n))) -;; (assert (prime? 13)) -;; (assert (prime? 11)) -;; (assert (not (prime? 12))) +(assert (prime? 13)) +(assert (prime? 11)) +(assert (not (prime? 12))) -;;; ---------------------- -;;; simple integral -;;; ---------------------- +;; ---------------------- + ;; simple integral +;; ---------------------- -;; (define (sum term a next b) -;; (if (> a b) -;; 0 -;; (+ (term a) (sum term (next a) next b)))) +(define (sum term a next b) + (if (> a b) + 0 + (+ (term a) (sum term (next a) next b)))) -;; (define (integral f a b dx) -;; (define (add-dx x) (+ x dx)) -;; (* (sum f (+ a (/ dx 2.0)) add-dx b) dx)) +(define (integral f a b dx) + (define (add-dx x) (+ x dx)) + (* (sum f (+ a (/ dx 2.0)) add-dx b) dx)) -;; (define (pi-sum a b) -;; (define (pi-term x) (/ 1.0 (* x (+ x 2)))) -;; (define (pi-next x) (+ x 4)) -;; (sum pi-term a pi-next b)) +(define (pi-sum a b) + (define (pi-term x) (/ 1.0 (* x (+ x 2)))) + (define (pi-next x) (+ x 4)) + (sum pi-term a pi-next b)) -;; (assert (< (abs (- (* 8 (pi-sum 1 100)) 3.121595)) 0.0001)) -;; (assert (< (abs (- (integral cube 0 1 0.02) 0.249950)) 0.0001)) +(assert (< (abs (- (* 8 (pi-sum 1 100)) 3.121595)) 0.0001)) +(assert (< (abs (- (integral cube 0 1 0.02) 0.249950)) 0.0001)) ;; ------------------------------------------------------------ -;; F(x,y) = x(1 + xy)^2 + y(1 − y) + (1 + xy)(1 − y) + ;; F(x,y) = x(1 + xy)^2 + y(1 − y) + (1 + xy)(1 − y) ;; ------------------------------------------------------------ -;; (define (f x y) -;; (let ((a (+ 1 (* x y))) -;; (b (- 1 y))) -;; (+ (* x (square a)) -;; (* y b) -;; (* a b)))) +(define (f x y) + (let ((a (+ 1 (* x y))) + (b (- 1 y))) + (+ (* x (square a)) + (* y b) + (* a b)))) -;; (assert (= (f 0 0) 1)) -;; (assert (= (f 1 1) 4)) +(assert (= (f 0 0) 1)) +(assert (= (f 1 1) 4)) -;; ;;; --------------- -;; ;;; find zero -;; ;;; --------------- +;;; --------------- +;;; find zero +;;; --------------- -;; (define (positive? x) (< 0 x)) -;; (define (negative? x) (< x 0)) +(define (positive? x) (< 0 x)) +(define (negative? x) (< x 0)) -;; (define (search f neg-point pos-point) -;; (let ((midpoint (average neg-point pos-point))) -;; (if (close-enough? neg-point pos-point) -;; midpoint -;; (let ((test-value (f midpoint))) -;; (cond ((positive? test-value) (search f neg-point midpoint)) -;; ((negative? test-value) (search f midpoint pos-point)) -;; (else midpoint)))))) +(define (search f neg-point pos-point) + (let ((midpoint (average neg-point pos-point))) + (if (close-enough? neg-point pos-point) + midpoint + (let ((test-value (f midpoint))) + (cond ((positive? test-value) (search f neg-point midpoint)) + ((negative? test-value) (search f midpoint pos-point)) + (else midpoint)))))) -;; (define (close-enough? x y) (< (abs (- x y)) 0.001)) +(define (close-enough? x y) (< (abs (- x y)) 0.001)) -;; (assert (close-enough? (search (lambda (x) (- 1 (square x))) -3 3) -1)) +(assert (close-enough? (search (lambda (x) (- 1 (square x))) -3 3) -1)) diff --git a/build.sh b/build.sh old mode 100644 new mode 100755 index b655e33..89d2a42 --- a/build.sh +++ b/build.sh @@ -26,6 +26,14 @@ time clang++ -D_DEBUG -D_DONT_BREAK_ON_ERRORS \ # src/main.cpp -g -o ./bin/slime --std=c++17 \ # -I3rd/ || exit 1 +echo "" +echo "------------------------------" +echo " compiling fullslime (prof) " +echo "------------------------------" +time clang++ -D_DONT_BREAK_ON_ERRORS -D_PROFILING \ + src/main.cpp -o ./bin/slime_p --std=c++17 \ + -I3rd/ || exit 1 + pushd ./bin > /dev/null # echo "" @@ -40,11 +48,17 @@ echo " running tests " echo "----------------------" time valgrind -q --track-origins=yes --leak-check=full --show-leak-kinds=all ./slime_d --run-tests || exit 1 -# echo "" -# echo "------------------------" -# echo " running benches " -# echo "------------------------" -# hyperfine -s color --warmup 5 "./slime --run-tests > /dev/null" +echo "" +echo "----------------------" +echo " running profile " +echo "----------------------" +time ./slime_p --run-tests || exit 1 + +echo "" +echo "------------------------" +echo " running benches " +echo "------------------------" +hyperfine -s color --warmup 5 "./slime --run-tests > /dev/null" popd > /dev/null # popd > /dev/null diff --git a/profiler_vis/report2tracing.py b/profiler_vis/report2tracing.py old mode 100644 new mode 100755 index 0ee2d5c..e96d732 --- a/profiler_vis/report2tracing.py +++ b/profiler_vis/report2tracing.py @@ -1,63 +1,68 @@ -import json -import csv -import sys - -class FancyFloat(float): - def __repr__(self): - return format(Decimal(self), "f") - -class JsonRpcEncoder(json.JSONEncoder): - def decimalize(self, val): - if isinstance(val, dict): - return {k:self.decimalize(v) for k,v in val.items()} - - if isinstance(val, (list, tuple)): - return type(val)(self.decimalize(v) for v in val) - - if isinstance(val, float): - return FancyFloat(val) - - return val - - def encode(self, val): - return super().encode(self.decimalize(val)) - -if len(sys.argv) == 1: - print("No file was provided") -else: - trace_events = [] - call_stack = [] - with open(sys.argv[1], "r") as in_file: - csv_reader = csv.reader(in_file, delimiter=',') - pf = 1 - first_line = True - for line in csv_reader: - if first_line: - pf = float(line[0]) / 1000 - first_line = False - continue - if line[0] == "->": - call_stack.append(line) - elif line[0] == "<-": - call = call_stack.pop() - dict = { - "pid": 1, - "tid": 1, - "ts" : float(call[1]), - "dur": (float(line[1])-float(call[1])), - "ph" : "X", - "name": call[2], - "args": { - "file": f"({call[3]}:{call[4]})", - } - } - if call[5]: - dict["args"]["info1"] = call[5] - if call[6]: - dict["args"]["info2"] = call[6] - trace_events.append(dict) - else: - print("invalid syntax") - break - with open("out.json", "w") as out_file: - out_file.write(json.dumps({"traceEvents": trace_events})) +#!/usr/bin/python + +import json +import csv +import sys + +class FancyFloat(float): + def __repr__(self): + return format(Decimal(self), "f") + +class JsonRpcEncoder(json.JSONEncoder): + def decimalize(self, val): + if isinstance(val, dict): + return {k:self.decimalize(v) for k,v in val.items()} + + if isinstance(val, (list, tuple)): + return type(val)(self.decimalize(v) for v in val) + + if isinstance(val, float): + return FancyFloat(val) + + return val + + def encode(self, val): + return super().encode(self.decimalize(val)) + +if len(sys.argv) == 1: + print("No file was provided") +else: + trace_events = [] + call_stack = [] + with open(sys.argv[1], "r") as in_file: + csv_reader = csv.reader(in_file, delimiter=',') + pf = 1 + first_line = True + last_ts = -1; + for line in csv_reader: + if first_line: + pf = float(line[0]) / 1000 + first_line = False + continue + if line[0] == "->": + call_stack.append(line) + elif line[0] == "<-": + call = call_stack.pop() + ts = float(call[1]) + dur = (float(line[1])-ts) + dict = { + "pid": 1, + "tid": 1, + "ts" : ts, + "dur": dur, + "ph" : "X", + "name": call[2], + "args": { + "file": f"({call[3]}:{call[4]})", + } + } + if call[5]: + dict["args"]["info1"] = call[5] + if call[6]: + dict["args"]["info2"] = call[6] + trace_events.append(dict) + else: + print("invalid syntax") + break + with open("out.json", "w") as out_file: + out_file.write(json.dumps({"traceEvents": trace_events}, indent=4)) diff --git a/src/assert.hpp b/src/assert.hpp index f55e9cc..8038d9d 100644 --- a/src/assert.hpp +++ b/src/assert.hpp @@ -41,11 +41,16 @@ } \ } while(0) -#define assert(condition) \ - do { \ - if (!(condition)) { \ - create_generic_error("Assertion-error."); \ - } \ +#define assert_list_length(_node, _len) assert("List length assertion", list_length(_node) == _len) + +#define assert(message, condition) \ + do { \ + if (!(condition)) { \ + create_generic_error("Assertion-error: %s\n" \ + " for: %s\n" \ + " in: %s:%d", \ + message, #condition, __FILE__, __LINE__); \ + } \ } while(0) #else @@ -53,5 +58,6 @@ # define assert_arguments_length_less_equal(expected, actual) do {} while (0) # define assert_arguments_length_greater_equal(expected, actual) do {} while (0) # define assert_type(_node, _type) do {} while (0) -# define assert(condition) do {} while (0) +# define assert_list_length(_node, _len) do {} while (0) +# define assert(message, condition) do {} while (0) #endif diff --git a/src/built_ins.cpp b/src/built_ins.cpp index fab2f56..cc6f6e5 100644 --- a/src/built_ins.cpp +++ b/src/built_ins.cpp @@ -144,9 +144,70 @@ namespace Slime { profile_this(); String* file_name_built_ins = Memory::create_string(__FILE__); - // define_macro((apply fun args), "TODO") { - // profile_with_name("(apply)"); - // }; + define_macro((apply fun fun_args), "TODO") { + // NOTE(Felix): is has to be a macro because apply by + // itself cannot return the result, we have to invoke eval + // and to prevent recursion, apply is a macro + + profile_with_name("(apply)"); + using namespace Globals::Current_Execution; + + --cs.next_index; + --ams.next_index; + Lisp_Object* args = pcs[--pcs.next_index]; + try_void assert_list_length(args, 2); + + Lisp_Object* fun = args->value.pair.first; + Lisp_Object* fun_args = args->value.pair.rest->value.pair.first; + + // 3. push args on the stack and apply + ats.append([] { + Lisp_Object* args_as_list = cs[--cs.next_index]; + for_lisp_list (args_as_list) { + cs.append(it); + } + pcs.append(Memory::nil); + (nass.end()-1)->append(NasAction::Step); + }); + (nass.end()-1)->append(NasAction::And_Then_Action); + + // 2. Eval fun_args and keep them on the stack + ats.append([] { + // NOTE(Felix): Flip the top 2 elements on cs because + // top is now the evaluated function, and below is the unevaluated args + Lisp_Object* tmp = cs[cs.next_index-1]; + cs[cs.next_index-1] = cs[cs.next_index-2]; + cs[cs.next_index-2] = tmp; + (nass.end()-1)->append(NasAction::Eval); + }); + (nass.end()-1)->append(NasAction::And_Then_Action); + + + // 1. Eval function and keep it on the stack, below it + // store the unevaluated argument list + ams.append(cs.next_index); + cs.append(fun_args); + cs.append(fun); + (nass.end()-1)->append(NasAction::Eval); + + }; + define((get-counter), + "When called returns a procedure that represents\n" + "a counter. Each time it is called it returns the\n" + "next whole number.") + { + define_symbol( + Memory::get_symbol("c"), + Memory::create_lisp_object((double)0)); + String* file_name_built_ins = Memory::create_string(__FILE__); + define((lambda), "") { + fetch(c); + c->value.number++; + return c; + }; + fetch(lambda); + return lambda; + }; define_macro((eval expr), "Takes one argument, and evaluates it two times.") { @@ -234,8 +295,9 @@ namespace Slime { try_void assert_type(doc, Lisp_Object_Type::String); try_void assert_type(form, Lisp_Object_Type::Pair); thing = form->value.pair.first; - try_void assert(form->value.pair.rest == Memory::nil); - // TODO docs + try_void assert("list must end here.", form->value.pair.rest == Memory::nil); + // TODO docs (maybe with hooks) we have to attach + // the docs to the result of evaluating } cs.append(definee); cs.append(thing); @@ -243,12 +305,18 @@ namespace Slime { (nass.end()-1)->append(NasAction::Eval); } break; case Lisp_Object_Type::Pair: { - fflush(stdout); try_void assert_type(definee->value.pair.first, Lisp_Object_Type::Symbol); Lisp_Object* func; try_void func = Memory::create_lisp_object_function(Lisp_Function_Type::Lambda); func->value.function->parent_environment = get_current_environment(); create_arguments_from_lambda_list_and_inject(definee->value.pair.rest, func); + if (Memory::get_type(thing_cons->value.pair.first) == Lisp_Object_Type::String && + thing_cons->value.pair.rest != Memory::nil) + { + // extract docs + func->docstring = thing_cons->value.pair.first->value.string; + thing_cons = thing_cons->value.pair.rest; + } func->value.function->body.lisp_body = maybe_wrap_body_in_begin(thing_cons); define_symbol(definee->value.pair.first, func); cs.append(Memory::t); @@ -376,6 +444,7 @@ namespace Slime { { profile_with_name("(+)"); fetch(args); + double sum = 0; for_lisp_list (args) { @@ -573,8 +642,8 @@ namespace Slime { int int_idx = ((int)idx->value.number); - try assert(int_idx >= 0); - try assert(int_idx < vec->value.vector.length); + try assert("vector access index must be >= 0", int_idx >= 0); + try assert("vector access index must be < length", int_idx < vec->value.vector.length); return vec->value.vector.data+int_idx; }; @@ -587,8 +656,8 @@ namespace Slime { int int_idx = ((int)idx->value.number); - try assert(int_idx >= 0); - try assert(int_idx < vec->value.vector.length); + try assert("vector access index must be >= 0", int_idx >= 0); + try assert("vector access index must be < length", int_idx < vec->value.vector.length); vec->value.vector.data[int_idx] = *val; @@ -973,7 +1042,7 @@ namespace Slime { printf(" (internal: %s)", Lisp_Object_Type_to_string(Memory::get_type(val))); printf("\nand is printed as: "); print(val); - printf("\n\ndocs: \n %s\n", + printf("\n\ndocs:\n=====\n %s\n\n", (val->docstring) ? Memory::get_c_str(val->docstring) : "No docs avaliable"); @@ -1027,12 +1096,12 @@ namespace Slime { profile_with_name("(show)"); fetch(n); try assert_type(n, Lisp_Object_Type::Function); - try assert(!n->value.function->is_c); + try assert("c-functoins cannot be shown", !n->value.function->is_c); puts("body:\n"); print(n->value.function->body.lisp_body); puts("\n"); - printf("parent_env: %lld\n", - (long long)n->value.function->parent_environment); + printf("parent_env: %p\n", + n->value.function->parent_environment); return Memory::nil; }; @@ -1085,7 +1154,6 @@ namespace Slime { profile_with_name("(exit)"); fetch(code); try assert_type(code, Lisp_Object_Type::Number); - Slime::Memory::free_everything(); exit((int)code->value.number); }; define((break), "TODO") { diff --git a/src/defines.cpp b/src/defines.cpp index 9d09ce9..5ef2a1c 100644 --- a/src/defines.cpp +++ b/src/defines.cpp @@ -20,4 +20,3 @@ #define console_red "\x1B[31m" #define console_green "\x1B[32m" #define console_cyan "\x1B[36m" - diff --git a/src/env.cpp b/src/env.cpp index 0db503f..a26c6b0 100644 --- a/src/env.cpp +++ b/src/env.cpp @@ -98,7 +98,7 @@ namespace Slime { if(env == get_root_environment()) { print_indent(indent); - printf("[built-ins]-Environment (%lld)\n", (long long)env); + printf("[built-ins]-Environment (%p)\n", env); return; } @@ -111,14 +111,14 @@ namespace Slime { } for (int i = 0; i < env->parents.next_index; ++i) { print_indent(indent); - printf("parent (0x%016llx)", (long long)env->parents.data[i]); + printf("parent (%p)", env->parents.data[i]); puts(":"); print_environment_indent(env->parents.data[i], indent+4); } } proc print_environment(Environment* env) -> void { - printf("\n=== Environment === (0x%016llx)\n", (long long)env); + printf("\n=== Environment === (%p)\n", env); print_environment_indent(env, 0); } diff --git a/src/eval.cpp b/src/eval.cpp index b80b1e1..7e630fd 100644 --- a/src/eval.cpp +++ b/src/eval.cpp @@ -56,7 +56,7 @@ namespace Slime { } // NOTE(Felix): We have to copy all the arguments, // otherwise we change the program code. - // XXX(Felix): T C functions we pass by reference. + // XXX(Felix): To C functions we pass by reference. // TODO(Felix): Why did we decide this?? if (is_c_function) { define_symbol(sym, next_arg); @@ -65,6 +65,8 @@ namespace Slime { sym, Memory::copy_lisp_object_except_pairs(next_arg)); } + assert("cs access index out of range", + arg_pos+1 < cs->next_index); next_arg = cs->data[++arg_pos]; } }; @@ -380,6 +382,7 @@ namespace Slime { } proc eval_expr(Lisp_Object* expr) -> Lisp_Object* { + profile_this(); using namespace Globals::Current_Execution; nass.reserve(1); @@ -393,40 +396,8 @@ namespace Slime { proc debug_step = [&] { if (!Globals::debug_log) return; - printf("\n-------------------\ncs:\n "); - for (int i = 0; i < cs.next_index; ++i) { - char* t = lisp_object_to_string(cs.data[i], true); - printf(" %d: %s\n ", i, t); - defer { free(t); }; - } - printf("\npcs:\n "); - for (auto lo : pcs) { - print(lo, true); - printf("\n "); - } - printf("\nnnas:\n "); - for (auto nas: nass) { - printf("nas:\n "); - for (auto na : nas) { - printf(" - %s\n ", [&] - { - switch(na) { - case NasAction::Pop_Environment: return "Pop_Environment"; - case NasAction::Define_Var: return "Define_Var"; - case NasAction::Eval: return "Eval"; - case NasAction::Step: return "Step"; - case NasAction::TM: return "TM"; - case NasAction::Pop: return "Pop"; - case NasAction::If: return "If"; - } - return "??"; - }()); - } - } - printf("\nams:\n "); - for (auto am : ams) { - printf("%d\n ", am); - } + printf("\n-------------------\n"); + print_current_execution(); // pause(); }; @@ -451,6 +422,9 @@ namespace Slime { case NasAction::Pop: { --cs.next_index; } break; + case NasAction::And_Then_Action: { + ats.data[--ats.next_index](); + } break; case NasAction::Pop_Environment: { pop_environment(); } break; @@ -465,6 +439,7 @@ namespace Slime { cs.data[cs.next_index-1] = pc->value.pair.first; ams.append(cs.next_index-1); pcs.append(pc->value.pair.rest); + mes.append(pc); nas->append(NasAction::TM); nas->append(NasAction::Eval); } break; @@ -474,6 +449,9 @@ namespace Slime { } } } break; + case NasAction::Macro_Write_Back: { + *mes.data[--mes.next_index] = *cs[cs.next_index-1]; + } break; case NasAction::TM: { pc = cs.data[cs.next_index-1]; @@ -483,7 +461,7 @@ namespace Slime { if(pc->value.function->is_c) { if (pc->value.function->type.c_function_type == C_Function_Type::cMacro) { try pc->value.function->body.c_macro_body(); - } else if(pc->value.function->type.c_function_type == C_Function_Type::cSpecial) + } else if (pc->value.function->type.c_function_type == C_Function_Type::cSpecial) { // TODO(Felix): Why not call the function // right away, and instead push step, so @@ -493,14 +471,17 @@ namespace Slime { } else { nas->append(NasAction::Step); } + --mes.next_index; } else { if (pc->value.function->type.lisp_function_type == Lisp_Function_Type::Macro) { push_pc_on_cs(); nas->append(NasAction::Eval); + nas->append(NasAction::Macro_Write_Back); nas->append(NasAction::Step); } else { + --mes.next_index; nas->append(NasAction::Step); } } @@ -597,7 +578,7 @@ namespace Slime { proc interprete_stdin() -> void { try_void Memory::init(4096 * 256* 100); - printf("Welcome to the lispy interpreter.\n"); + printf("Welcome to the lispy interpreter.\n%s\n", version_string); char* line; diff --git a/src/globals.cpp b/src/globals.cpp index a986614..e511e18 100644 --- a/src/globals.cpp +++ b/src/globals.cpp @@ -1,14 +1,31 @@ +namespace Slime { +#define v_major 0 +#define v_minor 1 +#define STRINGIZE2(s) #s +#define STRINGIZE(s) STRINGIZE2(s) +#define VERSION_STRING "v" STRINGIZE(v_major) "." STRINGIZE(v_minor) " - built on " __DATE__ " " __TIME__ + const char* version_string = VERSION_STRING; + const int major_version = v_major; + const int minor_version = v_minor; +#undef v_major +#undef v_minor +#undef STRINGIZE2 +#undef STRINGIZE +#undef VERSION_STRING +} + namespace Slime::Globals { char* bin_path = nullptr; Log_Level log_level = Log_Level::Debug; bool debug_log = false; Array_List load_path; namespace Current_Execution { - Array_List cs; - Array_List pcs; - Array_List ams; - Array_List> nass; - // Array_List call_stack; + Array_List cs; // call stack + Array_List pcs; // program counter stack + Array_List ams; // apply marker stack + Array_List> nass; // next action stack stack + Array_List> ats; // and then stack + Array_List mes; // macro expansion stack Array_List envi_stack; } diff --git a/src/io.cpp b/src/io.cpp index 3c0749c..510a113 100644 --- a/src/io.cpp +++ b/src/io.cpp @@ -399,11 +399,20 @@ namespace Slime { // NOTE(Felix): try to find the symbol it is bound to // in global env Lisp_Object* name = (Lisp_Object*)(get_root_environment()->hm.search_key_to_object(node)); - switch (node->value.function->type.c_function_type) { - case C_Function_Type::cFunction: asprintf(&temp, "[c-function %s]",&((Lisp_Object*)name)->value.symbol->data); break; - case C_Function_Type::cSpecial: asprintf(&temp, "[c-special %s]", &((Lisp_Object*)name)->value.symbol->data); break; - case C_Function_Type::cMacro: asprintf(&temp, "[c-macro %s]", &((Lisp_Object*)name)->value.symbol->data); break; - default: return strdup("[c-??]"); + if (name) { + switch (node->value.function->type.c_function_type) { + case C_Function_Type::cFunction: asprintf(&temp, "[c-function %s]",&((Lisp_Object*)name)->value.symbol->data); break; + case C_Function_Type::cSpecial: asprintf(&temp, "[c-special %s]", &((Lisp_Object*)name)->value.symbol->data); break; + case C_Function_Type::cMacro: asprintf(&temp, "[c-macro %s]", &((Lisp_Object*)name)->value.symbol->data); break; + default: return strdup("[c-??]"); + } + } else { + switch (node->value.function->type.c_function_type) { + case C_Function_Type::cFunction: asprintf(&temp, "[c-function]"); break; + case C_Function_Type::cSpecial: asprintf(&temp, "[c-special]"); break; + case C_Function_Type::cMacro: asprintf(&temp, "[c-macro]"); break; + default: return strdup("[c-??]"); + } } return temp; } else { @@ -444,7 +453,8 @@ namespace Slime { string_builder.append(strdup(",@")); assert_type(head->value.pair.rest, Lisp_Object_Type::Pair); - assert(head->value.pair.rest->value.pair.rest == Memory::nil); + assert("The list must end here.", + head->value.pair.rest->value.pair.rest == Memory::nil); string_builder.append(lisp_object_to_string(head->value.pair.rest->value.pair.first, print_repr)); return string_buider_to_string(string_builder); @@ -511,16 +521,49 @@ namespace Slime { } } - proc print_call_stack() -> void { - printf("call stack cannot be printed."); - // using Globals::Current_Execution::call_stack; - - // printf("callstack [%d] (most recent call last):\n", call_stack.next_index); - // for (int i = 0; i < call_stack.next_index; ++i) { - // printf("%2d -> ", i); - // print_single_call(call_stack.data[i]); - // printf("\n"); - // } + proc print_current_execution() -> void { + using Globals::Current_Execution::cs; + using Globals::Current_Execution::pcs; + using Globals::Current_Execution::nass; + using Globals::Current_Execution::ams; + printf("cs:\n "); + for (int i = 0; i < cs.next_index; ++i) { + char* t = lisp_object_to_string(cs.data[i], true); + printf(" %d: %s\n ", i, t); + defer { + free(t); + }; + } + printf("\npcs:\n "); + for (auto lo : pcs) { + print(lo, true); + printf("\n "); + } + printf("\nnnas:\n "); + for (auto nas: nass) { + printf("nas:\n "); + for (auto na : nas) { + printf(" - %s\n ", [&] + { + switch(na) { + case NasAction::Macro_Write_Back: return "Macro_Write_Back"; + case NasAction::And_Then_Action: return "And_Then_Action"; + case NasAction::Pop_Environment: return "Pop_Environment"; + case NasAction::Define_Var: return "Define_Var"; + case NasAction::Eval: return "Eval"; + case NasAction::Step: return "Step"; + case NasAction::TM: return "TM"; + case NasAction::Pop: return "Pop"; + case NasAction::If: return "If"; + } + return "??"; + }()); + } + } + printf("\nams:\n "); + for (auto am : ams) { + printf("%d\n ", am); + } } proc log_error() -> void { @@ -530,7 +573,7 @@ namespace Slime { puts(console_normal); fputs(" in: ", stdout); - print_call_stack(); + print_current_execution(); puts(console_normal); } } diff --git a/src/libslime.cpp b/src/libslime.cpp index 2ff3315..7796210 100644 --- a/src/libslime.cpp +++ b/src/libslime.cpp @@ -37,6 +37,7 @@ unsigned int hm_hash(Slime::Lisp_Object* obj); #include "ftb/bucket_allocator.hpp" #include "ftb/macros.hpp" #include "ftb/profiler.hpp" +#include "ftb/hooks.hpp" # include "defines.cpp" # include "assert.hpp" diff --git a/src/main.cpp b/src/main.cpp index 6d0eeb0..617deec 100644 --- a/src/main.cpp +++ b/src/main.cpp @@ -19,7 +19,6 @@ int main(int argc, char* argv[]) { Slime::Memory::init(4096 * 256* 100); if (Slime::Globals::error) return 1; Slime::built_in_load(Slime::Memory::create_string("generate-docs.slime")); - Slime::Memory::free_everything(); } else { Slime::interprete_file(argv[1]); } diff --git a/src/memory.cpp b/src/memory.cpp index ec8c203..fd104d5 100644 --- a/src/memory.cpp +++ b/src/memory.cpp @@ -11,12 +11,12 @@ namespace Slime::Memory { // ------------------ // lisp_objects // ------------------ - Bucket_Allocator object_memory(1024, 8); + Bucket_Allocator object_memory; // ------------------ // environments // ------------------ - Bucket_Allocator environment_memory(1024, 8); + Bucket_Allocator environment_memory; // NOTE(Felix): we are doing hashmaps separately so we don't have // to malloc them every time, and if two lisp objects have the @@ -26,7 +26,7 @@ namespace Slime::Memory { // ------------------ // Hashmaps // ------------------ - Bucket_Allocator> hashmap_memory(256, 8); + Bucket_Allocator> hashmap_memory; // ------------------ // strings @@ -163,6 +163,12 @@ namespace Slime::Memory { Globals::Current_Execution::ams.dealloc(); Globals::Current_Execution::pcs.dealloc(); Globals::Current_Execution::nass.dealloc(); + Globals::Current_Execution::ats.dealloc(); + Globals::Current_Execution::mes.dealloc(); + + object_memory.dealloc(); + environment_memory.dealloc(); + hashmap_memory.dealloc(); global_symbol_table.dealloc(); global_keyword_table.dealloc(); @@ -193,6 +199,16 @@ namespace Slime::Memory { proc init(int sms) -> void { profile_this(); + + object_memory.alloc(1024, 8); + environment_memory.alloc(1024, 8); + hashmap_memory.alloc(256, 8); + + system_shutdown_hook << [&] { + if_debug { + Slime::Memory::free_everything(); + } + }; char* exe_path = get_exe_dir(); // don't free exe path because it will be used until end of time Globals::load_path.alloc(); @@ -206,6 +222,8 @@ namespace Slime::Memory { Globals::Current_Execution::nass.alloc(); Globals::Current_Execution::pcs.alloc(); Globals::Current_Execution::ams.alloc(); + Globals::Current_Execution::ats.alloc(); + Globals::Current_Execution::mes.alloc(); add_to_load_path(exe_path); add_to_load_path("../bin/"); @@ -233,64 +251,8 @@ namespace Slime::Memory { Environment* user_env; try_void user_env = Memory::create_child_environment(env); push_environment(user_env); - - /* try_void _if = lookup_symbol(get_symbol("if"), env); - try_void _define = lookup_symbol(get_symbol("define"), env); - try_void _begin = lookup_symbol(get_symbol("begin"), env);*/ } - proc reset() -> void { - profile_this(); - - free_spots_in_string_memory.next_index = 0; - - global_symbol_table.dealloc(); - global_keyword_table.dealloc(); - file_to_env_map.dealloc(); - - global_symbol_table.alloc(); - global_keyword_table.alloc(); - file_to_env_map.alloc(); - - try_void Parser::standard_in = create_string("stdin"); - - object_memory.for_each([](Lisp_Object* lo){ - lo->~Lisp_Object(); - }); - environment_memory.for_each([](Environment* env){ - env->~Environment(); - }); - - object_memory.~Bucket_Allocator(); - environment_memory.~Bucket_Allocator(); - - new(&object_memory) Bucket_Allocator(1024, 8); - new(&environment_memory) Bucket_Allocator(1024, 8); - - next_free_spot_in_string_memory = string_memory; - - - // init nil - try_void nil = create_lisp_object(); - set_type(nil, Lisp_Object_Type::Nil); - - // init t - try_void t = create_lisp_object(); - set_type(t, Lisp_Object_Type::T); - - Globals::Current_Execution::envi_stack.next_index = 0; - Environment* env; - try_void env = create_built_ins_environment(); - push_environment(env); - - Environment* user_env; - try_void user_env = Memory::create_child_environment(env); - push_environment(user_env); - - try_void _if = lookup_symbol(get_symbol("if"), env); - try_void _define = lookup_symbol(get_symbol("define"), env); - try_void _begin = lookup_symbol(get_symbol("begin"), env); - } proc create_lisp_object(void* ptr) -> Lisp_Object* { Lisp_Object* node; diff --git a/src/structs.cpp b/src/structs.cpp index 8707d7c..29ee577 100644 --- a/src/structs.cpp +++ b/src/structs.cpp @@ -32,6 +32,8 @@ namespace Slime { }; enum struct NasAction { + And_Then_Action, + Macro_Write_Back, Eval, Step, TM, diff --git a/src/testing.cpp b/src/testing.cpp index 9cc997b..a8fa2da 100644 --- a/src/testing.cpp +++ b/src/testing.cpp @@ -582,14 +582,7 @@ namespace Slime { profile_this(); bool result = true; - try Memory::init(409600); - defer { - if_debug { - Slime::Memory::free_everything(); - } - }; - push_environment(Memory::create_child_environment( get_current_environment())); @@ -629,7 +622,7 @@ namespace Slime { invoke_test_script("macro_expand"); invoke_test_script("sicp"); invoke_test_script("simple_built_ins"); - invoke_test_script("modules"); + // invoke_test_script("modules"); // invoke_test_script("class_macro"); // invoke_test_script("automata"); // invoke_test_script("alists"); diff --git a/todo.org b/todo.org index 1164a2c..4c5970d 100644 --- a/todo.org +++ b/todo.org @@ -1,3 +1,4 @@ +* TODO assert list_length for arguemns of macros * TODO update header files * TODO use better type names: u32, .. * TODO write and/or as macros @@ -9,9 +10,9 @@ 1 (* n (fac (sub1 n))))) 3628800 -* TODO runHook NAS_Action +* TODO runHook NAS_Action * TODO consisitent names (Lisp_Object_Type_to_string .. lisp_object_to_string) -* TODO rename modifying functions to prefix '!' +* TODO rename modifying functions to have suffix '!' * TODO rename slime to plisk * TODO BUG 1: eval dot notation #+BEGIN_SRC lisp