-
Notifications
You must be signed in to change notification settings - Fork 23
/
lisp.c
executable file
·4133 lines (3575 loc) · 125 KB
/
lisp.c
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/* Distributed under Mozilla Public Licence 2.0 */
/* https://www.mozilla.org/en-US/MPL/2.0/ */
/* 2016-08-14 (C) Jonas S Karlsson, [email protected] */
/* A mini "lisp machine", main */
// http://stackoverflow.com/questions/3482389/how-many-primitives-does-it-take-to-build-a-lisp-machine-ten-seven-or-five
// in speed it's comparable to compiled LUA
// - simple "readline"
// - maybe 2x as slow
// - handles tail-recursion optimization
// - full closures
// - lexical binding
// RAW C esp8266 - printf("10,000,000 LOOP (100x lua) TIME=%d\r\n", tm); ===> 50ms
// Lua time 100,000 => 2s
// ----------------------
// s=0; for i=1,100000 do s=s+i end; print(s);
// function tail(n, s) if n == 0 then return s else return tail(n-1, s+1); end end print(tail(100000, 0))
// DEFINE(tail, (lambda (n s) (if (eq n 0) s (tail (- n 1) (+ s 1)))));
// princ(evalGC(reads("(tail 100000 0)"), env));
// -----------------------------------------------------------------
// lisp.c (tail 1,000 0)
// all alloc/evalGC gives 5240ms with print
// no print gc => 5040ms
// ==> painful slow!
// NO INT alloc => 4500ms
// needGC() function, block mark => 1070ms
//
// lisp.c (tail 10,000 0)
// => 9380, 9920, 10500
// reuse() looped always from 0, made it round-robin => 3000... 4200... 4000ms!
// mark_deep() + p->index=i ===> 1500-2000ms
// car/cdr macro, on desktop 6.50 -> 4.5s for for 1M loop for esp => 1400-1800
// hardcode primapply 2 parameters => 1100ms
// hardcode primapply 1,2,3,-3 (if),-16 => 860-1100ms
// slot alloc => 590,600 ms
// eq => ==, remove one eval, tag test => 540,550ms
//
// lisp.c (tail 10,000 0)
// now takes 5300ms more or less exactly every time
// 2.5x slower than lua, didn't actually measure actual lua time
// evalGC now lookup vars too => 4780
// bindEvalList (combined evallist + bindList) => 4040ms!
// ... => 4010ms
//
// slight increase if change the MAX_ALLOC to 512 but it keeps 17K free! => 4180ms
// We've slowed down some with adding the evallist/plus/times
// and trace functionality:
// > git checkout f871de73834340edb3fa5b26d49e43e373647f9b
// ./opt
// lisp> (time (fibo 34))
// 3 times, avg = 7015
// NOW
// ./opt
// lisp> (time (fibo 34))
// 3 times, avg = 7671
// 20151121: (time (fibo 24)) (5170 . xxx)
//
// (fibo 24)
// lua: 3s
// esp-lisp: 5s
//
// (fibo 30)
// x61 lisp: 4.920s
// opt: 2.67s
//
// time echo "function fibo(n) if n < 2 then return 1; else return fibo(n-1) + fibo(n-2); end end print(fibo(35)); " | lua
// 14930352, real 0m6.006s, user 0m3.653s
// lua fibo 32
// 3524578, real 0m1.992s, user 0m0.903s
//
// time ./a.out
// 3524578, real 0m19.353s, user 0m12.353s
//
// time ./opt
// 3524578, real 0m3.549s, user 0m2.253s
//
// 2.5x slower than lua interpreting instead of compiling to byte code!!!
//
#include <unistd.h>
#include <ctype.h>
#include <stdarg.h>
#include <string.h>
#include <stdlib.h>
#include <stdio.h>
#include <errno.h>
#include <setjmp.h>
#ifndef UNIX
#include "FreeRTOS.h"
#define LOOP 99999
#define LOOPS "99999"
#define LOOPTAIL "(tail 99999 0)"
// #include "esp/spi.h"
#endif
#ifdef UNIX
#define LOOP 2999999
#define LOOPS "2999999"
#define LOOPTAIL "(tail 2999999 0)"
#endif
// use pointer to store some tag data, use this for exteded types
// last bits (3 as it allocates in at least 8 bytes boundaries):
// ----------
// 000 = heap pointer, generic extended lisp data/struct with tag field - DONE
// 01 = integer << 2 - DONE
// 11 = inline symbol stored inside pointer! - DONE
// 32 bits = 6 chars * 5 bits = 30 bits + 11 or 3*ASCII(7)=28, if shifted
// ....fffff11 : fffff != 11111 means 6 char atom name inline
// 00001111111 : fffff == 11111 means 3 ascii atom name inline (names like "+" "-")
// xxxx1111111 : xxxxx > 0 FREE! FREE! FREE!
// xxx11111111 : 24 bits left!!! == hashsymbol!!!
// TODO: 15 type of "enums" possible each with values of 3*7=21 bits 0-2,097,152
// 21+3 = 24 !!! use for hash syms!!!!
//
// -- byte[8] lispheap[MAX_HEAP]
// 010 = lispheap, cons == 8 bytes, 2 cells - DONE
// 100 = lispheap, symbol == name + primptr, not same as value
// 110 = ??
// 000 HEAP (string, symbol, prim...) - DONE
// 001 INTP 1 - DONE
// 010 CONSP 1 - heap - DONE
// 011 SYMP 1 inline pointer symbol - DONE
// 100 ??? hash symbol ??? ??? array cons???
// 101 INTP 2 - DONE
// 110 PRIMP
// 111 SYMP 2 inline pointer symbol - DONE
//
// ROM storage, issue of serializing atom and be able to execute from ROM symbols cannot change name
// so need "unique" pointer, but since symbols can be determined dynamically we cannot change
// in ROM. Let's say we use 24 bits hash (1M /usr/share/dict/words cause 290 clashes),
// 32-24 = 8 - 3 bits id => 5 (length) of following string/symbol name. len=0 means it's "unique":
// 1. a symbol can be SYMP (ROM/ROM compatible)
// 2. a symbol can be HEAP ALLOC
// 3. a symbol can be hash in ROM string (len < 2^5 = 32)
// 4. a symbol can be hash in RAM
//
// 3 & 4 needs to verify when used???? Hmmmm, harmonize number 2 with 3 & 4
// symbol hashes
// -------------
// (hash, pointer to value, pointer to string)
// (0, 0, 0) end, or use linked list
// linear list: (value, hash, inline string<32), ..., (0000, nil)
// extended cons list: (cons (symbol, value), ...)
// extended env list: next, value, symbol ("cons3")
// extended env list: next, value, hashp/string/value (var sized, "cons3+")
#include "lisp.h"
#include "compat.h"
// forwards
void gc_conses();
int kbhit();
static inline lisp callfunc(lisp f, lisp args, lisp* envp, lisp e, int noeval);
int lispreadchar(char *chp);
PRIM breakpoint();
void error(char* msg);
static inline int tracep(lisp f);
void run(char* s, lisp* envp);
PRIM fundef(lisp f);
PRIM funenv(lisp f);
PRIM funame(lisp f);
lisp* global_envp = NULL;
// big value ok as it's used mostly no inside evaluation but outside at toplevel
#define READLINE_MAXLEN 512
// set to 1 to get GC tracing messages
// adding real debugging - http://software-lab.de/doc/tut.html#dbg
static int traceGC = 0;
static int trace = 0;
static int level = 0;
static int trace_level = 0;
static void indent(int n) {
n *= 2;
while (n-- > 0) putchar(' ');
}
// handle errors, break
jmp_buf lisp_break = {0};
// use for list(mkint(1), symbol("foo"), mkint(3), END);
// if non nil enables continous GC
// TODO: remove
static int dogc = 0;
typedef struct {
char tag;
char xx;
short index;
char* p; // TODO: make it inline, not second allocation
} string;
// conss name in order to be able to have a function named 'cons()'
// these are special, not stored in the allocated array
typedef struct {
lisp car;
lisp cdr;
} conss;
// lisp is a pointer with some semantics according to its lowest bits
// ==================================================================
// cons cells are 8 bytes, heap allocated objects are all 8 byte aligned too,
// thus, the three lowest bits aren't used so we use it for tagging/inline types.
//
// this is not ACCURATE!!! see later....
//
// 00000000 nil
// 000 heap allocated objects
// 01 int stored inline in the pointer
// 010 cons pointer into conses array
// 11 symbol names stored inside the pointer
//
// 100 special pointer, see below...
// 0100 UNUSED: ??? (IROM) symbol/string, n*16 bytes, zero terminated
// 1100 UNUSED: ??? (IROM) longcons (array consequtive nil terminated list) n*16 bytes (n*8 cars)
//
// x1yy cons style things? but with other type
// 0110 UNUSED: maybe we have func/thunk/immediate
// 1110 UNUSED:
// Espruino Javascript for esp8266 memory usage
// - http://www.esp8266.com/viewtopic.php?f=44&t=6574
// - uses 20KB, so 12 KB available for JS code + vars...
// stored using inline pointer
typedef struct {
char tag;
char xx;
short index;
int v;
} intint; // TODO: handle overflow...
// TODO: can we merge this and symbol, as all prim:s have name
typedef struct {
char tag;
signed char n; // TODO: maybe could use xx tag above?
short index;
void* f;
char* name; // TODO: could point to symbol, however "foo" in program will always be there as string
} prim;
// Pseudo closure that is returned by if/progn and other construct that takes code, should handle tail recursion
typedef struct thunk {
char tag;
char xx;
short index;
lisp e;
lisp env;
// This needs be same as immediate
} thunk;
typedef struct immediate {
char tag;
char xx;
short index;
lisp e;
lisp env;
// This needs be same as thunk
} immediate;
typedef struct func {
char tag;
char xx;
short index;
lisp e;
lisp env;
lisp name; // TODO: recycle
} func;
int tag_count[MAX_TAGS] = {0};
int tag_bytes[MAX_TAGS] = {0};
int tag_freed_count[MAX_TAGS] = {0};
int tag_freed_bytes[MAX_TAGS] = {0};
char* tag_name[MAX_TAGS] = { "total", "string", "cons", "int", "prim", "symbol", "thunk", "immediate", "func", 0 };
int tag_size[MAX_TAGS] = { 0, sizeof(string), sizeof(conss), sizeof(intint), sizeof(prim), sizeof(thunk), sizeof(immediate), sizeof(func) };
int gettag(lisp x) {
return TAG(x);
}
// essentially total number of cons+symbol+prim
// TODO: remove SYMBOL since they are never GC:ed! (thunk are special too, not tracked)
//#define MAX_ALLOCS 819200 // (fibo 22)
//#define MAX_ALLOCS 8192
//#define MAX_ALLOCS 1024 // keesp 15K free
//#define MAX_ALLOCS 512 // keeps 17K free
//#define MAX_ALLOCS 256 // keeps 21K free
//#define MAX_ALLOCS 128 // keeps 21K free
//#define MAX_ALLOCS 128 // make slower!!!
#define MAX_ALLOCS 256 // make faster???
int allocs_count = 0; // number of elements currently in used in allocs array
int allocs_next = 0; // top of allocations in allocs array
void* allocs[MAX_ALLOCS] = { 0 };
unsigned int used[MAX_ALLOCS/32 + 1] = { 0 };
#define SET_USED(i) ({int _i = (i); used[_i/32] |= 1 << _i%32;})
#define IS_USED(i) ({int _i = (i); (used[_i/32] >> _i%32) & 1;})
// any slot with no value/nil can be reused
int reuse_pos = 0;
int reuse() {
int n = allocs_next;
while(n--) {
if (!allocs[reuse_pos]) return reuse_pos;
reuse_pos++;
if (reuse_pos >= allocs_next) reuse_pos = 0;
}
return -1;
}
// total number of things in use
int used_count = 0;
int used_bytes = 0;
// TODO: maybe not good idea, just pre allocate 12 and 16 bytes stuff 4 at a time and put on free list?
// permanent malloc, no way to give back
#define PERMALLOC_CHUNK 64
// used_count=72 cons_count=354 free=19280 USED=12 bytes
// used_count=72 cons_count=354 free=19580 USED=16 bytes
// saved: (- 19368 19580) = -122
// 84 mallocs = (* 84 4) 336 bytes "saved"?
// used_count=72 cons_count=354 free=19288 USED=12 bytes
// used_count=72 cons_count=354 free=19580 USED=16 bytes
// used_count=72 cons_count=354 free=18892 USED=12 bytes
// unmodified: used_count=72 cons_count=354 free=18900 USED=12 bytes startMem=34796
// this: used_count=72 cons_count=354 free=19540 USED=16 bytes startMem=34796
// (- 34796 19540) = 15256
void* perMalloc(int bytes) {
if (bytes > PERMALLOC_CHUNK) return malloc(bytes);
static char* heap = NULL;
static int used = 0;
if (used + bytes > PERMALLOC_CHUNK) {
// printf("[perMalloc.more waste=%d]\n", PERMALLOC_CHUNK - used);
// TODO: how to handle waste? if too much, then not worth it...
heap = NULL;
used = 0;
}
if (!heap) heap = malloc(PERMALLOC_CHUNK);
void* r = heap;
// printf("[perMalloc %d]", bytes); fflush(stdout);
heap += bytes;
used += bytes;
return r;
}
// SLOT salloc/sfree, reuse mallocs of same size instead of free, saved 20% speed
#define SALLOC_MAX_SIZE 32
void* alloc_slot[SALLOC_MAX_SIZE] = {0}; // TODO: probably too many sizes...
void sfree(void** p, int bytes, int tag) {
if (IS((lisp)p, symboll) || CONSP((lisp)p)) {
error("sfree.ERROR: symbol or cons!\n");
}
if (bytes >= SALLOC_MAX_SIZE) {
used_bytes -= bytes;
return free(p);
}
/// TODO: use sfree?
if (IS((lisp)p, string)) {
free(((string*)p)->p);
}
// store for reuse
void* n = alloc_slot[bytes];
*p = n;
alloc_slot[bytes] = p;
// stats
if (tag > 0) {
tag_freed_count[tag]++;
tag_freed_bytes[tag] += bytes;
}
tag_freed_count[0]++;
tag_freed_bytes[0] += bytes;
}
static void* salloc(int bytes) {
void** p = alloc_slot[bytes];
if (bytes >= SALLOC_MAX_SIZE) {
used_bytes += bytes;
return malloc(bytes);
} else if (!p) {
used_bytes += bytes;
return malloc(bytes);
int i = 8;
char* n = malloc(bytes * i);
while (i--) {
sfree((void*)n, bytes, -1);
n += bytes;
}
p = alloc_slot[bytes];
}
alloc_slot[bytes] = *p;
return p;
}
// call this malloc using ALLOC(typename) macro
// if tag < 0 no GC on these (don't keep pointer around)
void* myMalloc(int bytes, int tag) {
///printf("MALLOC: %d %d %s\n", bytes, tag, tag_name[tag]);
if (1) { // 830ms -> 770ms 5% faster if removed, depends on the week!?
if (tag > 0) {
tag_count[tag]++;
tag_bytes[tag] += bytes;
used_count++;
}
tag_count[0]++;
tag_bytes[0] += bytes;
}
// use for heap debugging, put in offending addresses
//if (allocs_next == 269) { printf("\n==============ALLOC: %d bytes of tag %s ========================\n", bytes, tag_name[tag]); }
//if ((int)p == 0x08050208) { printf("\n============================== ALLOC trouble pointer %d bytes of tag %d %s ===========\n", bytes, ag, tag_name[tag]); }
void* p = salloc(bytes);
// immediate optimization, only used transiently, so given back fast, no need gc.
// symbols and prims are never freed, so no need keep track of or GC
if (tag <= 0 || tag == immediate_TAG || tag == symboll_TAG || tag == prim_TAG) {
((lisp)p)->index = -1;
return p;
}
int pos = reuse();
if (pos < 0) pos = allocs_next++;
allocs[pos] = p;
allocs_count++;
((lisp)p)->index = pos;
if (allocs_next >= MAX_ALLOCS) {
report_allocs(2);
error("Exhausted myMalloc array!\n");
}
return p;
}
static void mark_clean() {
memset(used, 0, sizeof(used));
}
static int blockGC = 0;
PRIM gc(lisp* envp) {
if (blockGC) {
printf("\n%% [warning: GC called with blockGC=%d]\n", blockGC);
return nil;
}
// mark
syms_mark();
//if (envp) { printf("ENVP %u=", (unsigned int)*envp); princ(*envp); terpri();}
if (envp) mark(*envp);
// sweep
gc_conses();
int count = 0;
int i ;
for(i = 0; i < allocs_next; i++) {
lisp p = allocs[i];
if (!p) continue;
if (INTP(p) || CONSP(p)) {
printf("GC.erronious pointer stored: %u, tag=%d\n", (int)p, TAG(p));
printf("VAL="); princ(p); terpri();
exit(1);
}
// USE FOR DEBUGGING SPECIFIC PTR
//if ((int)p == 0x0804e528) { printf("\nGC----------------------%d ERROR! p=0x%x ", i, p); princ(p); terpri(); }
if (TAG(p) > 8 || TAG(p) == 0) {
printf("\nGC----------------------%d ILLEGAL TAG! %d p=0x%x ", i, TAG(p), (unsigned int)p); princ(p); terpri();
}
int u = (used[i/32] >> i%32) & 1;
if (u) {
// printf("%d used=%d :: ", i, u); princ(p); terpri();
} else {
count++;
if (1) {
sfree((void*)p, tag_size[TAG(p)], TAG(p));;
} else {
printf("FREE: %d ", i); princ(p); terpri();
// simulate free
p->tag = 66;
}
allocs[i] = NULL;
allocs_count--;
used_count--;
}
}
mark_clean();
return mem_usage(count);
}
////////////////////////////////////////////////////////////////////////////////
// string
// only have this in order to keep track of allocations
char* my_strndup(char* s, int len) {
int l = strlen(s);
if (l > len) l = len;
char* r = myMalloc(len + 1, -1);
strncpy(r, s, len);
r[len] = 0;
return r;
}
// make a string from POINTER (inside other string) by copying LEN bytes
// if len < 0 then it's already malloced elsewhere
PRIM mklenstring(char* s, int len) {
if (!s) return nil;
string* r = ALLOC(string);
if (len >= 0) {
r->p = my_strndup(s, len); // TODO: how to deallocate?
} else {
r->p = s;
}
return (lisp)r;
}
PRIM mkstring(char* s) {
return mklenstring(s, strlen(s));
}
char* getstring(lisp s) {
return IS(s, string) ? ATTR(string, s, p) : "";
}
// TODO:
// (string-ref s 0index)
// (string-set! s 0index char) -- maybe not modify
// string=? (substring=? s1 start s2 start end)
// cmp instead of string-compare
// string-hash, string-upcase/string-downcase
// (substring s start end)
// (string-search-forward pattern string)
// (substring-search-forward pattern string start end)
// (string-search-all pattern start end) => (pos1 pos2...) / nil
// srfi.schemers.org/srfi-13/srfi-13.html -- TOO BOORING!!!
// predicate: string? string-null? string-every string-any
// construct: make-string string string-tabulate
// convertn: string->list list->string reverse-list->string string-join
// select: string-length string-ref string-copy substring/shared string-copy!
// string-take string-take-right string-drop- string-drop-right
// string-pad string-pad-right string-trim string-trim-both
// modify: string-set! string-fill!
// compare: string-compare string<> string= string< string> string<= string>=
// string-hash
// prefix: string-prefix-length string-suffix-length string-prefix? string-suffix?
// searching: string-index string-index-right string-skip string-skip-right string-count string-contains
// reverse & append: string-reverse string-append string-concatenate
// modify: string-replace string-delete
////////////////////////////////////////////////////////////////////////////////
// CONS
//#define MAX_CONS 137 // allows allocation of (list 1 2)
#define MAX_CONS 2048
//#define MAX_CONS 512
#define CONSES_BYTES (MAX_CONS * sizeof(conss))
conss* conses = NULL;
unsigned int cons_used[MAX_CONS/32 + 1] = { 0 };
lisp free_cons = 0;
int cons_count = 0; // TODO: remove, used for GC indication
#define CONS_SET_USED(i) ({int _i = (i); cons_used[_i/32] |= 1 << _i%32;})
#define CONS_IS_USED(i) ({int _i = (i); (cons_used[_i/32] >> _i%32) & 1;})
// TODO: as alternative to free list we could just use the bitmap
// this would allow us to allocate adjacent elements!
void gc_conses() {
// make first pointer point to first position
free_cons = nil;
cons_count = 0;
int i;
for(i = MAX_CONS - 1; i >= 0; i--) {
if (!CONS_IS_USED(i)) {
conss* c = &conses[i];
//if (c->car && c->car == _FREE_) continue; // already in free list...
c->car = _FREE_;
c->cdr = free_cons;
free_cons = MKCONS(c);
//printf("%u CONS=%u CONSP=%d\n", (int)c, (int)free_cons, CONSP(free_cons));
cons_count++;
}
}
memset(cons_used, 0, sizeof(cons_used));
}
void gc_cons_init() {
conses = malloc(CONSES_BYTES); // we malloc, so it's pointer starts at xxx000
memset(conses, 0, CONSES_BYTES);
memset(cons_used, 0, sizeof(cons_used));
gc_conses();
}
PRIM cons(lisp a, lisp b) {
conss* c = GETCONS(free_cons);
cons_count--;
if (!c) {
error("Run out of conses\n");
}
if (cons_count < 0) {
error("Really ran out of conses\n");
}
if (c->car != _FREE_) {
printf("Conses corruption error %u ... %u CONSP=%d\n", (int)c, (int)free_cons, CONSP(free_cons));
printf("CONS="); princ((lisp)c); terpri();
exit(1);
}
// TODO: this is updating counter in myMalloc stats, maybe refactor...
if (0) { // TOOD: enable this and it becomes very slow!!!!??? why compared to myMalloc shouldn't????
used_count++; // not correct as cons are different...
tag_count[conss_TAG]++;
tag_bytes[conss_TAG] += sizeof(conss);
tag_count[0]++;
tag_bytes[0] += sizeof(conss);
}
free_cons = c->cdr;
c->car = a;
c->cdr = b;
return MKCONS(c);
}
PRIM recons(lisp a, lisp b, lisp ab) {
if (a == car(ab) && b == cdr(ab)) return ab;
return cons(a, b);
}
// inline works on both unix/gcc and c99 for esp8266
inline PRIM car(lisp x) { return CONSP(x) ? GETCONS(x)->car : nil; }
inline PRIM cdr(lisp x) { return CONSP(x) ? GETCONS(x)->cdr : nil; }
PRIM nthcdr(lisp n, lisp l) {
int in = getint(n);
while (in-- > 0) l = cdr(l);
return l;
}
PRIM nth(lisp n, lisp l) {
if (getint(n) < 0) return nil;
return car(nthcdr(n, l));
}
int cons_count; // forward
// however, on esp8266 it's only inlined and no function exists,
// so we need to create them for use in lisp
#ifdef UNIX
#define car_ car
#define cdr_ cdr
#else
PRIM car_(lisp x) { return car(x); }
PRIM cdr_(lisp x) { return cdr(x); }
#endif
PRIM setcar(lisp x, lisp v) { return IS(x, conss) ? GETCONS(x)->car = v : nil; }
PRIM setcdr(lisp x, lisp v) { return IS(x, conss) ? GETCONS(x)->cdr = v : nil; }
PRIM list(lisp first, ...) {
va_list ap;
lisp r = nil;
// points to cell where cdr is next pos
lisp last = r;
lisp x;
va_start(ap, first);
for (x = first; x != (lisp)-1; x = va_arg(ap, lisp)) {
lisp nw = cons(x, nil);
if (!r) r = nw;
setcdr(last, nw);
last = nw;
}
va_end(ap);
return r;
}
void report_allocs(int verbose) {
int i;
if (verbose) terpri();
if (verbose == 2)
printf("--- Allocation stats ---\n");
if (verbose == 1) {
printf("\nAllocated: ");
for(i = 0; i<16; i++)
if (tag_count[i] > 0) printf("%d %s=%d bytes, ", tag_count[i], tag_name[i], tag_bytes[i]);
printf("\n Freed: ");
for(i = 0; i<16; i++)
if (tag_freed_count[i] > 0) printf("%d %s=%d bytes, ", tag_count[i], tag_name[i], tag_bytes[i]);
printf("\n Used: ");
}
for(i = 0; i<16; i++) {
if (tag_count[i] > 0 || tag_freed_count[i] > 0) {
int count = tag_count[i] - tag_freed_count[i];
int bytes = tag_bytes[i] - tag_freed_bytes[i];
if (verbose == 2)
printf("%12s: %3d allocations of %5d bytes, and still use %3d total %5d bytes\n",
tag_name[i], tag_count[i], tag_bytes[i], count, bytes);
else if (verbose == 1 && (count > 0 || bytes > 0))
printf("%d %s=%d bytes, ", count, tag_name[i], bytes);
}
}
if (verbose == 2) {
for(i = 0; i<16; i++) {
if (tag_count[i] > 0 || tag_freed_count[i] > 0) {
int count = tag_count[i] - tag_freed_count[i];
int bytes = tag_bytes[i] - tag_freed_bytes[i];
if (verbose == 1 && (tag_count[i] != count || tag_bytes[i] != bytes) && (tag_count[i] || tag_bytes[i]))
printf("churn %d %s=%d bytes, ", tag_count[i], tag_name[i], tag_bytes[i]);
}
}
}
for(i = 0; i<16; i++) {
tag_count[i] = 0;
tag_bytes[i] = 0;
tag_freed_count[i] = 0;
tag_freed_bytes[i] = 0;
}
// print static sizes...
if (verbose) {
int tot = 0, b;
printf("\nSTATICS ");
b = sizeof(tag_name); printf("tag_name: %d ", b); tot += b;
b = sizeof(tag_size); printf("tag_size: %d ", b); tot += b;
b = sizeof(tag_count); printf("tag_count: %d ", b); tot += b;
b = sizeof(tag_bytes); printf("tag_bytes: %d ", b); tot += b;
b = sizeof(tag_freed_count); printf("tag_freed_count: %d ", b); tot += b;
b = sizeof(tag_freed_bytes); printf("tag_freed_bytes: %d ", b); tot += b;
b = sizeof(allocs); printf("allocs: %d ", b); tot += b;
b = sizeof(alloc_slot); printf("alloc_slot: %d ", b); tot += b;
b = CONSES_BYTES; printf("conses: %d ", b); tot += b;
b = sizeof(cons_used); printf("cons_used: %d ", b); tot += b;
printf(" === TOTAL: %d\n", tot);
}
// TODO: this one doesn't make sense?
if (verbose) {
printf("\nused_count=%d cons_count=%d ", used_count, cons_count);
fflush(stdout);
}
}
lisp mkint(int v) {
return MKINT(v);
// TODO: add "bigint" or minusint...
intint* r = ALLOC(intint);
r->v = v;
return (lisp)r;
}
int getint(lisp x) {
return INTP(x) ? GETINT(x) : 0;
// TODO: add "bigint" or minusint...
return IS(x, intint) ? ATTR(intint, x, v) : 0;
}
PRIM eq(lisp a, lisp b);
PRIM member(lisp e, lisp r) {
while (r) {
if (eq(e, car(r))) return r;
r = cdr(r);
}
return nil;
}
PRIM out(lisp pin, lisp value) {
gpio_enable(getint(pin), GPIO_OUTPUT);
gpio_write(getint(pin), getint(value));
return value;
}
PRIM in(lisp pin) {
gpio_enable(getint(pin), GPIO_INPUT);
return mkint(gpio_read(getint(pin)));
}
PRIM dht(lisp pin) {
int t, h;
if (dht_read(pin, &t, &h)) return nil;
return cons(mkint(t), mkint(h));
}
PRIM adc() {
int v = sdk_system_adc_read();
return mkint(v);
}
// CONTROL INTERRUPTS:
// -------------------
// (interrupt PIN 0) : disable
// (interrupt PIN 1) : EDGE_POS
// (interrupt PIN 2) : EDGE_NEG
// (interrupt PIN 3) : EDGE_ANY
// (interrupt PIN 4) : LOW
// (interrupt PIN 5) : HIGH
//
// TODO: this has 200 ms, "ignore" if happen within 200ms, maybe add as parameter?
//
// CALLBACK API:
// -------------
// If any interrupt is enabled it'll call intXX where XX=pin if the symbol exists.
// This is called from the IDLE loop, no clicks counts will be lost, clicks is the
// new clicks since last invokation/clear. It will only be invoked once if any was
// missed, and only the last time in ms is retained.
//
// (define (int00 pin clicks count ms)
// (printf " [button %d new clicks=%d total=%d last at %d ms] " pin clicks count ms))
//
// POLLING API:
// ------------
// (interrupt PIN) : get count
// (interrupt PIN -1) : get +count if new, or -count if no new
// (interrupt PIN -2) : get +count if new, or 0 otherwise
// (interrupt PIN -3) : get ms of last click
PRIM interrupt(lisp pin, lisp changeType) {
if (!pin && !changeType) return nil;
int ct = getint(changeType);
if (changeType && ct >= 0) {
interrupt_init(getint(pin), ct);
return pin;
} else {
return mkint(getInterruptCount(getint(pin), changeType ? ct : 0));
}
}
// wget functions...
// echo '
// (wget "yesco.org" "http://yesco.org/index.html" (lambda (t a v) (princ t) (cond (a (princ " ") (princ a) (princ "=") (princ v)(terpri)))))
// ' | ./run
static void f_emit_text(lisp callback, char* path[], char c) {
maybeGC();
apply(callback, list(mkint(c), END)); // more effcient with "integer"/char
}
static void f_emit_tag(lisp callback, char* path[], char* tag) {
maybeGC();
apply(callback, list(symbol(tag), END));
}
static void f_emit_attr(lisp callback, char* path[], char* tag, char* attr, char* value) {
maybeGC();
apply(callback, list(symbol(tag), symbol(attr), mkstring(value), END));
}
// TODO: http://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/XML-Input.html#XML-Input
// https://www.gnu.org/software/guile/manual/html_node/Reading-and-Writing-XML.html
// https://www.gnu.org/software/guile/manual/html_node/sxml_002dmatch.html
PRIM wget_(lisp server, lisp url, lisp callback) {
wget_data data;
memset(&data, 0, sizeof(data));
data.userdata = callback;
data.xml_emit_text = (void*)f_emit_text;
data.xml_emit_tag = (void*)f_emit_tag;
data.xml_emit_attr = (void*)f_emit_attr;
wget(&data, getstring(url), getstring(server));
return nil;
}
// web functions...
// Generalize, similarly to xml stuff, with userdata etc, in order to handle several servers
static lisp web_callback = NULL;
static void header(char* buff, char* method, char* path) {
buff = buff ? buff : "";
maybeGC();
apply(web_callback, list(symbol("header"), mkstring(buff), symbol(method), mkstring(path), END));
}
static void body(char* buff, char* method, char* path) {
buff = buff ? buff : "";
maybeGC();
apply(web_callback, list(symbol("body"), mkstring(buff), symbol(method), mkstring(path), END));
}
static void response(int req, char* method, char* path) {
maybeGC();
lisp ret = apply(web_callback, list(nil, mkint(req), symbol(method), mkstring(path), END));
printf("RET="); princ(ret); terpri();
// TODO: instead redirect output to write!!!
char* s = getstring(ret);
do {
int r = write(req, s, strlen(s));
if (r < 0) { printf("%%Error on writing response, errno=%d\n", errno); break; }
s += r;
} while (*s);
maybeGC();
}
// echo '
// (web 8080 (lambda (r w s m p) (princ w) (princ " ") (princ s) (princ " ") (princ m) (princ " ") (princ p) (terpri) "FISH-42"))
// ' | ./run
int web_socket = 0;
int web_one() {
int r = -1;
if (!web_socket) return 0;
if (setjmp(lisp_break) == 0) {
r = httpd_next(web_socket, header, body, response);
} else {
printf("\n%%web_one.error... recovering...\n");
}
// disable longjmp
memset(lisp_break, 0, sizeof(lisp_break));
return r;
}
PRIM web(lisp* envp, lisp port, lisp callback) {
//wget_data data;
//memset(&data, 0, sizeof(data));
//data.userdata = callback;
//data.xml_emit_text = (void*)f_emit_text;
//data.xml_emit_tag = (void*)f_emit_tag;
//data.xml_emit_attr = (void*)f_emit_attr;
// store a pointer in global env to the function so it doesn't get gc:ed
web_callback = evalGC(callback, envp);
_define(envp, list(symbol("webcb"), reads("web_callback"), END));
int s = httpd_init(getint(port));
if (s < 0) { printf("ERROR.errno=%d\n", errno); return nil; }
web_socket = s;
web_one();
return mkint(s);
}
// lookup binding of symbol variable name (not work for int names)