diff --git a/femtolisp/compiler.lsp b/femtolisp/compiler.lsp index b9efc4f..52c938d 100644 --- a/femtolisp/compiler.lsp +++ b/femtolisp/compiler.lsp @@ -24,7 +24,7 @@ :loadg :loada :loadc :loadg.l :setg :seta :setc :setg.l - :closure :trycatch :argc :vargc :close :let :for :tapply + :closure :trycatch :argc :vargc :close :let :for :tapply :add2 :sub2 :neg dummy_t dummy_f dummy_nil])) @@ -69,13 +69,14 @@ (define (make-label e) (gensym)) (define (mark-label e l) (emit e :label l)) -(define (count- f l n) - (if (null? l) - n - (count- f (cdr l) (if (f (car l)) - (+ n 1) - n)))) -(define (count f l) (count- f l 0)) +(define (count f l) + (define (count- f l n) + (if (null? l) + n + (count- f (cdr l) (if (f (car l)) + (+ n 1) + n)))) + (count- f l 0)) (define (peephole c) c) @@ -147,22 +148,17 @@ (io.tostring! bcode)))) (define (const-to-idx-vec e) - (let ((const-to-idx (aref e 1)) - (nconst (aref e 2))) - (let ((cvec (vector.alloc nconst))) - (table.foreach (lambda (val idx) (aset! cvec idx val)) - const-to-idx) - cvec))) + (let ((cvec (vector.alloc (aref e 2)))) + (table.foreach (lambda (val idx) (aset! cvec idx val)) + (aref e 1)) + cvec)) (define (index-of item lst start) (cond ((null? lst) #f) - ((eq item (car lst)) start) - (#t (index-of item (cdr lst) (+ start 1))))) + ((eq? item (car lst)) start) + (else (index-of item (cdr lst) (+ start 1))))) -(define (in-env? s env) - (and (pair? env) - (or (memq s (car env)) - (in-env? s (cdr env))))) +(define (in-env? s env) (any (lambda (e) (memq s e)) env)) (define (lookup-sym s env lev arg?) (if (null? env) @@ -185,17 +181,14 @@ (closed (emit g (aref Is 1) (cadr loc) (caddr loc))) (else (emit g (aref Is 2) s))))) -(define (builtin->instruction b) - (let ((sym (intern (string #\: b)))) - (and (has? Instructions sym) sym))) - (define (cond->if form) (cond-clauses->if (cdr form))) (define (cond-clauses->if lst) (if (atom? lst) #f (let ((clause (car lst))) - (if (eq? (car clause) 'else) + (if (or (eq? (car clause) 'else) + (eq? (car clause) #t)) (cons 'begin (cdr clause)) `(if ,(car clause) ,(cons 'begin (cdr clause)) @@ -278,13 +271,13 @@ (define MAX_ARGS 127) -(define (list-part- l n i subl acc) - (cond ((atom? l) (if (> i 0) - (cons (nreverse subl) acc) - acc)) - ((>= i n) (list-part- l n 0 () (cons (nreverse subl) acc))) - (else (list-part- (cdr l) n (+ 1 i) (cons (car l) subl) acc)))) (define (list-partition l n) + (define (list-part- l n i subl acc) + (cond ((atom? l) (if (> i 0) + (cons (nreverse subl) acc) + acc)) + ((>= i n) (list-part- l n 0 () (cons (nreverse subl) acc))) + (else (list-part- (cdr l) n (+ 1 i) (cons (car l) subl) acc)))) (if (<= n 0) (error "list-partition: invalid count") (nreverse (list-part- l n 0 () ())))) @@ -339,6 +332,10 @@ (emit g :close) (emit g (if tail? :tcall :call) (+ 1 nargs))))) +(define (builtin->instruction b) + (let ((sym (intern (string #\: b)))) + (and (has? Instructions sym) sym))) + (define (compile-call g env tail? x) (let ((head (car x))) (let ((head @@ -361,11 +358,13 @@ (argc-error head count)) (case b ; handle special cases of vararg builtins (:list (if (= nargs 0) (emit g :loadnil) (emit g b nargs))) - (:+ (if (= nargs 0) (emit g :load0) - (emit g b nargs))) - (:- (if (= nargs 0) - (argc-error head 1) - (emit g b nargs))) + (:+ (cond ((= nargs 0) (emit g :load0)) + ((= nargs 2) (emit g :add2)) + (else (emit g b nargs)))) + (:- (cond ((= nargs 0) (argc-error head 1)) + ((= nargs 1) (emit g :neg)) + ((= nargs 2) (emit g :sub2)) + (else (emit g b nargs)))) (:* (if (= nargs 0) (emit g :load1) (emit g b nargs))) (:/ (if (= nargs 0) @@ -403,6 +402,8 @@ (or (compile-or g env tail? (cdr x))) (while (compile-while g env (cadr x) (cons 'begin (cddr x)))) (for (compile-for g env (cadr x) (caddr x) (cadddr x))) + (return (compile-in g env #t (cadr x)) + (emit g :ret)) (set! (compile-in g env #f (caddr x)) (compile-sym g env (cadr x) [:seta :setc :setg])) (trycatch (compile-in g env #f `(lambda () ,(cadr x))) @@ -440,14 +441,19 @@ (define (hex5 n) (pad-l (number->string n 16) 5 #\0)) -(define (disassemble- f lev) - (let ((fvec (function->vector f))) +(define (disassemble f . lev?) + (if (null? lev?) + (begin (disassemble f 0) + (newline) + (return #t))) + (let ((fvec (function->vector f)) + (lev (car lev?))) (let ((code (aref fvec 0)) (vals (aref fvec 1))) (define (print-val v) (if (and (function? v) (not (builtin? v))) (begin (princ "\n") - (disassemble- v (+ lev 1))) + (disassemble v (+ lev 1))) (print v))) (let ((i 0) (N (length code))) @@ -488,6 +494,4 @@ (else #f)))))))) -(define (disassemble f) (disassemble- f 0) (newline)) - #t diff --git a/femtolisp/flisp.boot b/femtolisp/flisp.boot index 829133e..2438428 100644 --- a/femtolisp/flisp.boot +++ b/femtolisp/flisp.boot @@ -41,7 +41,7 @@ splice-form? set-syntax! #function("n2d0d1e0e143;" [put! *syntax-environment*]) separate -#function("n2f00e0e1^^44;" [] #0=[#function("n4e1A6>0e2e3K;e0e1M316[0f00e0e1Ne1Me2Ke344;\\6r0f00e0e1Ne2e1Me3K44;];" [] #0#) ()]) +#function("n2f00e0e1^^44;" [] #0=[#function("n4e1A6>0e2e3K;e0e1M316[0f00e0e1Ne1Me2Ke344;f00e0e1Ne2e1Me3K44;" [] #0#) ()]) reverse #function("n1d0d1^e043;" [foldl cons]) revappend @@ -49,9 +49,9 @@ revappend remainder #function("n2e0e0e1U2e1T2S2;" []) ref-uint32-LE -#function("n2d0e0e1_R2Z_32d0e0e1`R2Za832d0e0e1a2R2Za@32d0e0e1a3R2ZaH32R4;" [ash]) +#function("n2d0e0e1_tZ_32d0e0e1`tZa832d0e0e1a2tZa@32d0e0e1a3tZaH32R4;" [ash]) ref-uint16-LE -#function("n2d0e0e1_R2Z_32d0e0e1`R2Za832R2;" [ash]) +#function("n2d0e0e1_tZ_32d0e0e1`tZa832t;" [ash]) repl #function("n0b0]]p43;" [#function("q3b0li02b1li12e1302d240;" [#function("n0d0b1312d2d3312b4b5lb6lmp42;" [princ "> " io.flush *output-stream* #function("q2d0d131@16I02b2d3e031p42;" [io.eof? *input-stream* #function("q2d0e0312e0h12\\;" [print that]) load-process]) #function("n0d040;" [read]) #function("n1d0d1312d2e041;" [io.discardbuffer *input-stream* raise])]) #function("n0b0lb1lm6G0d2302f0140;];" [#function("n0f003016@02d040;" [newline]) #function("n1d0e041;" [print-exception]) newline]) newline])]) self-evaluating? @@ -91,21 +91,19 @@ nestlist newline #function("n0d0d1312\\;" [princ *linefeed*]) memv -#function("n2e1?6:0];e1Me0=6F0e1;\\6T0d0e0e1N42;];" [memv]) +#function("n2e1?6:0];e1Me0=6F0e1;d0e0e1N42;" [memv]) mod #function("n2e0e0e1U2e1T2S2;" []) member -#function("n2e1?6:0];e1Me0>6F0e1;\\6T0d0e0e1N42;];" [member]) +#function("n2e1?6:0];e1Me0>6F0e1;d0e0e1N42;" [member]) mark-label #function("n2d0e0d1e143;" [emit :label]) map! #function("n2e1]e1F6O02e1e0e1M31O2e1Ni15502;" []) map-int #function("n2d0e1_326>0^;b1e0_31^K^p43;" [<= #function("q3e0i12`f01`S2b0lr2e0;" [#function("n1f01f10e031^KP2f01Nj01;" [])])]) -mapcar -#function("o1f00e0e142;" [] #0=[#function("n2e1A6=0e040;e1M?6H0e1M;\\6h0e0d0d1e132Qf00e0d0d2e13232K;];" [map car cdr] #0#) ()]) make-system-image -#function("n1b0d1e0d2d3d434b5p43;" [#function("q3d0b1ld230322d3e041;" [for-each #function("n1e0E16m02d0e031@16m02d1e031G@16m02d2e0f0132@16m02d3d1e03131@6\x9c0d4f00e0322d5f00b6322d4f00d1e031322d5f00b642;];" [constant? top-level-value memq iostream? io.print io.write "\n"]) environment io.close]) file :write :create :truncate (*linefeed* *directory-separator* *argv* that *print-pretty* *print-width*)]) +#function("n1b0d1e0d2d3d434b5d6p44;" [#function("q4]h02b1lb2lmd3e0312e2h02;" [*print-pretty* #function("n0d0b1ld23042;" [for-each #function("n1e0E16m02d0e031@16m02d1e031G@16m02d2e0f0132@16m02d3d1e03131@6\x9c0d4f00e0322d5f00b6322d4f00d1e031322d5f00b642;];" [constant? top-level-value memq iostream? io.print io.write "\n"]) environment]) #function("n1d0f00312f02h12d2e041;" [io.close *print-pretty* raise]) io.close]) file :write :create :truncate (*linefeed* *directory-separator* *argv* that *print-pretty* *print-width*) *print-pretty*]) make-enum-table #function("n2b0d130p42;" [#function("q2_d0d1f013131b2lr;" [1- length #function("n1d0f00f11e0Zf10e0R243;" [put!])]) table]) macroexpand-1 @@ -124,8 +122,8 @@ make-label #function("n1d040;" [gensym]) map #function("n2e1?6;0e1;e0e1M31d0e0e1N32K;" [map]) -listp -#function("n1e0A17=02e0F;" []) +mapcar +#function("o1f00e0e142;" [] #0=[#function("n2e1A6=0e040;e1M?6H0e1M;e0d0d1e132Qf00e0d0d2e13232K;" [map car cdr] #0#) ()]) load #function("n1b0d1e0d232p42;" [#function("q2b0lb1lm;" [#function("n0b0]p32]]]43;" [#function("q2b0li0;" [#function("n3d0f1031@6R0f00d1f1031e0d2e13143;d3f10312d2e141;" [io.eof? read load-process io.close])])]) #function("n1d0f00312d1b2f10e0L341;" [io.close raise load-error])]) file :read]) list-tail @@ -138,10 +136,8 @@ list* #function("o0e0N?6=0e0M;e0Md0e0NQK;" [list*]) list->vector #function("n1d0e0s;" [vector]) -list-part- -#function("n5e0?6O0d0e2_326L0d1e331e4K;e4;d2e2e1326n0d3e0e1_^d1e331e4K45;d3e0Ne1`e2R2e0Me3Ke445;" [> nreverse >= list-part-]) list-partition -#function("n2d0e1_326C0d1b241;d3d4e0e1_^^3541;" [<= error "list-partition: invalid count" nreverse list-part-]) +#function("n2b0]p42;" [#function("q2b0li02d1f01_326J0d2b341;d4e0f00f01_^^3541;" [#function("n5e0?6O0d0e2_326L0d1e331e4K;e4;d2e2e1326o0f00e0e1_^d1e331e4K45;f00e0Ne1`e2R2e0Me3Ke445;" [> nreverse >=]) <= error "list-partition: invalid count" nreverse])]) list? #function("n1e0A17I02e0F16I02d0e0N41;" [list?]) load-process @@ -153,7 +149,7 @@ length= lastcdr #function("n1e0?6;0e0;d0e0N41;" [lastcdr]) last-pair -#function("n1e0?6;0e0;e0N?6E0e0;\\6Q0d0e0N41;];" [last-pair]) +#function("n1e0?6;0e0;e0N?6E0e0;d0e0N41;" [last-pair]) iota #function("n1d0d1e042;" [map-int identity]) just-compile-args @@ -161,13 +157,13 @@ just-compile-args io.readline #function("n1d0e0b142;" [io.readuntil #\x000a]) in-env? -#function("n2e1F16Q02d0e0e1M3217Q02d1e0e1N42;" [memq in-env?]) +#function("n2d0b1le142;" [any #function("n1d0f00e042;" [memq])]) hex5 #function("n1d0d1e0a@32a5b243;" [pad-l number->string #\0]) identity #function("n1e0;" []) index-of -#function("n3e1A6:0];e0e1M<6F0e2;\\6Y0d0e0e1Ne2`R243;];" [index-of]) +#function("n3e1A6:0];e0e1M<6F0e2;d0e0e1Ne2`R243;" [index-of]) get-defined-vars #function("n1d0f00e03141;" [delete-duplicates] #0=[#function("n1e0?6:0^;e0Mb0<16I02e0NF6\x8c0d1e031C16`02d1e031L117\x8b02d1e031F16\x8502d2e031C16\x8502d2e031L117\x8b02^;e0Mb3<6\xa30d4d5f00e0N32s;^;" [define cadr caadr begin append map] #0#) ()]) for-each @@ -177,9 +173,9 @@ foldr foldl #function("n3e2A6;0e1;d0e0e0e2Me132e2N43;" [foldl]) filter -#function("n2f00e0e1^43;" [] #0=[#function("n3e1A6;0e2;e0e1M316V0f00e0e1Ne1Me2K43;\\6g0f00e0e1Ne243;];" [] #0#) ()]) +#function("n2f00e0e1^43;" [] #0=[#function("n3e1A6;0e2;e0e1M316V0f00e0e1Ne1Me2K43;f00e0e1Ne243;" [] #0#) ()]) f-body -#function("n1b0f00e031p42;" [#function("q2b0d1e031p42;" [#function("q2e0A6<0f00;b0e0f00L3d1b2le032K;" [lambda map #function("n1];" [])]) get-defined-vars])] [#function("n1e0?6:0];e0N^<6F0e0M;\\6P0b0e0K;];" [begin]) ()]) +#function("n1b0f00e031p42;" [#function("q2b0d1e031p42;" [#function("q2e0A6<0f00;b0e0f00L3d1b2le032K;" [lambda map #function("n1];" [])]) get-defined-vars])] [#function("n1e0?6:0];e0N^<6F0e0M;b0e0K;" [begin]) ()]) expand #function("n1d0e041;" [macroexpand]) every @@ -198,24 +194,20 @@ emit #function("o2d0e1b1326I0b2e0`Zp325J0]2e0_d3e1e2Ke0_Z32[2e0;" [memq (:loadv :loadg :setg) #function("q2b0f00a2Zp42;" [#function("q2b0f12Mp42;" [#function("q2b0d1f10e0326L0d2f10e0325i0d3f10e0f00332f00`R2j002f00`S2p42;" [#function("q2f30a2f10[2e0L1j322d0e0b1326[0b2f31p32j31;];" [>= 256 #function("q2e0d0=6=0d1;e0d2=6H0d3;e0d4=6S0d5;];" [:loadv :loadv.l :loadg :loadg.l :setg :setg.l])]) has? get put!])])]) nreconc]) display #function("n1d0e0312\\;" [princ]) -disassemble- -#function("n2b0d1e031p42;" [#function("q2b0e0_Ze0`Zp43;" [#function("q3b0]p42;" [#function("q2b0li02b1_d2f0031p43;" [#function("n1e0J16>02e0G@6U0d0b1312d2e0f31`R242;d3e041;" [princ "\n" disassemble- print]) #function("q3]e0e1W6P02b0d1d2f10e0Z32p32530;" [#function("q2d0f00_326D0d1305E0]2_f41`S2b2lr2d3d4f0031b5d6d7e031`32b8342f00`R2j002b9e0p42;" [> newline #function("n1d0b141;" [princ "\t"]) princ hex5 ": " string.tail string "\t" #function("q2d0e0b1326\\0f20f31d2f30f1032Z312f10a4R2j10;d0e0b3326\x820f20f31f30f10ZZ312f10`R2j10;d0e0b4326\xa70d5d6f30f10Z31312f10`R2j10;d0e0b7326\xe80d5d6f30f10Z31b8322f10`R2j102d5d6f30f10Z31312f10`R2j10;d0e0b9326\x130d5b:d;d1d5b:d;d2f30f103231322f10a4R2j10;];" [memv (:loadv.l :loadg.l :setg.l) ref-uint32-LE (:loadv :loadg :setg) (:loada :seta :call :tcall :list :+ :- :* :/ :vector :argc :vargc :loadi8 :let) princ number->string (:loadc :setc) " " (:jmp :brf :brt) "@" hex5 ref-uint16-LE (:jmp.l :brf.l :brt.l)])]) get 1/Instructions]) length])])]) function->vector]) disassemble -#function("n1d0e0_322d140;" [disassemble- newline]) +#function("o1e1A6J0d0e0_322d1302\\;5K0]2b2d3e031e1Mp43;" [disassemble newline #function("q3b0e0_Ze0`Zp43;" [#function("q3b0]p42;" [#function("q2b0li02b1_d2f0031p43;" [#function("n1e0J16>02e0G@6T0d0b1312d2e0f21`t42;d3e041;" [princ "\n" disassemble print]) #function("q3]e0e1W6P02b0d1d2f10e0Z32p32530;" [#function("q2d0f00_326D0d1305E0]2_f31`ub2lr2d3d4f0031b5d6d7e031`32b8342f00`tj002b9e0p42;" [> newline #function("n1d0b141;" [princ "\t"]) princ hex5 ": " string.tail string "\t" #function("q2d0e0b1326[0f20f31d2f30f1032Z312f10a4tj10;d0e0b3326\x800f20f31f30f10ZZ312f10`tj10;d0e0b4326\xa40d5d6f30f10Z31312f10`tj10;d0e0b7326\xe30d5d6f30f10Z31b8322f10`tj102d5d6f30f10Z31312f10`tj10;d0e0b9326\x0d0d5b:d;dstring (:loadc :setc) " " (:jmp :brf :brt) "@" hex5 ref-uint16-LE (:jmp.l :brf.l :brt.l)])]) get 1/Instructions]) length])])]) function->vector]) delete-duplicates #function("n1e0?6;0e0;b0e0Me0Np43;" [#function("q3d0e0e1326D0d1e141;e0d1e131K;" [member delete-duplicates])]) -count- -#function("n3e1A6;0e2;d0e0e1Ne0e1M316T0e2`R25V0e243;" [count-]) copy-tree #function("n1e0?6;0e0;d0e0M31d0e0N31K;" [copy-tree]) count -#function("n2d0e0e1_43;" [count-]) +#function("n2b0]p42;" [#function("q2b0li02e0f00f01_43;" [#function("n3e1A6;0e2;f00e0e1Ne0e1M316U0e2`R25W0e243;" [])])]) copy-list #function("n1e0?6;0e0;e0Md0e0N31K;" [copy-list]) const-to-idx-vec -#function("n1b0e0`Ze0a2Zp43;" [#function("q3b0d1e131p42;" [#function("q2d0b1lf00322e0;" [table.foreach #function("n2f00e1e0[;" [])]) vector.alloc])]) +#function("n1b0d1e0a2Z31p42;" [#function("q2d0b1lf00`Z322e0;" [table.foreach #function("n2f00e1e0[;" [])]) vector.alloc]) cond-clauses->if -#function("n1e0?6:0];b0e0Mp42;" [#function("q2e0Mb0<6B0b1e0NK;b2e0Mb1e0NKd3f00N31L4;" [else begin if cond-clauses->if])]) +#function("n1e0?6:0];b0e0Mp42;" [#function("q2e0Mb0<17B02e0M\\<6L0b1e0NK;b2e0Mb1e0NKd3f00N31L4;" [else begin if cond-clauses->if])]) compile-while #function("n4b0d1e031d1e031p43;" [#function("q3d0f00f01]]342d1f00e0322d0f00f01]f02342d2f00d3e1332d2f00d4322d0f00f01]f03342d2f00d5e0332d1f00e142;" [compile-in mark-label emit :brf :pop :jmp]) make-label]) cond->if @@ -237,21 +229,21 @@ compile-if compile-for #function("n5d0e4316h0d1e0e1]e2342d1e0e1]e3342d1e0e1]e4342d2e0d342;d4b541;" [1arg-lambda? compile-in emit :for error "for: third form must be a 1-argument lambda"]) compile-call -#function("n4b0e3Mp42;" [#function("q2b0e0C16e02d1e0f0132@16e02e0E16e02d2e03116e02d3e031G6q0d3e0315s0e0p42;" [#function("q2b0e0G16B02d1e031p42;" [#function("q2e0@6I0d0f20f21]f00345J0]2b1d2f20f21f23N33p42;" [compile-in #function("q2f006H0b0d1d2f00]33p42;d3f30f326X0d45Z0d5e043;" [#function("q2e016D02d0f43Ne032@6S0d1f20e0325T0]2b2f10p42;" [length= argc-error #function("q2e0d0=6Z0f10_V6L0d1f50d242;d1f50f20f1043;e0d3=6\x820f10_V6t0d1f50d442;d1f50f20f1043;e0d5=6\xa90f10_V6\x9b0d6f30`42;d1f50f20f1043;e0d7=6\xd10f10_V6\xc30d1f50d842;d1f50f20f1043;e0d9=6\xf80f10_V6\xea0d6f30`42;d1f50f20f1043;e0d:=6\"0f10_V6\x140d1f50d;b<43;d1f50f20f1043;d1f50f5216512f20d=<6=1d>5@1f2042;" [:list emit :loadnil :+ :load0 :- argc-error :* :load1 :/ :vector :loadv [] :apply :tapply])]) get arg-counts emit :tcall :call]) compile-arglist]) builtin->instruction]) in-env? constant? top-level-value])]) +#function("n4b0e3Mp42;" [#function("q2b0e0C16e02d1e0f0132@16e02e0E16e02d2e03116e02d3e031G6q0d3e0315s0e0p42;" [#function("q2b0e0G16B02d1e031p42;" [#function("q2e0@6I0d0f20f21]f00345J0]2b1d2f20f21f23N33p42;" [compile-in #function("q2f006H0b0d1d2f00]33p42;d3f30f326X0d45Z0d5e043;" [#function("q2e016D02d0f43Ne032@6S0d1f20e0325T0]2b2f10p42;" [length= argc-error #function("q2e0d0=6Z0f10_V6L0d1f50d242;d1f50f20f1043;e0d3=6\x950f10_V6t0d1f50d442;f10a2V6\x870d1f50d542;d1f50f20f1043;e0d6=6\xe10f10_V6\xae0d7f30`42;f10`V6\xc00d1f50d842;f10a2V6\xd30d1f50d942;d1f50f20f1043;e0d:=6\x090f10_V6\xfb0d1f50d;42;d1f50f20f1043;e0d<=601f10_V6\"0d7f30`42;d1f50f20f1043;e0d==6Z1f10_V6L1d1f50d>b?43;d1f50f20f1043;d1f50f5216m12f20d@<6u1dA5x1f2042;" [:list emit :loadnil :+ :load0 :add2 :- argc-error :neg :sub2 :* :load1 :/ :vector :loadv [] :apply :tapply])]) get arg-counts emit :tcall :call]) compile-arglist]) builtin->instruction]) in-env? constant? top-level-value])]) compile-begin #function("n4e3?6D0d0e0e1e2]44;e3N?6Y0d0e0e1e2e3M44;d0e0e1]e3M342d1e0d2322d3e0e1e2e3N44;" [compile-in emit :pop compile-begin]) compile-and #function("n4d0e0e1e2e3\\d146;" [compile-short-circuit :brf]) -compile -#function("n1d0^e042;" [compile-f]) compile-app #function("n4b0e3Mp42;" [#function("q2e0F16O02e0Mb0<16O02d1d2e031316c0d3f00f01f02f0344;d4f00f01f02f0344;" [lambda list? cadr compile-let compile-call])]) +compile +#function("n1d0^e042;" [compile-f]) compile-arglist #function("n3b0d1e2d232p42;" [#function("q2e06i0d0f00d1f02d232f01332b3d4d5b6ld7e0d23232Kp322d2`R2;d0f00f02f01332d8f0241;" [just-compile-args list-head MAX_ARGS #function("q2d0f10f11]e044;" [compile-in]) nconc map #function("n1d0e0K;" [list]) list-partition length]) length> MAX_ARGS]) compile-f #function("o2b0d130d2e131p43;" [#function("q3f02A@6O0d0e0d1d2d3e13131335\x820d4e131A6j0d0e0d5d3e131335\x820d0e0d6e1?6z0_5\x800d3e131332d7e0d8e131f00K\\d9f0131342d0e0d:322d;d= <= :loadi8 :loadv #function("q2e0b0=6K0d1f00d2d3f033143;e0b4=6h0d5f00f01f02d6f033144;e0b7=6\x810d8f00f01f02f0344;e0b9=6\x9b0d:f00f01f02f03N44;e0b;=6\xb10df01f0332332d1f00d?42;e0b@=6\xf10dAf00f01f02f03N44;e0bB=6\x0b0dCf00f01f02f03N44;e0bD=6/0dEf00f01d3f0331b9dFf0331K44;e0bG=6W1dHf00f01d3f0331dIf0331dJf033145;e0bK=6\x861d5f00f01]dIf0331342dLf00f01d3f0331bM44;e0bN=6\xdc1d5f00f01]b=^d3f0331L3342dOdIf0331316\xb81]5\xbe1dPbQ312d5f00f01]dIf0331342d1f00dR42;dSf00f01f02f0344;" [quote emit :loadv cadr cond compile-in cond->if if compile-if begin compile-begin prog1 compile-prog1 lambda compile-f :closure and compile-and or compile-or while compile-while cddr for compile-for caddr cadddr set! compile-sym [:seta :setc :setg] trycatch 1arg-lambda? error "trycatch: second form must be a 1-argument lambda" :trycatch compile-app])]) +#function("n4e3C6E0d0e0e1e3b144;e3?6\xd10e3_<6[0d2e0d342;e3`<6k0d2e0d442;e3\\<6{0d2e0d542;e3]<6\x8b0d2e0d642;e3^<6\x9b0d2e0d742;e3I16\xb802d8e3a\xb03216\xb802d9e3a\xaf326\xc60d2e0d:e343;d2e0d;e343;b= <= :loadi8 :loadv #function("q2e0b0=6K0d1f00d2d3f033143;e0b4=6h0d5f00f01f02d6f033144;e0b7=6\x810d8f00f01f02f0344;e0b9=6\x9b0d:f00f01f02f03N44;e0b;=6\xb10df01f0332332d1f00d?42;e0b@=6\xf10dAf00f01f02f03N44;e0bB=6\x0b0dCf00f01f02f03N44;e0bD=6/0dEf00f01d3f0331b9dFf0331K44;e0bG=6W1dHf00f01d3f0331dIf0331dJf033145;e0bK=6|1d5f00f01\\d3f0331342d1f00dL42;e0bM=6\xab1d5f00f01]dIf0331342dNf00f01d3f0331bO44;e0bP=6\x011d5f00f01]b=^d3f0331L3342dQdIf0331316\xdd1]5\xe31dRbS312d5f00f01]dIf0331342d1f00dT42;dUf00f01f02f0344;" [quote emit :loadv cadr cond compile-in cond->if if compile-if begin compile-begin prog1 compile-prog1 lambda compile-f :closure and compile-and or compile-or while compile-while cddr for compile-for caddr cadddr return :ret set! compile-sym [:seta :setc :setg] trycatch 1arg-lambda? error "trycatch: second form must be a 1-argument lambda" :trycatch compile-app])]) char? #function("n1d0e031b1<;" [typeof wchar]) cddr @@ -282,24 +274,24 @@ cadr #function("n1e0NM;" []) builtin->instruction #function("n1b0d1d2b3e03231p42;" [#function("q2d0d1e03216A02e0;" [has? Instructions]) intern string #\:]) +bq-bracket +#function("n1e0?6C0d0d1e031L2;e0Mb2<6W0d0d3e031L2;e0Mb4<6k0b5d3e031L2;e0Mb6<6{0d3e041;d0d1e031L2;" [list bq-process *comma* cadr *comma-at* copy-list *comma-dot*]) bq-bracket1 #function("n1e0F16@02e0Mb0<6J0d1e041;d2e041;" [*comma* cadr bq-process]) bq-process -#function("n1d0e0316T0e0H6Q0b1d2d3e03131p42;e0;e0?6a0b4e0L2;e0Mb5<6y0d2d2d6e0313141;e0Mb7<6\x890d6e041;d8d9e032@6\xa90b:d;e031de0^p43;];" [self-evaluating? #function("q2e0Mb0<6B0d1e0NK;d2d1e0L3;" [list vector apply]) bq-process vector->list quote backquote cadr *comma* any splice-form? #function("q3e0A6>0b0e1K;d1b2e1Kd3e031L142;" [list nconc nlist* bq-process]) lastcdr map bq-bracket1 #function("q3]e0F16B02e0Mb0<@6[02d1e0M31e1Ki12e0Ni05302b2e0F6u0d3e1d4e031L1325\x9a0e0A6\x840d5e1315\x9a0\\6\x990d3e1d6e031L1325\x9a0]p42;" [*comma* bq-bracket #function("q2e0NA6=0e0M;b0e0K;" [nconc]) nreconc cadr nreverse bq-process])]) -bq-bracket -#function("n1e0?6C0d0d1e031L2;e0Mb2<6W0d0d3e031L2;e0Mb4<6k0b5d3e031L2;e0Mb6<6{0d3e041;\\6\x8a0d0d1e031L2;];" [list bq-process *comma* cadr *comma-at* copy-list *comma-dot*]) +#function("n1d0e0316T0e0H6Q0b1d2d3e03131p42;e0;e0?6a0b4e0L2;e0Mb5<6y0d2d2d6e0313141;e0Mb7<6\x890d6e041;d8d9e032@6\xa90b:d;e031de0^p43;" [self-evaluating? #function("q2e0Mb0<6B0d1e0NK;d2d1e0L3;" [list vector apply]) bq-process vector->list quote backquote cadr *comma* any splice-form? #function("q3e0A6>0b0e1K;d1b2e1Kd3e031L142;" [list nconc nlist* bq-process]) lastcdr map bq-bracket1 #function("q3]e0F16B02e0Mb0<@6[02d1e0M31e1Ki12e0Ni05302b2e0F6u0d3e1d4e031L1325\x920e0A6\x840d5e1315\x920d3e1d6e031L132p42;" [*comma* bq-bracket #function("q2e0NA6=0e0M;b0e0K;" [nconc]) nreconc cadr nreverse bq-process])]) assv -#function("n2e1?6:0];d0e131e0=6J0e1M;\\6X0d1e0e1N42;];" [caar assv]) +#function("n2e1?6:0];d0e131e0=6J0e1M;d1e0e1N42;" [caar assv]) assoc -#function("n2e1?6:0];d0e131e0>6J0e1M;\\6X0d1e0e1N42;];" [caar assoc]) +#function("n2e1?6:0];d0e131e0>6J0e1M;d1e0e1N42;" [caar assoc]) argc-error #function("n2d0d1b2e0b3e1e1`V6J0b45L0b53541;" [error string "compile error: " " expects " " argument." " arguments."]) arg-counts #table(:not 1 :set-cdr! 2 :cons 2 :number? 1 :equal? 2 :cdr 1 :vector? 1 :eqv? 2 :apply 2 := 2 :atom? 1 :aref 2 :compare 2 :< 2 :null? 1 :eq? 2 :car 1 :set-car! 2 :builtin? 1 :aset! 3 :bound? 1 :boolean? 1 :pair? 1 :symbol? 1 :fixnum? 1) append2 #function("n2e0A6;0e1;e0Md0e0Ne132K;" [append2]) -any -#function("n2e1F16O02e0e1M3117O02d0e0e1N42;" [any]) +append +#function("o0e0A6:0^;e0NA6E0e0M;d0e0Md1e0NQ42;" [append2 append]) abs #function("n1e0_W6>0e0S1;e0;" []) __script @@ -308,12 +300,12 @@ __init_globals #function("n0d0b1<17K02d0b2<17K02d0b3<6Z0b4h52b6h75c0b8h52b9h72d:h;2d= #function("n2e1e0W17A02e0e1V;" []) > @@ -323,7 +315,7 @@ Instructions 1arg-lambda? #function("n1e0F16e02e0Mb0<16e02e0NF16e02d1e031F16e02d2d1e031`42;" [lambda cadr length=]) 1/Instructions -#table(2 :pop 45 :loadf 67 :tapply 59 :setg.l 38 := 15 :atom? 50 :loadv 61 :trycatch 14 :equal? 30 :cdr 40 :compare 11 :ret 69 dummy_f 28 :list 48 :load1 22 :pair? 36 :* 60 :closure 41 :vector 0 :nop 17 :null? 29 :car 56 :setg 23 :builtin? 4 :tcall 43 :aset! 3 :call 58 :setc 21 :bound? 8 :jmp.l 39 :< 63 :vargc 51 :loadv.l 53 :loada 66 :for 44 :loadt 65 :let 55 :loadg.l 5 :jmp 27 :cons 46 :loadnil 34 :+ 6 :brf 13 :eqv? 42 :aref 68 dummy_t 10 :brt.l 31 :set-car! 19 :symbol? 25 :fixnum? 16 :not 54 :loadc 47 :load0 35 :- 32 :set-cdr! 62 :argc 20 :number? 9 :brf.l 12 :eq? 26 :function? 7 :brt 70 dummy_nil 37 :/ 49 :loadi8 52 :loadg 24 :vector? 1 :dup 64 :close 18 :boolean? 33 :apply 57 :seta) +#table(2 :pop 45 :loadf 67 :tapply 59 :setg.l 15 :atom? 38 := 50 :loadv 71 dummy_t 61 :trycatch 14 :equal? 30 :cdr 40 :compare 11 :ret 69 :sub2 28 :list 48 :load1 22 :pair? 36 :* 60 :closure 41 :vector 0 :nop 17 :null? 29 :car 56 :setg 72 dummy_f 23 :builtin? 4 :tcall 43 :aset! 3 :call 58 :setc 21 :bound? 8 :jmp.l 39 :< 63 :vargc 51 :loadv.l 53 :loada 66 :for 44 :loadt 65 :let 55 :loadg.l 5 :jmp 27 :cons 46 :loadnil 34 :+ 6 :brf 13 :eqv? 42 :aref 10 :brt.l 31 :set-car! 73 dummy_nil 19 :symbol? 25 :fixnum? 16 :not 68 :add2 47 :load0 35 :- 32 :set-cdr! 62 :argc 20 :number? 9 :brf.l 54 :loadc 12 :eq? 26 :function? 7 :brt 70 :neg 37 :/ 49 :loadi8 52 :loadg 24 :vector? 1 :dup 64 :close 18 :boolean? 33 :apply 57 :seta) /= #function("n2e0e1V@;" []) 1+ diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 432e97b..7a238f9 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -716,6 +716,8 @@ static value_t do_trycatch() return v; } +#define fn_vals(f) (((value_t*)ptr(f))[4]) + /* stack on entry: caller's responsibility: @@ -744,7 +746,7 @@ static value_t apply_cl(uint32_t nargs) uint8_t *code; value_t func, v, x, e; function_t *fn; - value_t *pvals, *lenv, *pv; + value_t *lenv, *pv; symbol_t *sym; cons_t *c; @@ -761,8 +763,6 @@ static value_t apply_cl(uint32_t nargs) bp = SP-nargs; PUSH(fn->env); - PUSH(fn->vals); - pvals = &Stack[SP-1]; ip = 0; while (1) { @@ -786,15 +786,11 @@ static value_t apply_cl(uint32_t nargs) } Stack[bp+i] = v; Stack[bp+i+1] = Stack[bp+nargs]; - Stack[bp+i+2] = Stack[bp+nargs+1]; - pvals = &Stack[bp+i+2]; } else { PUSH(NIL); Stack[SP-1] = Stack[SP-2]; - Stack[SP-2] = Stack[SP-3]; - Stack[SP-3] = NIL; - pvals = &Stack[SP-1]; + Stack[SP-2] = NIL; } nargs = i+1; break; @@ -802,9 +798,7 @@ static value_t apply_cl(uint32_t nargs) ip++; // last arg is closure environment to use nargs--; - Stack[SP-2] = Stack[SP-1]; POPN(1); - pvals = &Stack[SP-1]; break; case OP_NOP: break; case OP_DUP: v = Stack[SP-1]; PUSH(v); break; @@ -1029,43 +1023,61 @@ static value_t apply_cl(uint32_t nargs) POPN(n); PUSH(v); break; + case OP_ADD2: + if (bothfixnums(Stack[SP-1], Stack[SP-2])) { + accum = (int64_t)numval(Stack[SP-1]) + numval(Stack[SP-2]); + if (fits_fixnum(accum)) + v = fixnum(accum); + else + v = return_from_int64(accum); + } + else { + v = fl_add_any(&Stack[SP-2], 2, 0); + } + POPN(1); + Stack[SP-1] = v; + break; case OP_SUB: n = code[ip++]; apply_sub: + if (n == 2) goto do_sub2; + if (n == 1) goto do_neg; i = SP-n; - if (n == 1) { - if (__likely(isfixnum(Stack[i]))) - Stack[SP-1] = fixnum(-numval(Stack[i])); - else - Stack[SP-1] = fl_neg(Stack[i]); - break; - } - if (n == 2) { - if (__likely(bothfixnums(Stack[i], Stack[i+1]))) { - s = numval(Stack[i]) - numval(Stack[i+1]); - if (__likely(fits_fixnum(s))) { - POPN(1); - Stack[SP-1] = fixnum(s); - break; - } - Stack[i+1] = fixnum(-numval(Stack[i+1])); - } - else { - Stack[i+1] = fl_neg(Stack[i+1]); - } - } - else { - // we need to pass the full arglist on to fl_add_any - // so it can handle rest args properly - PUSH(Stack[i]); - Stack[i] = fixnum(0); - Stack[i+1] = fl_neg(fl_add_any(&Stack[i], n, 0)); - Stack[i] = POP(); - } + // we need to pass the full arglist on to fl_add_any + // so it can handle rest args properly + PUSH(Stack[i]); + Stack[i] = fixnum(0); + Stack[i+1] = fl_neg(fl_add_any(&Stack[i], n, 0)); + Stack[i] = POP(); v = fl_add_any(&Stack[i], 2, 0); POPN(n); PUSH(v); break; + case OP_NEG: + do_neg: + if (__likely(isfixnum(Stack[SP-1]))) + Stack[SP-1] = fixnum(-numval(Stack[SP-1])); + else + Stack[SP-1] = fl_neg(Stack[SP-1]); + break; + case OP_SUB2: + do_sub2: + if (__likely(bothfixnums(Stack[SP-2], Stack[SP-1]))) { + s = numval(Stack[SP-2]) - numval(Stack[SP-1]); + if (__likely(fits_fixnum(s))) { + POPN(1); + Stack[SP-1] = fixnum(s); + break; + } + Stack[SP-1] = fixnum(-numval(Stack[SP-1])); + } + else { + Stack[SP-1] = fl_neg(Stack[SP-1]); + } + v = fl_add_any(&Stack[SP-2], 2, 0); + POPN(1); + Stack[SP-1] = v; + break; case OP_MUL: n = code[ip++]; apply_mul: @@ -1219,20 +1231,24 @@ static value_t apply_cl(uint32_t nargs) case OP_LOAD1: PUSH(fixnum(1)); break; case OP_LOADI8: s = (int8_t)code[ip++]; PUSH(fixnum(s)); break; case OP_LOADV: - assert(code[ip] < vector_size(*pvals)); - v = vector_elt(*pvals, code[ip]); ip++; + v = fn_vals(Stack[bp-1]); + assert(code[ip] < vector_size(v)); + v = vector_elt(v, code[ip]); ip++; PUSH(v); break; case OP_LOADVL: - v = vector_elt(*pvals, *(uint32_t*)&code[ip]); ip+=4; + v = fn_vals(Stack[bp-1]); + v = vector_elt(v, *(uint32_t*)&code[ip]); ip+=4; PUSH(v); break; case OP_LOADGL: - v = vector_elt(*pvals, *(uint32_t*)&code[ip]); ip+=4; + v = fn_vals(Stack[bp-1]); + v = vector_elt(v, *(uint32_t*)&code[ip]); ip+=4; goto do_loadg; case OP_LOADG: - assert(code[ip] < vector_size(*pvals)); - v = vector_elt(*pvals, code[ip]); ip++; + v = fn_vals(Stack[bp-1]); + assert(code[ip] < vector_size(v)); + v = vector_elt(v, code[ip]); ip++; do_loadg: assert(issymbol(v)); sym = (symbol_t*)ptr(v); @@ -1242,11 +1258,13 @@ static value_t apply_cl(uint32_t nargs) break; case OP_SETGL: - v = vector_elt(*pvals, *(uint32_t*)&code[ip]); ip+=4; + v = fn_vals(Stack[bp-1]); + v = vector_elt(v, *(uint32_t*)&code[ip]); ip+=4; goto do_setg; case OP_SETG: - assert(code[ip] < vector_size(*pvals)); - v = vector_elt(*pvals, code[ip]); ip++; + v = fn_vals(Stack[bp-1]); + assert(code[ip] < vector_size(v)); + v = vector_elt(v, code[ip]); ip++; do_setg: assert(issymbol(v)); sym = (symbol_t*)ptr(v); diff --git a/femtolisp/opcodes.h b/femtolisp/opcodes.h index 593665a..4c9fd04 100644 --- a/femtolisp/opcodes.h +++ b/femtolisp/opcodes.h @@ -21,7 +21,7 @@ enum { OP_SETG, OP_SETA, OP_SETC, OP_SETGL, OP_CLOSURE, OP_TRYCATCH, OP_ARGC, OP_VARGC, OP_CLOSE, OP_LET, OP_FOR, - OP_TAPPLY, + OP_TAPPLY, OP_ADD2, OP_SUB2, OP_NEG, OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST, diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 250e3b2..7ebe874 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -134,7 +134,6 @@ (or (pred (car lst)) (any pred (cdr lst))))) -(define (listp a) (or (null? a) (pair? a))) (define (list? a) (or (null? a) (and (pair? a) (list? (cdr a))))) (define (list-tail lst n) @@ -728,18 +727,23 @@ (define (make-system-image fname) (let ((f (file fname :write :create :truncate)) (excludes '(*linefeed* *directory-separator* *argv* that - *print-pretty* *print-width*))) - (for-each (lambda (s) - (if (and (bound? s) - (not (constant? s)) - (not (builtin? (top-level-value s))) - (not (memq s excludes)) - (not (iostream? (top-level-value s)))) - (begin - (io.print f s) (io.write f "\n") - (io.print f (top-level-value s)) (io.write f "\n")))) - (environment)) - (io.close f))) + *print-pretty* *print-width*)) + (pp *print-pretty*)) + (set! *print-pretty* #f) + (unwind-protect + (for-each (lambda (s) + (if (and (bound? s) + (not (constant? s)) + (not (builtin? (top-level-value s))) + (not (memq s excludes)) + (not (iostream? (top-level-value s)))) + (begin + (io.print f s) (io.write f "\n") + (io.print f (top-level-value s)) (io.write f "\n")))) + (environment)) + (begin + (io.close f) + (set! *print-pretty* pp))))) ; initialize globals that need to be set at load time (define (__init_globals) diff --git a/femtolisp/todo b/femtolisp/todo index 5aafc5b..ba3ffac 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -1030,4 +1030,14 @@ new evaluator todo: * let optimization * have macroexpand use its own global syntax table * be able to create/load an image file -- opcodes NEG, ADD2 +- fix trace and untrace +- opcodes NEG, ADD2, (CADR ?), sub-immediate, add-immediate +- EQTO N, compare directly to stored datum N +- peephole opt + constant+pop => nothing, e.g. 2-arg 'if' in statement position + not+brf => brt + not+brt => brf + loadt+brf => nothing + loadf+brt => nothing + loadt+brt => jmp + loadf+brf => jmp