From d031087338d4d4be434c85695a1c0fc456eaafae Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 3 Apr 2008 23:35:57 -0500 Subject: [PATCH 01/14] better cpu report --- extra/hardware-info/backend/backend.factor | 1 + extra/hardware-info/hardware-info.factor | 4 +++- extra/hardware-info/macosx/macosx.factor | 2 +- 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/hardware-info/backend/backend.factor b/extra/hardware-info/backend/backend.factor index 95a56da2d2..283fea6fcc 100644 --- a/extra/hardware-info/backend/backend.factor +++ b/extra/hardware-info/backend/backend.factor @@ -2,6 +2,7 @@ USING: system ; IN: hardware-info.backend HOOK: cpus os ( -- n ) +HOOK: cpu-mhz os ( -- n ) HOOK: memory-load os ( -- n ) HOOK: physical-mem os ( -- n ) HOOK: available-mem os ( -- n ) diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor index 6d27cf5252..53aab483a1 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/hardware-info/hardware-info.factor @@ -3,11 +3,12 @@ combinators vocabs.loader hardware-info.backend system ; IN: hardware-info : write-unit ( x n str -- ) - [ 2^ /i number>string write bl ] [ write ] bi* ; + [ 2^ /f number>string write bl ] [ write ] bi* ; : kb ( x -- ) 10 "kB" write-unit ; : megs ( x -- ) 20 "MB" write-unit ; : gigs ( x -- ) 30 "GB" write-unit ; +: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ; << { { [ os windows? ] [ "hardware-info.windows" ] } @@ -18,4 +19,5 @@ IN: hardware-info : hardware-report. ( -- ) "CPUs: " write cpus number>string write nl + "CPU Speed: " write cpu-mhz ghz nl "Physical RAM: " write physical-mem megs nl ; diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/hardware-info/macosx/macosx.factor index dac052a1de..91838d2a53 100644 --- a/extra/hardware-info/macosx/macosx.factor +++ b/extra/hardware-info/macosx/macosx.factor @@ -41,7 +41,7 @@ M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ; : machine-arch ( -- n ) { 6 12 } sysctl-query-string ; : vector-unit ( -- n ) { 6 13 } sysctl-query-uint ; : bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ; -: cpu-frequency ( -- n ) { 6 15 } sysctl-query-uint ; +M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ; : cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ; : l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ; : l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ; From 3eb2bd784f8c633840afa5796cdd49637ea01714 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 3 Apr 2008 23:36:14 -0500 Subject: [PATCH 02/14] fix library path --- extra/db/postgresql/ffi/ffi.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index 7925989bf5..7f428bb6b6 100755 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -6,7 +6,8 @@ IN: db.postgresql.ffi << "postgresql" { { [ os winnt? ] [ "libpq.dll" ] } - { [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] } + { [ os macosx? ] [ "/opt/local/lib/postgresql83/libpq.dylib" ] } + ! { [ os macosx? ] [ "libpq.dylib" ] } { [ os unix? ] [ "libpq.so" ] } } cond "cdecl" add-library >> From ec620ef0c829f2955d9a685270bd5b55c91ccabc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 5 Apr 2008 20:22:33 -0500 Subject: [PATCH 03/14] inheritance with postgresql --- extra/db/db.factor | 52 ++++++++++++++--------- extra/db/postgresql/postgresql.factor | 59 +++++++++++++-------------- 2 files changed, 61 insertions(+), 50 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 55e672ec80..3cade1a895 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -11,14 +11,19 @@ TUPLE: db update-statements delete-statements ; -: ( handle -- obj ) - H{ } clone H{ } clone H{ } clone - db construct-boa ; +: construct-db ( class -- obj ) + construct-empty + H{ } clone >>insert-statements + H{ } clone >>update-statements + H{ } clone >>delete-statements ; GENERIC: make-db* ( seq class -- db ) -GENERIC: db-open ( db -- ) + +: make-db ( seq class -- db ) + construct-db make-db* ; + +GENERIC: db-open ( db -- db ) HOOK: db-close db ( handle -- ) -: make-db ( seq class -- db ) construct-empty make-db* ; : dispose-statements ( seq -- ) [ dispose drop ] assoc-each ; @@ -30,10 +35,12 @@ HOOK: db-close db ( handle -- ) handle>> db-close ] with-variable ; +! TUPLE: sql sql in-params out-params ; TUPLE: statement handle sql in-params out-params bind-params bound? ; -TUPLE: simple-statement ; -TUPLE: prepared-statement ; -TUPLE: nonthrowable-statement ; +TUPLE: simple-statement < statement ; +TUPLE: prepared-statement < statement ; +TUPLE: nonthrowable-statement < statement ; +TUPLE: throwable-statement < statement ; : make-nonthrowable ( obj -- obj' ) dup sequence? [ [ make-nonthrowable ] map @@ -41,14 +48,12 @@ TUPLE: nonthrowable-statement ; nonthrowable-statement construct-delegate ] if ; -MIXIN: throwable-statement -INSTANCE: statement throwable-statement -INSTANCE: simple-statement throwable-statement -INSTANCE: prepared-statement throwable-statement - TUPLE: result-set sql in-params out-params handle n max ; -: ( sql in out -- statement ) - { (>>sql) (>>in-params) (>>out-params) } statement construct ; +: construct-statement ( sql in out class -- statement ) + construct-empty + swap >>out-params + swap >>in-params + swap >>sql ; HOOK: db ( str in out -- statement ) HOOK: db ( str in out -- statement ) @@ -88,10 +93,17 @@ M: nonthrowable-statement execute-statement ( statement -- ) dup #rows >>max 0 >>n drop ; -: ( query handle tuple -- result-set ) - >r >r { sql>> in-params>> out-params>> } get-slots r> - { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set - construct r> construct-delegate ; +: construct-result-set ( query handle class -- result-set ) + construct-empty + swap >>handle + >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r> + swap >>out-params + swap >>in-params + swap >>sql ; + + ! >r >r { sql>> in-params>> out-params>> } get-slots r> + ! { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set + ! construct r> construct-delegate ; : sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; @@ -110,7 +122,7 @@ M: nonthrowable-statement execute-statement ( statement -- ) accumulator >r query-each r> { } like ; inline : with-db ( db seq quot -- ) - >r make-db dup db-open db r> + >r make-db db-open db r> [ db get swap [ drop ] swap compose with-disposal ] curry with-variable ; : default-query ( query -- result-set ) diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index f9805560ad..322143e7a2 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -5,40 +5,39 @@ kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges combinators sequences.lib classes locals words tools.walker -namespaces.lib ; +namespaces.lib accessors ; IN: db.postgresql -TUPLE: postgresql-db host port pgopts pgtty db user pass ; -TUPLE: postgresql-statement ; -INSTANCE: postgresql-statement throwable-statement -TUPLE: postgresql-result-set ; +TUPLE: postgresql-db < db + host port pgopts pgtty db user pass ; + +TUPLE: postgresql-statement < throwable-statement ; + +TUPLE: postgresql-result-set < result-set ; + : ( statement in out -- postgresql-statement ) - - postgresql-statement construct-delegate ; + postgresql-statement construct-statement ; M: postgresql-db make-db* ( seq tuple -- db ) - >r first4 r> [ - { - set-postgresql-db-host - set-postgresql-db-user - set-postgresql-db-pass - set-postgresql-db-db - } set-slots - ] keep ; + >r first4 r> + swap >>db + swap >>pass + swap >>user + swap >>host ; -M: postgresql-db db-open ( db -- ) - dup { - postgresql-db-host - postgresql-db-port - postgresql-db-pgopts - postgresql-db-pgtty - postgresql-db-db - postgresql-db-user - postgresql-db-pass - } get-slots connect-postgres swap set-delegate ; +M: postgresql-db db-open ( db -- db ) + dup { + [ host>> ] + [ port>> ] + [ pgopts>> ] + [ pgtty>> ] + [ db>> ] + [ user>> ] + [ pass>> ] + } cleave connect-postgres >>handle ; M: postgresql-db dispose ( db -- ) - db-handle PQfinish ; + handle>> PQfinish ; M: postgresql-statement bind-statement* ( statement -- ) drop ; @@ -50,10 +49,10 @@ M: postgresql-statement bind-tuple ( tuple statement -- ) ] keep set-statement-bind-params ; M: postgresql-result-set #rows ( result-set -- n ) - result-set-handle PQntuples ; + handle>> PQntuples ; M: postgresql-result-set #columns ( result-set -- n ) - result-set-handle PQnfields ; + handle>> PQnfields ; M: postgresql-result-set row-column ( result-set column -- obj ) >r dup result-set-handle swap result-set-n r> pq-get-string ; @@ -69,7 +68,7 @@ M: postgresql-statement query-results ( query -- result-set ) ] [ dup do-postgresql-statement ] if* - postgresql-result-set + postgresql-result-set construct-result-set dup init-result-set ; M: postgresql-result-set advance-row ( result-set -- ) @@ -90,7 +89,7 @@ M: postgresql-result-set dispose ( result-set -- ) M: postgresql-statement prepare-statement ( statement -- ) [ - >r db get db-handle "" r> + >r db get handle>> "" r> dup statement-sql swap statement-in-params length f PQprepare postgresql-error ] keep set-statement-handle ; From aade46d44874b2223a3d81eff411e1e80de98b05 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 6 Apr 2008 00:37:12 -0500 Subject: [PATCH 04/14] sqlite inheritance --- extra/db/sqlite/sqlite.factor | 44 +++++++++++++---------------------- 1 file changed, 16 insertions(+), 28 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 9b3185bcf2..d14403648d 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -5,61 +5,49 @@ hashtables io.files kernel math math.parser namespaces prettyprint sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators -io namespaces.lib ; -USE: tools.walker +io namespaces.lib accessors ; IN: db.sqlite -TUPLE: sqlite-db path ; +TUPLE: sqlite-db < db path ; M: sqlite-db make-db* ( path db -- db ) - [ set-sqlite-db-path ] keep ; + swap >>path ; -M: sqlite-db db-open ( db -- ) - dup sqlite-db-path sqlite-open - swap set-delegate ; +M: sqlite-db db-open ( db -- db ) + [ path>> sqlite-open ] [ swap >>handle ] bi ; M: sqlite-db db-close ( handle -- ) sqlite-close ; M: sqlite-db dispose ( db -- ) dispose-db ; -: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline -TUPLE: sqlite-statement ; -INSTANCE: sqlite-statement throwable-statement +TUPLE: sqlite-statement < throwable-statement ; +! INSTANCE: sqlite-statement throwable-statement -TUPLE: sqlite-result-set has-more? ; +TUPLE: sqlite-result-set < result-set has-more? ; M: sqlite-db ( str in out -- obj ) ; M: sqlite-db ( str in out -- obj ) - { - set-statement-sql - set-statement-in-params - set-statement-out-params - } statement construct - sqlite-statement construct-delegate ; + sqlite-statement construct-statement ; : sqlite-maybe-prepare ( statement -- statement ) - dup statement-handle [ - [ - delegate - db get db-handle over statement-sql sqlite-prepare - swap set-statement-handle - ] keep + dup handle>> [ + db get handle>> over sql>> sqlite-prepare + >>handle ] unless ; M: sqlite-statement dispose ( statement -- ) - statement-handle + handle>> [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ; M: sqlite-result-set dispose ( result-set -- ) - f swap set-result-set-handle ; + f >>handle drop ; : sqlite-bind ( triples handle -- ) swap [ first3 sqlite-bind-type ] with each ; : reset-statement ( statement -- ) - sqlite-maybe-prepare - statement-handle sqlite-reset ; + sqlite-maybe-prepare handle>> sqlite-reset ; M: sqlite-statement bind-statement* ( statement -- ) sqlite-maybe-prepare @@ -104,7 +92,7 @@ M: sqlite-result-set more-rows? ( result-set -- ? ) M: sqlite-statement query-results ( query -- result-set ) sqlite-maybe-prepare - dup statement-handle sqlite-result-set + dup statement-handle sqlite-result-set construct-result-set dup advance-row ; M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; From 0804c7e7af0f68696b57c4666838ff5e1da14414 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 6 Apr 2008 01:22:52 -0500 Subject: [PATCH 05/14] cleanup --- extra/db/sqlite/sqlite.factor | 46 +++++++++++++++++------------------ 1 file changed, 22 insertions(+), 24 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index d14403648d..e0930f3ba8 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -20,7 +20,6 @@ M: sqlite-db db-close ( handle -- ) sqlite-close ; M: sqlite-db dispose ( db -- ) dispose-db ; TUPLE: sqlite-statement < throwable-statement ; -! INSTANCE: sqlite-statement throwable-statement TUPLE: sqlite-result-set < result-set has-more? ; @@ -57,11 +56,11 @@ M: sqlite-statement bind-statement* ( statement -- ) M: sqlite-statement bind-tuple ( tuple statement -- ) [ - statement-in-params + in-params>> [ - [ sql-spec-column-name ":" prepend ] - [ sql-spec-slot-name rot get-slot-named ] - [ sql-spec-type ] tri 3array + [ column-name>> ":" prepend ] + [ slot-name>> rot get-slot-named ] + [ type>> ] tri 3array ] with map ] keep bind-statement ; @@ -71,28 +70,27 @@ M: sqlite-statement bind-tuple ( tuple statement -- ) dup zero? [ "last-id failed" throw ] when ; M: sqlite-db insert-tuple* ( tuple statement -- ) - execute-statement last-insert-id swap set-primary-key ; + execute-statement last-insert-id >>primary-key drop ; M: sqlite-result-set #columns ( result-set -- n ) - result-set-handle sqlite-#columns ; + handle>> sqlite-#columns ; M: sqlite-result-set row-column ( result-set n -- obj ) - >r result-set-handle r> sqlite-column ; + [ handle>> ] [ sqlite-column ] bi* ; M: sqlite-result-set row-column-typed ( result-set n -- obj ) - dup pick result-set-out-params nth sql-spec-type - >r >r result-set-handle r> r> sqlite-column-typed ; + dup pick out-params>> nth type>> + >r >r handle>> r> r> sqlite-column-typed ; M: sqlite-result-set advance-row ( result-set -- ) - [ result-set-handle sqlite-next ] keep - set-sqlite-result-set-has-more? ; + dup handle>> sqlite-next >>has-more? drop ; M: sqlite-result-set more-rows? ( result-set -- ? ) - sqlite-result-set-has-more? ; + has-more?>> ; M: sqlite-statement query-results ( query -- result-set ) sqlite-maybe-prepare - dup statement-handle sqlite-result-set construct-result-set + dup handle>> sqlite-result-set construct-result-set dup advance-row ; M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; @@ -107,9 +105,9 @@ M: sqlite-db create-sql-statement ( class -- statement ) [ "create table " 0% 0% "(" 0% [ ", " 0% ] [ - dup sql-spec-column-name 0% + dup column-name>> 0% " " 0% - dup sql-spec-type t lookup-type 0% + dup type>> t lookup-type 0% modifiers 0% ] interleave ");" 0% ] sqlite-make ; @@ -122,7 +120,7 @@ M: sqlite-db ( tuple -- statement ) "insert into " 0% 0% "(" 0% maybe-remove-id - dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + dup [ ", " 0% ] [ column-name>> 0% ] interleave ") values(" 0% [ ", " 0% ] [ bind% ] interleave ");" 0% @@ -133,11 +131,11 @@ M: sqlite-db ( tuple -- statement ) : where-primary-key% ( specs -- ) " where " 0% - find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ; + find-primary-key dup column-name>> 0% " = " 0% bind% ; : where-clause ( specs -- ) " where " 0% - [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ; + [ " and " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave ; M: sqlite-db ( class -- statement ) [ @@ -145,7 +143,7 @@ M: sqlite-db ( class -- statement ) 0% " set " 0% dup remove-id - [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave where-primary-key% ] sqlite-make ; @@ -154,23 +152,23 @@ M: sqlite-db ( specs table -- sql ) "delete from " 0% 0% " where " 0% find-primary-key - dup sql-spec-column-name 0% " = " 0% bind% + dup column-name>> 0% " = " 0% bind% ] sqlite-make ; ! : select-interval ( interval name -- ) ; ! : select-sequence ( seq name -- ) ; M: sqlite-db bind% ( spec -- ) - dup 1, sql-spec-column-name ":" prepend 0% ; + dup 1, column-name>> ":" prepend 0% ; M: sqlite-db ( tuple class -- statement ) [ "select " 0% over [ ", " 0% ] - [ dup sql-spec-column-name 0% 2, ] interleave + [ dup column-name>> 0% 2, ] interleave " from " 0% 0% - [ sql-spec-slot-name swap get-slot-named ] with subset + [ column-name>> swap get-slot-named ] with subset dup empty? [ drop ] [ where-clause ] if ";" 0% ] sqlite-make ; From 1518d631150a969041095d71cc8381bff6157b47 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Apr 2008 22:04:31 -0500 Subject: [PATCH 06/14] Fix Windows launcher resource leak --- extra/io/windows/nt/launcher/launcher-tests.factor | 13 ++++++++++++- extra/io/windows/nt/launcher/launcher.factor | 2 +- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/extra/io/windows/nt/launcher/launcher-tests.factor b/extra/io/windows/nt/launcher/launcher-tests.factor index fac6471b8c..8b13b9b3b9 100755 --- a/extra/io/windows/nt/launcher/launcher-tests.factor +++ b/extra/io/windows/nt/launcher/launcher-tests.factor @@ -1,7 +1,7 @@ IN: io.windows.launcher.nt.tests USING: io.launcher tools.test calendar accessors namespaces kernel system arrays io io.files io.encodings.ascii -sequences parser assocs hashtables ; +sequences parser assocs hashtables math ; [ ] [ @@ -129,3 +129,14 @@ sequences parser assocs hashtables ; "HOME" swap at "XXX" = ] unit-test + +2 [ + [ ] [ + + "cmd.exe /c dir" >>command + "dir.txt" temp-file >>stdout + try-process + ] unit-test + + [ ] [ "dir.txt" temp-file delete-file ] unit-test +] times diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index a01ba4698e..97de248d24 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -39,7 +39,7 @@ IN: io.windows.nt.launcher create-mode FILE_ATTRIBUTE_NORMAL ! flags and attributes f ! template file - CreateFile dup invalid-handle? dup close-later ; + CreateFile dup invalid-handle? dup close-always ; : set-inherit ( handle ? -- ) >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; From 225a0fb781f281c2c581bacac5c4989fc2ba7d7d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Apr 2008 23:31:53 -0500 Subject: [PATCH 07/14] Fix Windows crash with set-os-envs --- core/bootstrap/primitives.factor | 1 + core/inference/known-words/known-words.factor | 2 + core/kernel/kernel-tests.factor | 9 + vm/errors.c | 6 + vm/errors.h | 2 + vm/errors.s | 687 ++++++++ vm/os-windows.c | 2 +- vm/primitives.c | 1 + vm/run.s | 1511 +++++++++++++++++ 9 files changed, 2220 insertions(+), 1 deletion(-) create mode 100644 vm/errors.s create mode 100644 vm/run.s diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 5836b4d3c5..233de6f4ee 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -737,6 +737,7 @@ define-builtin { "resize-bit-array" "bit-arrays" } { "resize-float-array" "float-arrays" } { "dll-valid?" "alien" } + { "unimplemented" "kernel.private" } } dup length [ >r first2 r> make-primitive ] 2each diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 99737e0ac5..8f505c21a1 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -594,3 +594,5 @@ set-primitive-effect \ dll-valid? { object } { object } set-primitive-effect \ modify-code-heap { array object } { } set-primitive-effect + +\ unimplemented { } { } set-primitive-effect diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 3c40984d7a..4b129ad59d 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -108,3 +108,12 @@ IN: kernel.tests H{ } values swap >r dup length swap r> 0 -roll (loop) ; [ loop ] must-fail + +! Discovered on Windows +: total-failure-1 "" [ ] map unimplemented ; + +[ total-failure-1 ] must-fail + +: total-failure-2 [ ] (call) unimplemented ; + +[ total-failure-2 ] must-fail diff --git a/vm/errors.c b/vm/errors.c index 27158cbf44..6d99d34766 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -145,3 +145,9 @@ DEFINE_PRIMITIVE(call_clear) { throw_impl(dpop(),stack_chain->callstack_bottom); } + +/* For testing purposes */ +DEFINE_PRIMITIVE(unimplemented) +{ + not_implemented_error(); +} diff --git a/vm/errors.h b/vm/errors.h index 747a3415ba..227fed9228 100755 --- a/vm/errors.h +++ b/vm/errors.h @@ -55,3 +55,5 @@ void *signal_callstack_top; void memory_signal_handler_impl(void); void divide_by_zero_signal_handler_impl(void); void misc_signal_handler_impl(void); + +DECLARE_PRIMITIVE(unimplemented); diff --git a/vm/errors.s b/vm/errors.s new file mode 100644 index 0000000000..d6b3bdb6e5 --- /dev/null +++ b/vm/errors.s @@ -0,0 +1,687 @@ + .file "errors.c" + .section .rdata,"dr" +LC0: + .ascii "fatal_error: %s %lx\12\0" + .text +.globl _fatal_error + .def _fatal_error; .scl 2; .type 32; .endef +_fatal_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call ___getreent + movl %eax, %edx + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl 8(%ebp), %eax + movl %eax, 8(%esp) + movl $LC0, 4(%esp) + movl 12(%edx), %eax + movl %eax, (%esp) + call _fprintf + movl $1, (%esp) + call _exit + .section .rdata,"dr" + .align 4 +LC1: + .ascii "You have triggered a bug in Factor. Please report.\12\0" +LC2: + .ascii "critical_error: %s %lx\12\0" + .text +.globl _critical_error + .def _critical_error; .scl 2; .type 32; .endef +_critical_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call ___getreent + movl $LC1, 4(%esp) + movl 12(%eax), %eax + movl %eax, (%esp) + call _fprintf + call ___getreent + movl %eax, %edx + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl 8(%ebp), %eax + movl %eax, 8(%esp) + movl $LC2, 4(%esp) + movl 12(%edx), %eax + movl %eax, (%esp) + call _fprintf + call _factorbug + leave + ret + .section .rdata,"dr" +LC3: + .ascii "early_error: \0" +LC4: + .ascii "\12\0" + .text +.globl _throw_error + .def _throw_error; .scl 2; .type 32; .endef +_throw_error: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + cmpl $7, _userenv+20 + je L4 + movb $0, _gc_off + movl _gc_locals_region, %eax + movl (%eax), %eax + subl $4, %eax + movl %eax, _gc_locals + movl _extra_roots_region, %eax + movl (%eax), %eax + subl $4, %eax + movl %eax, _extra_roots + call _fix_stacks + movl 8(%ebp), %eax + movl %eax, (%esp) + call _dpush + cmpl $0, 12(%ebp) + je L5 + movl _stack_chain, %eax + movl 4(%eax), %eax + movl %eax, 4(%esp) + movl 12(%ebp), %eax + movl %eax, (%esp) + call _fix_callstack_top + movl %eax, 12(%ebp) + jmp L6 +L5: + movl _stack_chain, %eax + movl (%eax), %eax + movl %eax, 12(%ebp) +L6: + movl 12(%ebp), %edx + movl _userenv+20, %eax + call _throw_impl + jmp L3 +L4: + call ___getreent + movl $LC1, 4(%esp) + movl 12(%eax), %eax + movl %eax, (%esp) + call _fprintf + call ___getreent + movl $LC3, 4(%esp) + movl 12(%eax), %eax + movl %eax, (%esp) + call _fprintf + movl 8(%ebp), %eax + movl %eax, (%esp) + call _print_obj + call ___getreent + movl $LC4, 4(%esp) + movl 12(%eax), %eax + movl %eax, (%esp) + call _fprintf + call _factorbug +L3: + leave + ret + .def _dpush; .scl 3; .type 32; .endef +_dpush: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + addl $4, %esi + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + leave + ret + .def _put; .scl 3; .type 32; .endef +_put: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %edx + movl 12(%ebp), %eax + movl %eax, (%edx) + popl %ebp + ret +.globl _general_error + .def _general_error; .scl 2; .type 32; .endef +_general_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl 8(%ebp), %eax + movl %eax, (%esp) + call _tag_fixnum + movl %eax, %edx + movl 16(%ebp), %eax + movl %eax, 12(%esp) + movl 12(%ebp), %eax + movl %eax, 8(%esp) + movl %edx, 4(%esp) + movl _userenv+24, %eax + movl %eax, (%esp) + call _allot_array_4 + movl %eax, %edx + movl 20(%ebp), %eax + movl %eax, 4(%esp) + movl %edx, (%esp) + call _throw_error + leave + ret + .def _tag_fixnum; .scl 3; .type 32; .endef +_tag_fixnum: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + sall $3, %eax + andl $-8, %eax + popl %ebp + ret +.globl _type_error + .def _type_error; .scl 2; .type 32; .endef +_type_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl 8(%ebp), %eax + movl %eax, (%esp) + call _tag_fixnum + movl %eax, %edx + movl $0, 12(%esp) + movl 12(%ebp), %eax + movl %eax, 8(%esp) + movl %edx, 4(%esp) + movl $3, (%esp) + call _general_error + leave + ret +.globl _not_implemented_error + .def _not_implemented_error; .scl 2; .type 32; .endef +_not_implemented_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl $0, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $2, (%esp) + call _general_error + leave + ret +.globl _in_page + .def _in_page; .scl 2; .type 32; .endef +_in_page: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _getpagesize + movl %eax, -4(%ebp) + movl 16(%ebp), %edx + leal 12(%ebp), %eax + addl %edx, (%eax) + movl 20(%ebp), %eax + movl %eax, %edx + imull -4(%ebp), %edx + leal 12(%ebp), %eax + addl %edx, (%eax) + movb $0, -5(%ebp) + movl 8(%ebp), %eax + cmpl 12(%ebp), %eax + jb L15 + movl -4(%ebp), %eax + addl 12(%ebp), %eax + cmpl 8(%ebp), %eax + jb L15 + movb $1, -5(%ebp) +L15: + movzbl -5(%ebp), %eax + leave + ret + .section .rdata,"dr" + .align 4 +LC5: + .ascii "allot_object() missed GC check\0" +LC6: + .ascii "gc locals underflow\0" +LC7: + .ascii "gc locals overflow\0" +LC8: + .ascii "extra roots underflow\0" +LC9: + .ascii "extra roots overflow\0" + .text +.globl _memory_protection_error + .def _memory_protection_error; .scl 2; .type 32; .endef +_memory_protection_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl $-1, 12(%esp) + movl $0, 8(%esp) + movl _stack_chain, %eax + movl 24(%eax), %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L17 + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $11, (%esp) + call _general_error + jmp L16 +L17: + movl $0, 12(%esp) + movl _ds_size, %eax + movl %eax, 8(%esp) + movl _stack_chain, %eax + movl 24(%eax), %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L19 + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $12, (%esp) + call _general_error + jmp L16 +L19: + movl $-1, 12(%esp) + movl $0, 8(%esp) + movl _stack_chain, %eax + movl 28(%eax), %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L21 + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $13, (%esp) + call _general_error + jmp L16 +L21: + movl $0, 12(%esp) + movl _rs_size, %eax + movl %eax, 8(%esp) + movl _stack_chain, %eax + movl 28(%eax), %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L23 + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $14, (%esp) + call _general_error + jmp L16 +L23: + movl $0, 12(%esp) + movl $0, 8(%esp) + movl _nursery, %eax + movl 12(%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L25 + movl $0, 4(%esp) + movl $LC5, (%esp) + call _critical_error + jmp L16 +L25: + movl $-1, 12(%esp) + movl $0, 8(%esp) + movl _gc_locals_region, %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L27 + movl $0, 4(%esp) + movl $LC6, (%esp) + call _critical_error + jmp L16 +L27: + movl $0, 12(%esp) + movl $0, 8(%esp) + movl _gc_locals_region, %eax + movl 8(%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L29 + movl $0, 4(%esp) + movl $LC7, (%esp) + call _critical_error + jmp L16 +L29: + movl $-1, 12(%esp) + movl $0, 8(%esp) + movl _extra_roots_region, %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L31 + movl $0, 4(%esp) + movl $LC8, (%esp) + call _critical_error + jmp L16 +L31: + movl $0, 12(%esp) + movl $0, 8(%esp) + movl _extra_roots_region, %eax + movl 8(%eax), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _in_page + testb %al, %al + je L33 + movl $0, 4(%esp) + movl $LC9, (%esp) + call _critical_error + jmp L16 +L33: + movl 8(%ebp), %eax + movl %eax, (%esp) + call _allot_cell + movl %eax, %edx + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl $7, 8(%esp) + movl %edx, 4(%esp) + movl $15, (%esp) + call _general_error +L16: + leave + ret + .def _allot_cell; .scl 3; .type 32; .endef +_allot_cell: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + cmpl $268435455, 8(%ebp) + jbe L36 + movl 8(%ebp), %eax + movl %eax, (%esp) + call _cell_to_bignum + movl %eax, (%esp) + call _tag_bignum + movl %eax, -4(%ebp) + jmp L35 +L36: + movl 8(%ebp), %eax + movl %eax, (%esp) + call _tag_fixnum + movl %eax, -4(%ebp) +L35: + movl -4(%ebp), %eax + leave + ret + .def _tag_bignum; .scl 3; .type 32; .endef +_tag_bignum: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + andl $-8, %eax + orl $1, %eax + popl %ebp + ret +.globl _signal_error + .def _signal_error; .scl 2; .type 32; .endef +_signal_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl 8(%ebp), %eax + movl %eax, (%esp) + call _tag_fixnum + movl %eax, %edx + movl 12(%ebp), %eax + movl %eax, 12(%esp) + movl $7, 8(%esp) + movl %edx, 4(%esp) + movl $5, (%esp) + call _general_error + leave + ret +.globl _divide_by_zero_error + .def _divide_by_zero_error; .scl 2; .type 32; .endef +_divide_by_zero_error: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl 8(%ebp), %eax + movl %eax, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $4, (%esp) + call _general_error + leave + ret +.globl _memory_signal_handler_impl + .def _memory_signal_handler_impl; .scl 2; .type 32; .endef +_memory_signal_handler_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl _signal_callstack_top, %eax + movl %eax, 4(%esp) + movl _signal_fault_addr, %eax + movl %eax, (%esp) + call _memory_protection_error + leave + ret +.globl _divide_by_zero_signal_handler_impl + .def _divide_by_zero_signal_handler_impl; .scl 2; .type 32; .endef +_divide_by_zero_signal_handler_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl _signal_callstack_top, %eax + movl %eax, (%esp) + call _divide_by_zero_error + leave + ret +.globl _misc_signal_handler_impl + .def _misc_signal_handler_impl; .scl 2; .type 32; .endef +_misc_signal_handler_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl _signal_callstack_top, %eax + movl %eax, 4(%esp) + movl _signal_number, %eax + movl %eax, (%esp) + call _signal_error + leave + ret +.globl _primitive_throw + .def _primitive_throw; .scl 2; .type 32; .endef +_primitive_throw: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_throw_impl + leave + ret + .def _primitive_throw_impl; .scl 3; .type 32; .endef +_primitive_throw_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + call _dpop + movl %eax, %ecx + movl _stack_chain, %eax + movl (%eax), %edx + movl %ecx, %eax + call _throw_impl + leave + ret + .def _dpop; .scl 3; .type 32; .endef +_dpop: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %esi, (%esp) + call _get + movl %eax, -4(%ebp) + subl $4, %esi + movl -4(%ebp), %eax + leave + ret + .def _get; .scl 3; .type 32; .endef +_get: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + movl (%eax), %eax + popl %ebp + ret +.globl _primitive_call_clear + .def _primitive_call_clear; .scl 2; .type 32; .endef +_primitive_call_clear: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_call_clear_impl + leave + ret + .def _primitive_call_clear_impl; .scl 3; .type 32; .endef +_primitive_call_clear_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl _stack_chain, %edx + movl 4(%edx), %edx + call _throw_impl + leave + ret +.globl _primitive_unimplemented2 + .def _primitive_unimplemented2; .scl 2; .type 32; .endef +_primitive_unimplemented2: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + call _not_implemented_error + leave + ret +.globl _primitive_unimplemented + .def _primitive_unimplemented; .scl 2; .type 32; .endef +_primitive_unimplemented: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_unimplemented_impl + leave + ret + .def _primitive_unimplemented_impl; .scl 3; .type 32; .endef +_primitive_unimplemented_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _not_implemented_error + leave + ret + .comm _console_open, 16 # 1 + .comm _userenv, 256 # 256 + .comm _T, 16 # 4 + .comm _stack_chain, 16 # 4 + .comm _ds_size, 16 # 4 + .comm _rs_size, 16 # 4 + .comm _stage2, 16 # 1 + .comm _profiling_p, 16 # 1 + .comm _signal_number, 16 # 4 + .comm _signal_fault_addr, 16 # 4 + .comm _signal_callstack_top, 16 # 4 + .comm _secure_gc, 16 # 1 + .comm _data_heap, 16 # 4 + .comm _cards_offset, 16 # 4 + .comm _newspace, 16 # 4 + .comm _nursery, 16 # 4 + .comm _gc_time, 16 # 8 + .comm _nursery_collections, 16 # 4 + .comm _aging_collections, 16 # 4 + .comm _cards_scanned, 16 # 4 + .comm _performing_gc, 16 # 1 + .comm _collecting_gen, 16 # 4 + .comm _collecting_aging_again, 16 # 1 + .comm _last_code_heap_scan, 16 # 4 + .comm _growing_data_heap, 16 # 1 + .comm _old_data_heap, 16 # 4 + .comm _gc_jmp, 208 # 208 + .comm _heap_scan_ptr, 16 # 4 + .comm _gc_off, 16 # 1 + .comm _gc_locals_region, 16 # 4 + .comm _gc_locals, 16 # 4 + .comm _extra_roots_region, 16 # 4 + .comm _extra_roots, 16 # 4 + .comm _bignum_zero, 16 # 4 + .comm _bignum_pos_one, 16 # 4 + .comm _bignum_neg_one, 16 # 4 + .comm _code_heap, 16 # 8 + .comm _data_relocation_base, 16 # 4 + .comm _code_relocation_base, 16 # 4 + .comm _posix_argc, 16 # 4 + .comm _posix_argv, 16 # 4 + .def _save_callstack_top; .scl 3; .type 32; .endef + .def _getpagesize; .scl 3; .type 32; .endef + .def _allot_array_4; .scl 3; .type 32; .endef + .def _print_obj; .scl 3; .type 32; .endef + .def _throw_impl; .scl 3; .type 32; .endef + .def _fix_callstack_top; .scl 3; .type 32; .endef + .def _fix_stacks; .scl 3; .type 32; .endef + .def _factorbug; .scl 3; .type 32; .endef + .def _exit; .scl 3; .type 32; .endef + .def ___getreent; .scl 3; .type 32; .endef + .def _fprintf; .scl 3; .type 32; .endef + .def _critical_error; .scl 3; .type 32; .endef + .def _type_error; .scl 3; .type 32; .endef + .section .drectve + + .ascii " -export:nursery,data" + .ascii " -export:cards_offset,data" + .ascii " -export:stack_chain,data" + .ascii " -export:userenv,data" diff --git a/vm/os-windows.c b/vm/os-windows.c index 1be41f8b57..664df9e774 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -215,7 +215,7 @@ void sleep_millis(DWORD msec) Sleep(msec); } -DECLARE_PRIMITIVE(set_os_envs) +DEFINE_PRIMITIVE(set_os_envs) { not_implemented_error(); } diff --git a/vm/primitives.c b/vm/primitives.c index 038a7d84a5..533fcebc9a 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -187,4 +187,5 @@ void *primitives[] = { primitive_resize_bit_array, primitive_resize_float_array, primitive_dll_validp, + primitive_unimplemented, }; diff --git a/vm/run.s b/vm/run.s new file mode 100644 index 0000000000..78b2adac84 --- /dev/null +++ b/vm/run.s @@ -0,0 +1,1511 @@ + .file "run.c" + .text +.globl _reset_datastack + .def _reset_datastack; .scl 2; .type 32; .endef +_reset_datastack: + pushl %ebp + movl %esp, %ebp + movl _stack_chain, %eax + movl 24(%eax), %eax + movl (%eax), %esi + subl $4, %esi + popl %ebp + ret +.globl _reset_retainstack + .def _reset_retainstack; .scl 2; .type 32; .endef +_reset_retainstack: + pushl %ebp + movl %esp, %ebp + movl _stack_chain, %eax + movl 28(%eax), %eax + movl (%eax), %edi + subl $4, %edi + popl %ebp + ret +.globl _fix_stacks + .def _fix_stacks; .scl 2; .type 32; .endef +_fix_stacks: + pushl %ebp + movl %esp, %ebp + leal 4(%esi), %eax + movl _stack_chain, %edx + movl 24(%edx), %edx + cmpl (%edx), %eax + jb L5 + leal 256(%esi), %eax + movl _stack_chain, %edx + movl 24(%edx), %edx + cmpl 8(%edx), %eax + jae L5 + jmp L4 +L5: + call _reset_datastack +L4: + leal 4(%edi), %eax + movl _stack_chain, %edx + movl 28(%edx), %edx + cmpl (%edx), %eax + jb L7 + leal 256(%edi), %eax + movl _stack_chain, %edx + movl 28(%edx), %edx + cmpl 8(%edx), %eax + jae L7 + jmp L3 +L7: + call _reset_retainstack +L3: + popl %ebp + ret +.globl _save_stacks + .def _save_stacks; .scl 2; .type 32; .endef +_save_stacks: + pushl %ebp + movl %esp, %ebp + cmpl $0, _stack_chain + je L8 + movl _stack_chain, %eax + movl %esi, 8(%eax) + movl _stack_chain, %eax + movl %edi, 12(%eax) +L8: + popl %ebp + ret +.globl _nest_stacks + .def _nest_stacks; .scl 2; .type 32; .endef +_nest_stacks: + pushl %ebp + movl %esp, %ebp + pushl %ebx + subl $20, %esp + movl $44, (%esp) + call _safe_malloc + movl %eax, -8(%ebp) + movl -8(%ebp), %eax + movl $-1, 4(%eax) + movl -8(%ebp), %eax + movl $-1, (%eax) + movl -8(%ebp), %eax + movl %esi, 16(%eax) + movl -8(%ebp), %eax + movl %edi, 20(%eax) + movl -8(%ebp), %edx + movl _userenv+8, %eax + movl %eax, 36(%edx) + movl -8(%ebp), %edx + movl _userenv+4, %eax + movl %eax, 32(%edx) + movl -8(%ebp), %ebx + movl _ds_size, %eax + movl %eax, (%esp) + call _alloc_segment + movl %eax, 24(%ebx) + movl -8(%ebp), %ebx + movl _rs_size, %eax + movl %eax, (%esp) + call _alloc_segment + movl %eax, 28(%ebx) + movl -8(%ebp), %edx + movl _stack_chain, %eax + movl %eax, 40(%edx) + movl -8(%ebp), %eax + movl %eax, _stack_chain + call _reset_datastack + call _reset_retainstack + addl $20, %esp + popl %ebx + popl %ebp + ret +.globl _unnest_stacks + .def _unnest_stacks; .scl 2; .type 32; .endef +_unnest_stacks: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl _stack_chain, %eax + movl 24(%eax), %eax + movl %eax, (%esp) + call _dealloc_segment + movl _stack_chain, %eax + movl 28(%eax), %eax + movl %eax, (%esp) + call _dealloc_segment + movl _stack_chain, %eax + movl 16(%eax), %esi + movl _stack_chain, %eax + movl 20(%eax), %edi + movl _stack_chain, %eax + movl 36(%eax), %eax + movl %eax, _userenv+8 + movl _stack_chain, %eax + movl 32(%eax), %eax + movl %eax, _userenv+4 + movl _stack_chain, %eax + movl %eax, -4(%ebp) + movl -4(%ebp), %eax + movl 40(%eax), %eax + movl %eax, _stack_chain + movl -4(%ebp), %eax + movl %eax, (%esp) + call _free + leave + ret +.globl _init_stacks + .def _init_stacks; .scl 2; .type 32; .endef +_init_stacks: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + movl %eax, _ds_size + movl 12(%ebp), %eax + movl %eax, _rs_size + movl $0, _stack_chain + popl %ebp + ret +.globl _primitive_drop + .def _primitive_drop; .scl 2; .type 32; .endef +_primitive_drop: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_drop_impl + leave + ret + .def _primitive_drop_impl; .scl 3; .type 32; .endef +_primitive_drop_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + leave + ret + .def _dpop; .scl 3; .type 32; .endef +_dpop: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %esi, (%esp) + call _get + movl %eax, -4(%ebp) + subl $4, %esi + movl -4(%ebp), %eax + leave + ret + .def _get; .scl 3; .type 32; .endef +_get: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + movl (%eax), %eax + popl %ebp + ret +.globl _primitive_2drop + .def _primitive_2drop; .scl 2; .type 32; .endef +_primitive_2drop: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_2drop_impl + leave + ret + .def _primitive_2drop_impl; .scl 3; .type 32; .endef +_primitive_2drop_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esi + popl %ebp + ret +.globl _primitive_3drop + .def _primitive_3drop; .scl 2; .type 32; .endef +_primitive_3drop: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_3drop_impl + leave + ret + .def _primitive_3drop_impl; .scl 3; .type 32; .endef +_primitive_3drop_impl: + pushl %ebp + movl %esp, %ebp + subl $12, %esi + popl %ebp + ret +.globl _primitive_dup + .def _primitive_dup; .scl 2; .type 32; .endef +_primitive_dup: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_dup_impl + leave + ret + .def _primitive_dup_impl; .scl 3; .type 32; .endef +_primitive_dup_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpeek + movl %eax, (%esp) + call _dpush + leave + ret + .def _dpush; .scl 3; .type 32; .endef +_dpush: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + addl $4, %esi + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + leave + ret + .def _put; .scl 3; .type 32; .endef +_put: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %edx + movl 12(%ebp), %eax + movl %eax, (%edx) + popl %ebp + ret + .def _dpeek; .scl 3; .type 32; .endef +_dpeek: + pushl %ebp + movl %esp, %ebp + subl $4, %esp + movl %esi, (%esp) + call _get + leave + ret +.globl _primitive_2dup + .def _primitive_2dup; .scl 2; .type 32; .endef +_primitive_2dup: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_2dup_impl + leave + ret + .def _primitive_2dup_impl; .scl 3; .type 32; .endef +_primitive_2dup_impl: + pushl %ebp + movl %esp, %ebp + subl $16, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + addl $8, %esi + movl -8(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + leave + ret +.globl _primitive_3dup + .def _primitive_3dup; .scl 2; .type 32; .endef +_primitive_3dup: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_3dup_impl + leave + ret + .def _primitive_3dup_impl; .scl 3; .type 32; .endef +_primitive_3dup_impl: + pushl %ebp + movl %esp, %ebp + subl $20, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -12(%ebp) + addl $12, %esi + movl -4(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -8(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -12(%ebp), %eax + movl %eax, 4(%esp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _put + leave + ret +.globl _primitive_rot + .def _primitive_rot; .scl 2; .type 32; .endef +_primitive_rot: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_rot_impl + leave + ret + .def _primitive_rot_impl; .scl 3; .type 32; .endef +_primitive_rot_impl: + pushl %ebp + movl %esp, %ebp + subl $20, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -12(%ebp) + movl -12(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -8(%ebp), %eax + movl %eax, 4(%esp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _put + leave + ret +.globl _primitive__rot + .def _primitive__rot; .scl 2; .type 32; .endef +_primitive__rot: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive__rot_impl + leave + ret + .def _primitive__rot_impl; .scl 3; .type 32; .endef +_primitive__rot_impl: + pushl %ebp + movl %esp, %ebp + subl $20, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -12(%ebp) + movl -8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -12(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _put + leave + ret +.globl _primitive_dupd + .def _primitive_dupd; .scl 2; .type 32; .endef +_primitive_dupd: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_dupd_impl + leave + ret + .def _primitive_dupd_impl; .scl 3; .type 32; .endef +_primitive_dupd_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + movl -8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -8(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, (%esp) + call _dpush + leave + ret +.globl _primitive_swapd + .def _primitive_swapd; .scl 2; .type 32; .endef +_primitive_swapd: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_swapd_impl + leave + ret + .def _primitive_swapd_impl; .scl 3; .type 32; .endef +_primitive_swapd_impl: + pushl %ebp + movl %esp, %ebp + subl $16, %esp + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -4(%ebp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + movl -8(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + leal -8(%esi), %eax + movl %eax, (%esp) + call _put + leave + ret +.globl _primitive_nip + .def _primitive_nip; .scl 2; .type 32; .endef +_primitive_nip: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_nip_impl + leave + ret + .def _primitive_nip_impl; .scl 3; .type 32; .endef +_primitive_nip_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, -4(%ebp) + movl -4(%ebp), %eax + movl %eax, (%esp) + call _drepl + leave + ret + .def _drepl; .scl 3; .type 32; .endef +_drepl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + leave + ret +.globl _primitive_2nip + .def _primitive_2nip; .scl 2; .type 32; .endef +_primitive_2nip: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_2nip_impl + leave + ret + .def _primitive_2nip_impl; .scl 3; .type 32; .endef +_primitive_2nip_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpeek + movl %eax, -4(%ebp) + subl $8, %esi + movl -4(%ebp), %eax + movl %eax, (%esp) + call _drepl + leave + ret +.globl _primitive_tuck + .def _primitive_tuck; .scl 2; .type 32; .endef +_primitive_tuck: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_tuck_impl + leave + ret + .def _primitive_tuck_impl; .scl 3; .type 32; .endef +_primitive_tuck_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + movl -8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, (%esp) + call _dpush + leave + ret +.globl _primitive_over + .def _primitive_over; .scl 2; .type 32; .endef +_primitive_over: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_over_impl + leave + ret + .def _primitive_over_impl; .scl 3; .type 32; .endef +_primitive_over_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, (%esp) + call _dpush + leave + ret +.globl _primitive_pick + .def _primitive_pick; .scl 2; .type 32; .endef +_primitive_pick: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_pick_impl + leave + ret + .def _primitive_pick_impl; .scl 3; .type 32; .endef +_primitive_pick_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + leal -8(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, (%esp) + call _dpush + leave + ret +.globl _primitive_swap + .def _primitive_swap; .scl 2; .type 32; .endef +_primitive_swap: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_swap_impl + leave + ret + .def _primitive_swap_impl; .scl 3; .type 32; .endef +_primitive_swap_impl: + pushl %ebp + movl %esp, %ebp + subl $16, %esp + call _dpeek + movl %eax, -4(%ebp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _get + movl %eax, -8(%ebp) + movl -8(%ebp), %eax + movl %eax, 4(%esp) + movl %esi, (%esp) + call _put + movl -4(%ebp), %eax + movl %eax, 4(%esp) + leal -4(%esi), %eax + movl %eax, (%esp) + call _put + leave + ret +.globl _primitive_to_r + .def _primitive_to_r; .scl 2; .type 32; .endef +_primitive_to_r: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_to_r_impl + leave + ret + .def _primitive_to_r_impl; .scl 3; .type 32; .endef +_primitive_to_r_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, (%esp) + call _rpush + leave + ret + .def _rpush; .scl 3; .type 32; .endef +_rpush: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + addl $4, %edi + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl %edi, (%esp) + call _put + leave + ret +.globl _primitive_from_r + .def _primitive_from_r; .scl 2; .type 32; .endef +_primitive_from_r: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_from_r_impl + leave + ret + .def _primitive_from_r_impl; .scl 3; .type 32; .endef +_primitive_from_r_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _rpop + movl %eax, (%esp) + call _dpush + leave + ret + .def _rpop; .scl 3; .type 32; .endef +_rpop: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %edi, (%esp) + call _get + movl %eax, -4(%ebp) + subl $4, %edi + movl -4(%ebp), %eax + leave + ret +.globl _stack_to_array + .def _stack_to_array; .scl 2; .type 32; .endef +_stack_to_array: + pushl %ebp + movl %esp, %ebp + subl $40, %esp + movl 8(%ebp), %edx + movl 12(%ebp), %eax + subl %edx, %eax + addl $4, %eax + movl %eax, -4(%ebp) + cmpl $0, -4(%ebp) + jns L58 + movl $0, -12(%ebp) + jmp L57 +L58: + movl -4(%ebp), %eax + movl %eax, -16(%ebp) + cmpl $0, -16(%ebp) + jns L60 + addl $3, -16(%ebp) +L60: + movl -16(%ebp), %eax + sarl $2, %eax + movl %eax, 4(%esp) + movl $8, (%esp) + call _allot_array_internal + movl %eax, -8(%ebp) + movl -4(%ebp), %eax + movl %eax, 8(%esp) + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl -8(%ebp), %eax + addl $8, %eax + movl %eax, (%esp) + call _memcpy + movl -8(%ebp), %eax + movl %eax, (%esp) + call _tag_object + movl %eax, (%esp) + call _dpush + movl $1, -12(%ebp) +L57: + movl -12(%ebp), %eax + leave + ret + .def _tag_object; .scl 3; .type 32; .endef +_tag_object: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + andl $-8, %eax + orl $3, %eax + popl %ebp + ret +.globl _primitive_datastack + .def _primitive_datastack; .scl 2; .type 32; .endef +_primitive_datastack: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_datastack_impl + leave + ret + .def _primitive_datastack_impl; .scl 3; .type 32; .endef +_primitive_datastack_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl %esi, 4(%esp) + movl _stack_chain, %eax + movl 24(%eax), %eax + movl (%eax), %eax + movl %eax, (%esp) + call _stack_to_array + testb %al, %al + jne L63 + movl $0, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $11, (%esp) + call _general_error +L63: + leave + ret +.globl _primitive_retainstack + .def _primitive_retainstack; .scl 2; .type 32; .endef +_primitive_retainstack: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_retainstack_impl + leave + ret + .def _primitive_retainstack_impl; .scl 3; .type 32; .endef +_primitive_retainstack_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl %edi, 4(%esp) + movl _stack_chain, %eax + movl 28(%eax), %eax + movl (%eax), %eax + movl %eax, (%esp) + call _stack_to_array + testb %al, %al + jne L66 + movl $0, 12(%esp) + movl $7, 8(%esp) + movl $7, 4(%esp) + movl $13, (%esp) + call _general_error +L66: + leave + ret +.globl _array_to_stack + .def _array_to_stack; .scl 2; .type 32; .endef +_array_to_stack: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl 8(%ebp), %eax + movl %eax, (%esp) + call _array_capacity + sall $2, %eax + movl %eax, -4(%ebp) + movl -4(%ebp), %eax + movl %eax, 8(%esp) + movl 8(%ebp), %eax + addl $8, %eax + movl %eax, 4(%esp) + movl 12(%ebp), %eax + movl %eax, (%esp) + call _memcpy + movl -4(%ebp), %eax + addl 12(%ebp), %eax + subl $4, %eax + leave + ret + .def _array_capacity; .scl 3; .type 32; .endef +_array_capacity: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + movl 4(%eax), %eax + shrl $3, %eax + popl %ebp + ret +.globl _primitive_set_datastack + .def _primitive_set_datastack; .scl 2; .type 32; .endef +_primitive_set_datastack: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_set_datastack_impl + leave + ret + .def _primitive_set_datastack_impl; .scl 3; .type 32; .endef +_primitive_set_datastack_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, (%esp) + call _untag_array + movl %eax, %edx + movl _stack_chain, %eax + movl 24(%eax), %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl %edx, (%esp) + call _array_to_stack + movl %eax, %esi + leave + ret + .def _untag_array; .scl 3; .type 32; .endef +_untag_array: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl 8(%ebp), %eax + movl %eax, 4(%esp) + movl $8, (%esp) + call _type_check + movl 8(%ebp), %eax + movl %eax, (%esp) + call _untag_object + leave + ret + .def _untag_object; .scl 3; .type 32; .endef +_untag_object: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + andl $-8, %eax + popl %ebp + ret + .def _type_check; .scl 3; .type 32; .endef +_type_check: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl 12(%ebp), %eax + movl %eax, (%esp) + call _type_of + cmpl 8(%ebp), %eax + je L74 + movl 12(%ebp), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %eax + movl %eax, (%esp) + call _type_error +L74: + leave + ret + .def _type_of; .scl 3; .type 32; .endef +_type_of: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + movl 8(%ebp), %eax + andl $7, %eax + movl %eax, -4(%ebp) + cmpl $3, -4(%ebp) + jne L77 + movl 8(%ebp), %eax + movl %eax, (%esp) + call _object_type + movl %eax, -8(%ebp) + jmp L76 +L77: + movl -4(%ebp), %eax + movl %eax, -8(%ebp) +L76: + movl -8(%ebp), %eax + leave + ret + .def _object_type; .scl 3; .type 32; .endef +_object_type: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl 8(%ebp), %eax + andl $-8, %eax + movl %eax, (%esp) + call _get + movl %eax, (%esp) + call _untag_header + leave + ret + .def _untag_header; .scl 3; .type 32; .endef +_untag_header: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + shrl $3, %eax + popl %ebp + ret +.globl _primitive_set_retainstack + .def _primitive_set_retainstack; .scl 2; .type 32; .endef +_primitive_set_retainstack: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_set_retainstack_impl + leave + ret + .def _primitive_set_retainstack_impl; .scl 3; .type 32; .endef +_primitive_set_retainstack_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, (%esp) + call _untag_array + movl %eax, %edx + movl _stack_chain, %eax + movl 28(%eax), %eax + movl (%eax), %eax + movl %eax, 4(%esp) + movl %edx, (%esp) + call _array_to_stack + movl %eax, %edi + leave + ret +.globl _primitive_getenv + .def _primitive_getenv; .scl 2; .type 32; .endef +_primitive_getenv: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_getenv_impl + leave + ret + .def _primitive_getenv_impl; .scl 3; .type 32; .endef +_primitive_getenv_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpeek + movl %eax, (%esp) + call _untag_fixnum_fast + movl %eax, -4(%ebp) + movl -4(%ebp), %eax + movl _userenv(,%eax,4), %eax + movl %eax, (%esp) + call _drepl + leave + ret + .def _untag_fixnum_fast; .scl 3; .type 32; .endef +_untag_fixnum_fast: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + sarl $3, %eax + popl %ebp + ret +.globl _primitive_setenv + .def _primitive_setenv; .scl 2; .type 32; .endef +_primitive_setenv: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_setenv_impl + leave + ret + .def _primitive_setenv_impl; .scl 3; .type 32; .endef +_primitive_setenv_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpop + movl %eax, (%esp) + call _untag_fixnum_fast + movl %eax, -4(%ebp) + call _dpop + movl %eax, -8(%ebp) + movl -4(%ebp), %edx + movl -8(%ebp), %eax + movl %eax, _userenv(,%edx,4) + leave + ret +.globl _primitive_exit + .def _primitive_exit; .scl 2; .type 32; .endef +_primitive_exit: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_exit_impl + leave + ret + .def _primitive_exit_impl; .scl 3; .type 32; .endef +_primitive_exit_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, (%esp) + call _to_fixnum + movl %eax, (%esp) + call _exit +.globl _primitive_os_env + .def _primitive_os_env; .scl 2; .type 32; .endef +_primitive_os_env: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_os_env_impl + leave + ret + .def _primitive_os_env_impl; .scl 3; .type 32; .endef +_primitive_os_env_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _unbox_char_string + movl %eax, -4(%ebp) + movl -4(%ebp), %eax + movl %eax, (%esp) + call _getenv + movl %eax, -8(%ebp) + cmpl $0, -8(%ebp) + jne L92 + movl $7, (%esp) + call _dpush + jmp L91 +L92: + movl -8(%ebp), %eax + movl %eax, (%esp) + call _box_char_string +L91: + leave + ret +.globl _primitive_eq + .def _primitive_eq; .scl 2; .type 32; .endef +_primitive_eq: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_eq_impl + leave + ret + .def _primitive_eq_impl; .scl 3; .type 32; .endef +_primitive_eq_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpop + movl %eax, -4(%ebp) + call _dpeek + movl %eax, -8(%ebp) + movl -4(%ebp), %eax + cmpl -8(%ebp), %eax + jne L96 + movl _T, %eax + movl %eax, -12(%ebp) + jmp L97 +L96: + movl $7, -12(%ebp) +L97: + movl -12(%ebp), %eax + movl %eax, (%esp) + call _drepl + leave + ret +.globl _primitive_millis + .def _primitive_millis; .scl 2; .type 32; .endef +_primitive_millis: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_millis_impl + leave + ret + .def _primitive_millis_impl; .scl 3; .type 32; .endef +_primitive_millis_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _current_millis + movl %eax, (%esp) + movl %edx, 4(%esp) + call _box_unsigned_8 + leave + ret +.globl _primitive_sleep + .def _primitive_sleep; .scl 2; .type 32; .endef +_primitive_sleep: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_sleep_impl + leave + ret + .def _primitive_sleep_impl; .scl 3; .type 32; .endef +_primitive_sleep_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpop + movl %eax, (%esp) + call _to_cell + movl %eax, (%esp) + call _sleep_millis + leave + ret +.globl _primitive_tag + .def _primitive_tag; .scl 2; .type 32; .endef +_primitive_tag: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_tag_impl + leave + ret + .def _primitive_tag_impl; .scl 3; .type 32; .endef +_primitive_tag_impl: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + call _dpeek + andl $7, %eax + movl %eax, (%esp) + call _tag_fixnum + movl %eax, (%esp) + call _drepl + leave + ret + .def _tag_fixnum; .scl 3; .type 32; .endef +_tag_fixnum: + pushl %ebp + movl %esp, %ebp + movl 8(%ebp), %eax + sall $3, %eax + andl $-8, %eax + popl %ebp + ret +.globl _primitive_slot + .def _primitive_slot; .scl 2; .type 32; .endef +_primitive_slot: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_slot_impl + leave + ret + .def _primitive_slot_impl; .scl 3; .type 32; .endef +_primitive_slot_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpop + movl %eax, (%esp) + call _untag_fixnum_fast + movl %eax, -4(%ebp) + call _dpop + movl %eax, -8(%ebp) + movl -8(%ebp), %edx + andl $-8, %edx + movl -4(%ebp), %eax + sall $2, %eax + leal (%edx,%eax), %eax + movl %eax, (%esp) + call _get + movl %eax, (%esp) + call _dpush + leave + ret +.globl _primitive_set_slot + .def _primitive_set_slot; .scl 2; .type 32; .endef +_primitive_set_slot: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl %eax, -4(%ebp) + movl %edx, -8(%ebp) + movl -8(%ebp), %eax + call _save_callstack_top + call _primitive_set_slot_impl + leave + ret + .def _primitive_set_slot_impl; .scl 3; .type 32; .endef +_primitive_set_slot_impl: + pushl %ebp + movl %esp, %ebp + subl $24, %esp + call _dpop + movl %eax, (%esp) + call _untag_fixnum_fast + movl %eax, -4(%ebp) + call _dpop + movl %eax, -8(%ebp) + call _dpop + movl %eax, -12(%ebp) + movl -12(%ebp), %eax + movl %eax, 8(%esp) + movl -4(%ebp), %eax + movl %eax, 4(%esp) + movl -8(%ebp), %eax + movl %eax, (%esp) + call _set_slot + leave + ret + .def _set_slot; .scl 3; .type 32; .endef +_set_slot: + pushl %ebp + movl %esp, %ebp + subl $8, %esp + movl 16(%ebp), %eax + movl %eax, 4(%esp) + movl 8(%ebp), %edx + andl $-8, %edx + movl 12(%ebp), %eax + sall $2, %eax + leal (%edx,%eax), %eax + movl %eax, (%esp) + call _put + movl 8(%ebp), %eax + movl %eax, (%esp) + call _write_barrier + leave + ret + .def _write_barrier; .scl 3; .type 32; .endef +_write_barrier: + pushl %ebp + movl %esp, %ebp + subl $4, %esp + movl 8(%ebp), %eax + shrl $6, %eax + addl _cards_offset, %eax + movl %eax, -4(%ebp) + movl -4(%ebp), %edx + movl -4(%ebp), %eax + movzbl (%eax), %eax + orb $-64, %al + movb %al, (%edx) + leave + ret + .comm _console_open, 16 # 1 + .comm _userenv, 256 # 256 + .comm _T, 16 # 4 + .comm _stack_chain, 16 # 4 + .comm _ds_size, 16 # 4 + .comm _rs_size, 16 # 4 + .comm _stage2, 16 # 1 + .comm _profiling_p, 16 # 1 + .comm _signal_number, 16 # 4 + .comm _signal_fault_addr, 16 # 4 + .comm _signal_callstack_top, 16 # 4 + .comm _secure_gc, 16 # 1 + .comm _data_heap, 16 # 4 + .comm _cards_offset, 16 # 4 + .comm _newspace, 16 # 4 + .comm _nursery, 16 # 4 + .comm _gc_time, 16 # 8 + .comm _nursery_collections, 16 # 4 + .comm _aging_collections, 16 # 4 + .comm _cards_scanned, 16 # 4 + .comm _performing_gc, 16 # 1 + .comm _collecting_gen, 16 # 4 + .comm _collecting_aging_again, 16 # 1 + .comm _last_code_heap_scan, 16 # 4 + .comm _growing_data_heap, 16 # 1 + .comm _old_data_heap, 16 # 4 + .comm _gc_jmp, 208 # 208 + .comm _heap_scan_ptr, 16 # 4 + .comm _gc_off, 16 # 1 + .comm _gc_locals_region, 16 # 4 + .comm _gc_locals, 16 # 4 + .comm _extra_roots_region, 16 # 4 + .comm _extra_roots, 16 # 4 + .comm _bignum_zero, 16 # 4 + .comm _bignum_pos_one, 16 # 4 + .comm _bignum_neg_one, 16 # 4 + .comm _code_heap, 16 # 8 + .comm _data_relocation_base, 16 # 4 + .comm _code_relocation_base, 16 # 4 + .comm _posix_argc, 16 # 4 + .comm _posix_argv, 16 # 4 + .def _sleep_millis; .scl 3; .type 32; .endef + .def _current_millis; .scl 3; .type 32; .endef + .def _getenv; .scl 3; .type 32; .endef + .def _exit; .scl 3; .type 32; .endef + .def _general_error; .scl 3; .type 32; .endef + .def _memcpy; .scl 3; .type 32; .endef + .def _allot_array_internal; .scl 3; .type 32; .endef + .def _save_callstack_top; .scl 3; .type 32; .endef + .def _free; .scl 3; .type 32; .endef + .def _dealloc_segment; .scl 3; .type 32; .endef + .def _alloc_segment; .scl 3; .type 32; .endef + .def _safe_malloc; .scl 3; .type 32; .endef + .def _type_error; .scl 3; .type 32; .endef + .section .drectve + + .ascii " -export:nursery,data" + .ascii " -export:cards_offset,data" + .ascii " -export:stack_chain,data" + .ascii " -export:userenv,data" + .ascii " -export:unnest_stacks" + .ascii " -export:nest_stacks" + .ascii " -export:save_stacks" From fcb78822b271c72cd6f14d314e260c0624ca86ab Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 00:16:05 -0500 Subject: [PATCH 08/14] Remove annoying and useless shadowing warnings --- core/parser/parser-docs.factor | 4 ---- core/parser/parser.factor | 16 +--------------- 2 files changed, 1 insertion(+), 19 deletions(-) diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 5adecca206..d11f036445 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -284,10 +284,6 @@ HELP: use HELP: in { $var-description "A variable holding the name of the current vocabulary for new definitions." } ; -HELP: shadow-warnings -{ $values { "vocab" "an assoc mapping strings to words" } { "vocabs" "a sequence of assocs" } } -{ $description "Tests if any keys in " { $snippet "vocab" } " shadow keys in the elements of " { $snippet "vocabs" } ", and if so, prints a warning message. These warning messages can be disabled by setting " { $link parser-notes } " to " { $link f } "." } ; - HELP: (use+) { $values { "vocab" "an assoc mapping strings to words" } } { $description "Adds an assoc at the front of the search path." } diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 7db7e46b3a..6d091fd1c0 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -191,22 +191,8 @@ SYMBOL: in : word/vocab% ( word -- ) "(" % dup word-vocabulary % " " % word-name % ")" % ; -: shadow-warning ( new old -- ) - 2dup eq? [ - 2drop - ] [ - [ word/vocab% " shadowed by " % word/vocab% ] "" make - note. - ] if ; - -: shadow-warnings ( vocab vocabs -- ) - [ - swapd assoc-stack dup - [ shadow-warning ] [ 2drop ] if - ] curry assoc-each ; - : (use+) ( vocab -- ) - vocab-words use get 2dup shadow-warnings push ; + vocab-words use get push ; : use+ ( vocab -- ) load-vocab (use+) ; From 457fea23f7ce862e6cebf9ffc0fa648c35b53a1b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 00:16:15 -0500 Subject: [PATCH 09/14] Improved word completion --- extra/ui/tools/listener/listener.factor | 30 +++++++++++++++---------- 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 52c3d2de42..91f7b0ec5d 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -7,7 +7,7 @@ ui.gadgets ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words prettyprint listener debugger threads boxes concurrency.flags -math arrays generic accessors ; +math arrays generic accessors combinators ; IN: ui.tools.listener TUPLE: listener-gadget input output stack ; @@ -101,26 +101,32 @@ M: listener-operation invoke-command ( target command -- ) : clear-stack ( listener -- ) [ clear ] swap (call-listener) ; -GENERIC# word-completion-string 1 ( word listener -- string ) +GENERIC: word-completion-string ( word -- string ) + +M: word word-completion-string + word-name ; M: method-body word-completion-string - >r "method-generic" word-prop r> word-completion-string ; + "method-generic" word-prop word-completion-string ; USE: generic.standard.engines.tuple M: tuple-dispatch-engine-word word-completion-string - >r "engine-generic" word-prop r> word-completion-string ; + "engine-generic" word-prop word-completion-string ; -M: word word-completion-string ( word listener -- string ) - >r [ word-name ] [ word-vocabulary ] bi dup vocab-words r> - input>> interactor-use memq? - [ drop ] [ [ "USE: " % % " " % % ] "" make ] if ; +: use-if-necessary ( word seq -- ) + >r word-vocabulary vocab-words r> + { + { [ dup not ] [ 2drop ] } + { [ 2dup memq? ] [ 2drop ] } + { [ t ] [ push ] } + } cond ; : insert-word ( word -- ) - get-workspace - workspace-listener - [ word-completion-string ] keep - input>> user-input ; + get-workspace workspace-listener input>> + [ >r word-completion-string r> user-input ] + [ interactor-use use-if-necessary ] + 2bi ; : quot-action ( interactor -- lines ) dup control-value From b0e322bffc2e59e38e4b373d1b4922b2fc933be4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Apr 2008 14:19:29 -0500 Subject: [PATCH 10/14] refactor db some --- extra/db/db.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 3cade1a895..1a1a18c942 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -41,6 +41,7 @@ TUPLE: simple-statement < statement ; TUPLE: prepared-statement < statement ; TUPLE: nonthrowable-statement < statement ; TUPLE: throwable-statement < statement ; + : make-nonthrowable ( obj -- obj' ) dup sequence? [ [ make-nonthrowable ] map @@ -49,6 +50,7 @@ TUPLE: throwable-statement < statement ; ] if ; TUPLE: result-set sql in-params out-params handle n max ; + : construct-statement ( sql in out class -- statement ) construct-empty swap >>out-params @@ -101,10 +103,6 @@ M: nonthrowable-statement execute-statement ( statement -- ) swap >>in-params swap >>sql ; - ! >r >r { sql>> in-params>> out-params>> } get-slots r> - ! { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set - ! construct r> construct-delegate ; - : sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; From 4180472ae9ac1b2dc4e6aff339f5b21f389867de Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 14:45:32 -0500 Subject: [PATCH 11/14] Fix listener tests --- extra/ui/tools/listener/listener-tests.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor index 13ce834df3..cc218533d8 100755 --- a/extra/ui/tools/listener/listener-tests.factor +++ b/extra/ui/tools/listener/listener-tests.factor @@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor ui.tools.listener hashtables kernel namespaces parser sequences tools.test ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.panes vocabs words tools.test.ui slots.private -threads ; +threads arrays generic ; IN: ui.tools.listener.tests [ f ] [ "word" source-editor command-map empty? ] unit-test @@ -13,11 +13,11 @@ IN: ui.tools.listener.tests "listener" get [ [ "dup" ] [ - \ dup "listener" get word-completion-string + \ dup word-completion-string ] unit-test - [ "USE: slots.private slot" ] - [ \ slot "listener" get word-completion-string ] unit-test + [ "equal?" ] + [ \ array \ equal? method word-completion-string ] unit-test "i" set From a24e2786c1a87788e1533d4e33209b17aa642a71 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Apr 2008 14:49:31 -0500 Subject: [PATCH 12/14] remove special case for netbsd64 gcc --- build-support/factor.sh | 5 ----- 1 file changed, 5 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index 476e885257..ea0c35aa83 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -89,11 +89,6 @@ set_md5sum() { set_gcc() { case $OS in openbsd) ensure_program_installed egcc; CC=egcc;; - netbsd) if [[ $WORD -eq 64 ]] ; then - CC=/usr/pkg/gcc34/bin/gcc - else - CC=gcc - fi ;; *) CC=gcc;; esac } From 719fc91432e8ec49a1c956bc8bb4bd95e7a4d63a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Apr 2008 15:27:35 -0500 Subject: [PATCH 13/14] fix sqlite --- extra/db/sqlite/sqlite.factor | 4 ++-- extra/db/tuples/tuples-tests.factor | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index e0930f3ba8..11c0150cd2 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -70,7 +70,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- ) dup zero? [ "last-id failed" throw ] when ; M: sqlite-db insert-tuple* ( tuple statement -- ) - execute-statement last-insert-id >>primary-key drop ; + execute-statement last-insert-id swap set-primary-key ; M: sqlite-result-set #columns ( result-set -- n ) handle>> sqlite-#columns ; @@ -168,7 +168,7 @@ M: sqlite-db ( tuple class -- statement ) [ dup column-name>> 0% 2, ] interleave " from " 0% 0% - [ column-name>> swap get-slot-named ] with subset + [ slot-name>> swap get-slot-named ] with subset dup empty? [ drop ] [ where-clause ] if ";" 0% ] sqlite-make ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 6b61981119..951ded32ea 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -260,10 +260,10 @@ C: secret ! [ test-random-id ] test-sqlite [ native-person-schema test-tuples ] test-sqlite [ assigned-person-schema test-tuples ] test-sqlite -! [ assigned-person-schema test-repeated-insert ] test-sqlite -! [ native-person-schema test-tuples ] test-postgresql -! [ assigned-person-schema test-tuples ] test-postgresql -! [ assigned-person-schema test-repeated-insert ] test-postgresql + [ assigned-person-schema test-repeated-insert ] test-sqlite + [ native-person-schema test-tuples ] test-postgresql + [ assigned-person-schema test-tuples ] test-postgresql + [ assigned-person-schema test-repeated-insert ] test-postgresql ! \ insert-tuple must-infer ! \ update-tuple must-infer From 3164cda6fb4dc8541c0154518321ca946245e54d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Apr 2008 15:45:08 -0500 Subject: [PATCH 14/14] Remove bogus files --- vm/data_gc.h | 4 +- vm/errors.s | 687 ----------------------- vm/run.s | 1511 -------------------------------------------------- 3 files changed, 2 insertions(+), 2200 deletions(-) delete mode 100644 vm/errors.s delete mode 100644 vm/run.s diff --git a/vm/data_gc.h b/vm/data_gc.h index 0adcf0ca39..d3b8b6e39e 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -315,8 +315,6 @@ INLINE void* allot_object(CELL type, CELL a) { CELL *object; - /* If the object is bigger than the nursery, allocate it in - tenured space */ if(nursery->size - ALLOT_BUFFER_ZONE > a) { /* If there is insufficient room, collect the nursery */ @@ -325,6 +323,8 @@ INLINE void* allot_object(CELL type, CELL a) object = allot_zone(nursery,a); } + /* If the object is bigger than the nursery, allocate it in + tenured space */ else { F_ZONE *tenured = &data_heap->generations[TENURED]; diff --git a/vm/errors.s b/vm/errors.s deleted file mode 100644 index d6b3bdb6e5..0000000000 --- a/vm/errors.s +++ /dev/null @@ -1,687 +0,0 @@ - .file "errors.c" - .section .rdata,"dr" -LC0: - .ascii "fatal_error: %s %lx\12\0" - .text -.globl _fatal_error - .def _fatal_error; .scl 2; .type 32; .endef -_fatal_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call ___getreent - movl %eax, %edx - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl 8(%ebp), %eax - movl %eax, 8(%esp) - movl $LC0, 4(%esp) - movl 12(%edx), %eax - movl %eax, (%esp) - call _fprintf - movl $1, (%esp) - call _exit - .section .rdata,"dr" - .align 4 -LC1: - .ascii "You have triggered a bug in Factor. Please report.\12\0" -LC2: - .ascii "critical_error: %s %lx\12\0" - .text -.globl _critical_error - .def _critical_error; .scl 2; .type 32; .endef -_critical_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call ___getreent - movl $LC1, 4(%esp) - movl 12(%eax), %eax - movl %eax, (%esp) - call _fprintf - call ___getreent - movl %eax, %edx - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl 8(%ebp), %eax - movl %eax, 8(%esp) - movl $LC2, 4(%esp) - movl 12(%edx), %eax - movl %eax, (%esp) - call _fprintf - call _factorbug - leave - ret - .section .rdata,"dr" -LC3: - .ascii "early_error: \0" -LC4: - .ascii "\12\0" - .text -.globl _throw_error - .def _throw_error; .scl 2; .type 32; .endef -_throw_error: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - cmpl $7, _userenv+20 - je L4 - movb $0, _gc_off - movl _gc_locals_region, %eax - movl (%eax), %eax - subl $4, %eax - movl %eax, _gc_locals - movl _extra_roots_region, %eax - movl (%eax), %eax - subl $4, %eax - movl %eax, _extra_roots - call _fix_stacks - movl 8(%ebp), %eax - movl %eax, (%esp) - call _dpush - cmpl $0, 12(%ebp) - je L5 - movl _stack_chain, %eax - movl 4(%eax), %eax - movl %eax, 4(%esp) - movl 12(%ebp), %eax - movl %eax, (%esp) - call _fix_callstack_top - movl %eax, 12(%ebp) - jmp L6 -L5: - movl _stack_chain, %eax - movl (%eax), %eax - movl %eax, 12(%ebp) -L6: - movl 12(%ebp), %edx - movl _userenv+20, %eax - call _throw_impl - jmp L3 -L4: - call ___getreent - movl $LC1, 4(%esp) - movl 12(%eax), %eax - movl %eax, (%esp) - call _fprintf - call ___getreent - movl $LC3, 4(%esp) - movl 12(%eax), %eax - movl %eax, (%esp) - call _fprintf - movl 8(%ebp), %eax - movl %eax, (%esp) - call _print_obj - call ___getreent - movl $LC4, 4(%esp) - movl 12(%eax), %eax - movl %eax, (%esp) - call _fprintf - call _factorbug -L3: - leave - ret - .def _dpush; .scl 3; .type 32; .endef -_dpush: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - addl $4, %esi - movl 8(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - leave - ret - .def _put; .scl 3; .type 32; .endef -_put: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %edx - movl 12(%ebp), %eax - movl %eax, (%edx) - popl %ebp - ret -.globl _general_error - .def _general_error; .scl 2; .type 32; .endef -_general_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl 8(%ebp), %eax - movl %eax, (%esp) - call _tag_fixnum - movl %eax, %edx - movl 16(%ebp), %eax - movl %eax, 12(%esp) - movl 12(%ebp), %eax - movl %eax, 8(%esp) - movl %edx, 4(%esp) - movl _userenv+24, %eax - movl %eax, (%esp) - call _allot_array_4 - movl %eax, %edx - movl 20(%ebp), %eax - movl %eax, 4(%esp) - movl %edx, (%esp) - call _throw_error - leave - ret - .def _tag_fixnum; .scl 3; .type 32; .endef -_tag_fixnum: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - sall $3, %eax - andl $-8, %eax - popl %ebp - ret -.globl _type_error - .def _type_error; .scl 2; .type 32; .endef -_type_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl 8(%ebp), %eax - movl %eax, (%esp) - call _tag_fixnum - movl %eax, %edx - movl $0, 12(%esp) - movl 12(%ebp), %eax - movl %eax, 8(%esp) - movl %edx, 4(%esp) - movl $3, (%esp) - call _general_error - leave - ret -.globl _not_implemented_error - .def _not_implemented_error; .scl 2; .type 32; .endef -_not_implemented_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl $0, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $2, (%esp) - call _general_error - leave - ret -.globl _in_page - .def _in_page; .scl 2; .type 32; .endef -_in_page: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _getpagesize - movl %eax, -4(%ebp) - movl 16(%ebp), %edx - leal 12(%ebp), %eax - addl %edx, (%eax) - movl 20(%ebp), %eax - movl %eax, %edx - imull -4(%ebp), %edx - leal 12(%ebp), %eax - addl %edx, (%eax) - movb $0, -5(%ebp) - movl 8(%ebp), %eax - cmpl 12(%ebp), %eax - jb L15 - movl -4(%ebp), %eax - addl 12(%ebp), %eax - cmpl 8(%ebp), %eax - jb L15 - movb $1, -5(%ebp) -L15: - movzbl -5(%ebp), %eax - leave - ret - .section .rdata,"dr" - .align 4 -LC5: - .ascii "allot_object() missed GC check\0" -LC6: - .ascii "gc locals underflow\0" -LC7: - .ascii "gc locals overflow\0" -LC8: - .ascii "extra roots underflow\0" -LC9: - .ascii "extra roots overflow\0" - .text -.globl _memory_protection_error - .def _memory_protection_error; .scl 2; .type 32; .endef -_memory_protection_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl $-1, 12(%esp) - movl $0, 8(%esp) - movl _stack_chain, %eax - movl 24(%eax), %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L17 - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $11, (%esp) - call _general_error - jmp L16 -L17: - movl $0, 12(%esp) - movl _ds_size, %eax - movl %eax, 8(%esp) - movl _stack_chain, %eax - movl 24(%eax), %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L19 - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $12, (%esp) - call _general_error - jmp L16 -L19: - movl $-1, 12(%esp) - movl $0, 8(%esp) - movl _stack_chain, %eax - movl 28(%eax), %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L21 - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $13, (%esp) - call _general_error - jmp L16 -L21: - movl $0, 12(%esp) - movl _rs_size, %eax - movl %eax, 8(%esp) - movl _stack_chain, %eax - movl 28(%eax), %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L23 - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $14, (%esp) - call _general_error - jmp L16 -L23: - movl $0, 12(%esp) - movl $0, 8(%esp) - movl _nursery, %eax - movl 12(%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L25 - movl $0, 4(%esp) - movl $LC5, (%esp) - call _critical_error - jmp L16 -L25: - movl $-1, 12(%esp) - movl $0, 8(%esp) - movl _gc_locals_region, %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L27 - movl $0, 4(%esp) - movl $LC6, (%esp) - call _critical_error - jmp L16 -L27: - movl $0, 12(%esp) - movl $0, 8(%esp) - movl _gc_locals_region, %eax - movl 8(%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L29 - movl $0, 4(%esp) - movl $LC7, (%esp) - call _critical_error - jmp L16 -L29: - movl $-1, 12(%esp) - movl $0, 8(%esp) - movl _extra_roots_region, %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L31 - movl $0, 4(%esp) - movl $LC8, (%esp) - call _critical_error - jmp L16 -L31: - movl $0, 12(%esp) - movl $0, 8(%esp) - movl _extra_roots_region, %eax - movl 8(%eax), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _in_page - testb %al, %al - je L33 - movl $0, 4(%esp) - movl $LC9, (%esp) - call _critical_error - jmp L16 -L33: - movl 8(%ebp), %eax - movl %eax, (%esp) - call _allot_cell - movl %eax, %edx - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl $7, 8(%esp) - movl %edx, 4(%esp) - movl $15, (%esp) - call _general_error -L16: - leave - ret - .def _allot_cell; .scl 3; .type 32; .endef -_allot_cell: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - cmpl $268435455, 8(%ebp) - jbe L36 - movl 8(%ebp), %eax - movl %eax, (%esp) - call _cell_to_bignum - movl %eax, (%esp) - call _tag_bignum - movl %eax, -4(%ebp) - jmp L35 -L36: - movl 8(%ebp), %eax - movl %eax, (%esp) - call _tag_fixnum - movl %eax, -4(%ebp) -L35: - movl -4(%ebp), %eax - leave - ret - .def _tag_bignum; .scl 3; .type 32; .endef -_tag_bignum: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - andl $-8, %eax - orl $1, %eax - popl %ebp - ret -.globl _signal_error - .def _signal_error; .scl 2; .type 32; .endef -_signal_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl 8(%ebp), %eax - movl %eax, (%esp) - call _tag_fixnum - movl %eax, %edx - movl 12(%ebp), %eax - movl %eax, 12(%esp) - movl $7, 8(%esp) - movl %edx, 4(%esp) - movl $5, (%esp) - call _general_error - leave - ret -.globl _divide_by_zero_error - .def _divide_by_zero_error; .scl 2; .type 32; .endef -_divide_by_zero_error: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl 8(%ebp), %eax - movl %eax, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $4, (%esp) - call _general_error - leave - ret -.globl _memory_signal_handler_impl - .def _memory_signal_handler_impl; .scl 2; .type 32; .endef -_memory_signal_handler_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl _signal_callstack_top, %eax - movl %eax, 4(%esp) - movl _signal_fault_addr, %eax - movl %eax, (%esp) - call _memory_protection_error - leave - ret -.globl _divide_by_zero_signal_handler_impl - .def _divide_by_zero_signal_handler_impl; .scl 2; .type 32; .endef -_divide_by_zero_signal_handler_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl _signal_callstack_top, %eax - movl %eax, (%esp) - call _divide_by_zero_error - leave - ret -.globl _misc_signal_handler_impl - .def _misc_signal_handler_impl; .scl 2; .type 32; .endef -_misc_signal_handler_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl _signal_callstack_top, %eax - movl %eax, 4(%esp) - movl _signal_number, %eax - movl %eax, (%esp) - call _signal_error - leave - ret -.globl _primitive_throw - .def _primitive_throw; .scl 2; .type 32; .endef -_primitive_throw: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_throw_impl - leave - ret - .def _primitive_throw_impl; .scl 3; .type 32; .endef -_primitive_throw_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - call _dpop - movl %eax, %ecx - movl _stack_chain, %eax - movl (%eax), %edx - movl %ecx, %eax - call _throw_impl - leave - ret - .def _dpop; .scl 3; .type 32; .endef -_dpop: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %esi, (%esp) - call _get - movl %eax, -4(%ebp) - subl $4, %esi - movl -4(%ebp), %eax - leave - ret - .def _get; .scl 3; .type 32; .endef -_get: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - movl (%eax), %eax - popl %ebp - ret -.globl _primitive_call_clear - .def _primitive_call_clear; .scl 2; .type 32; .endef -_primitive_call_clear: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_call_clear_impl - leave - ret - .def _primitive_call_clear_impl; .scl 3; .type 32; .endef -_primitive_call_clear_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - movl _stack_chain, %edx - movl 4(%edx), %edx - call _throw_impl - leave - ret -.globl _primitive_unimplemented2 - .def _primitive_unimplemented2; .scl 2; .type 32; .endef -_primitive_unimplemented2: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - call _not_implemented_error - leave - ret -.globl _primitive_unimplemented - .def _primitive_unimplemented; .scl 2; .type 32; .endef -_primitive_unimplemented: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_unimplemented_impl - leave - ret - .def _primitive_unimplemented_impl; .scl 3; .type 32; .endef -_primitive_unimplemented_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _not_implemented_error - leave - ret - .comm _console_open, 16 # 1 - .comm _userenv, 256 # 256 - .comm _T, 16 # 4 - .comm _stack_chain, 16 # 4 - .comm _ds_size, 16 # 4 - .comm _rs_size, 16 # 4 - .comm _stage2, 16 # 1 - .comm _profiling_p, 16 # 1 - .comm _signal_number, 16 # 4 - .comm _signal_fault_addr, 16 # 4 - .comm _signal_callstack_top, 16 # 4 - .comm _secure_gc, 16 # 1 - .comm _data_heap, 16 # 4 - .comm _cards_offset, 16 # 4 - .comm _newspace, 16 # 4 - .comm _nursery, 16 # 4 - .comm _gc_time, 16 # 8 - .comm _nursery_collections, 16 # 4 - .comm _aging_collections, 16 # 4 - .comm _cards_scanned, 16 # 4 - .comm _performing_gc, 16 # 1 - .comm _collecting_gen, 16 # 4 - .comm _collecting_aging_again, 16 # 1 - .comm _last_code_heap_scan, 16 # 4 - .comm _growing_data_heap, 16 # 1 - .comm _old_data_heap, 16 # 4 - .comm _gc_jmp, 208 # 208 - .comm _heap_scan_ptr, 16 # 4 - .comm _gc_off, 16 # 1 - .comm _gc_locals_region, 16 # 4 - .comm _gc_locals, 16 # 4 - .comm _extra_roots_region, 16 # 4 - .comm _extra_roots, 16 # 4 - .comm _bignum_zero, 16 # 4 - .comm _bignum_pos_one, 16 # 4 - .comm _bignum_neg_one, 16 # 4 - .comm _code_heap, 16 # 8 - .comm _data_relocation_base, 16 # 4 - .comm _code_relocation_base, 16 # 4 - .comm _posix_argc, 16 # 4 - .comm _posix_argv, 16 # 4 - .def _save_callstack_top; .scl 3; .type 32; .endef - .def _getpagesize; .scl 3; .type 32; .endef - .def _allot_array_4; .scl 3; .type 32; .endef - .def _print_obj; .scl 3; .type 32; .endef - .def _throw_impl; .scl 3; .type 32; .endef - .def _fix_callstack_top; .scl 3; .type 32; .endef - .def _fix_stacks; .scl 3; .type 32; .endef - .def _factorbug; .scl 3; .type 32; .endef - .def _exit; .scl 3; .type 32; .endef - .def ___getreent; .scl 3; .type 32; .endef - .def _fprintf; .scl 3; .type 32; .endef - .def _critical_error; .scl 3; .type 32; .endef - .def _type_error; .scl 3; .type 32; .endef - .section .drectve - - .ascii " -export:nursery,data" - .ascii " -export:cards_offset,data" - .ascii " -export:stack_chain,data" - .ascii " -export:userenv,data" diff --git a/vm/run.s b/vm/run.s deleted file mode 100644 index 78b2adac84..0000000000 --- a/vm/run.s +++ /dev/null @@ -1,1511 +0,0 @@ - .file "run.c" - .text -.globl _reset_datastack - .def _reset_datastack; .scl 2; .type 32; .endef -_reset_datastack: - pushl %ebp - movl %esp, %ebp - movl _stack_chain, %eax - movl 24(%eax), %eax - movl (%eax), %esi - subl $4, %esi - popl %ebp - ret -.globl _reset_retainstack - .def _reset_retainstack; .scl 2; .type 32; .endef -_reset_retainstack: - pushl %ebp - movl %esp, %ebp - movl _stack_chain, %eax - movl 28(%eax), %eax - movl (%eax), %edi - subl $4, %edi - popl %ebp - ret -.globl _fix_stacks - .def _fix_stacks; .scl 2; .type 32; .endef -_fix_stacks: - pushl %ebp - movl %esp, %ebp - leal 4(%esi), %eax - movl _stack_chain, %edx - movl 24(%edx), %edx - cmpl (%edx), %eax - jb L5 - leal 256(%esi), %eax - movl _stack_chain, %edx - movl 24(%edx), %edx - cmpl 8(%edx), %eax - jae L5 - jmp L4 -L5: - call _reset_datastack -L4: - leal 4(%edi), %eax - movl _stack_chain, %edx - movl 28(%edx), %edx - cmpl (%edx), %eax - jb L7 - leal 256(%edi), %eax - movl _stack_chain, %edx - movl 28(%edx), %edx - cmpl 8(%edx), %eax - jae L7 - jmp L3 -L7: - call _reset_retainstack -L3: - popl %ebp - ret -.globl _save_stacks - .def _save_stacks; .scl 2; .type 32; .endef -_save_stacks: - pushl %ebp - movl %esp, %ebp - cmpl $0, _stack_chain - je L8 - movl _stack_chain, %eax - movl %esi, 8(%eax) - movl _stack_chain, %eax - movl %edi, 12(%eax) -L8: - popl %ebp - ret -.globl _nest_stacks - .def _nest_stacks; .scl 2; .type 32; .endef -_nest_stacks: - pushl %ebp - movl %esp, %ebp - pushl %ebx - subl $20, %esp - movl $44, (%esp) - call _safe_malloc - movl %eax, -8(%ebp) - movl -8(%ebp), %eax - movl $-1, 4(%eax) - movl -8(%ebp), %eax - movl $-1, (%eax) - movl -8(%ebp), %eax - movl %esi, 16(%eax) - movl -8(%ebp), %eax - movl %edi, 20(%eax) - movl -8(%ebp), %edx - movl _userenv+8, %eax - movl %eax, 36(%edx) - movl -8(%ebp), %edx - movl _userenv+4, %eax - movl %eax, 32(%edx) - movl -8(%ebp), %ebx - movl _ds_size, %eax - movl %eax, (%esp) - call _alloc_segment - movl %eax, 24(%ebx) - movl -8(%ebp), %ebx - movl _rs_size, %eax - movl %eax, (%esp) - call _alloc_segment - movl %eax, 28(%ebx) - movl -8(%ebp), %edx - movl _stack_chain, %eax - movl %eax, 40(%edx) - movl -8(%ebp), %eax - movl %eax, _stack_chain - call _reset_datastack - call _reset_retainstack - addl $20, %esp - popl %ebx - popl %ebp - ret -.globl _unnest_stacks - .def _unnest_stacks; .scl 2; .type 32; .endef -_unnest_stacks: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl _stack_chain, %eax - movl 24(%eax), %eax - movl %eax, (%esp) - call _dealloc_segment - movl _stack_chain, %eax - movl 28(%eax), %eax - movl %eax, (%esp) - call _dealloc_segment - movl _stack_chain, %eax - movl 16(%eax), %esi - movl _stack_chain, %eax - movl 20(%eax), %edi - movl _stack_chain, %eax - movl 36(%eax), %eax - movl %eax, _userenv+8 - movl _stack_chain, %eax - movl 32(%eax), %eax - movl %eax, _userenv+4 - movl _stack_chain, %eax - movl %eax, -4(%ebp) - movl -4(%ebp), %eax - movl 40(%eax), %eax - movl %eax, _stack_chain - movl -4(%ebp), %eax - movl %eax, (%esp) - call _free - leave - ret -.globl _init_stacks - .def _init_stacks; .scl 2; .type 32; .endef -_init_stacks: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - movl %eax, _ds_size - movl 12(%ebp), %eax - movl %eax, _rs_size - movl $0, _stack_chain - popl %ebp - ret -.globl _primitive_drop - .def _primitive_drop; .scl 2; .type 32; .endef -_primitive_drop: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_drop_impl - leave - ret - .def _primitive_drop_impl; .scl 3; .type 32; .endef -_primitive_drop_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - leave - ret - .def _dpop; .scl 3; .type 32; .endef -_dpop: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %esi, (%esp) - call _get - movl %eax, -4(%ebp) - subl $4, %esi - movl -4(%ebp), %eax - leave - ret - .def _get; .scl 3; .type 32; .endef -_get: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - movl (%eax), %eax - popl %ebp - ret -.globl _primitive_2drop - .def _primitive_2drop; .scl 2; .type 32; .endef -_primitive_2drop: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_2drop_impl - leave - ret - .def _primitive_2drop_impl; .scl 3; .type 32; .endef -_primitive_2drop_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esi - popl %ebp - ret -.globl _primitive_3drop - .def _primitive_3drop; .scl 2; .type 32; .endef -_primitive_3drop: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_3drop_impl - leave - ret - .def _primitive_3drop_impl; .scl 3; .type 32; .endef -_primitive_3drop_impl: - pushl %ebp - movl %esp, %ebp - subl $12, %esi - popl %ebp - ret -.globl _primitive_dup - .def _primitive_dup; .scl 2; .type 32; .endef -_primitive_dup: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_dup_impl - leave - ret - .def _primitive_dup_impl; .scl 3; .type 32; .endef -_primitive_dup_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpeek - movl %eax, (%esp) - call _dpush - leave - ret - .def _dpush; .scl 3; .type 32; .endef -_dpush: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - addl $4, %esi - movl 8(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - leave - ret - .def _put; .scl 3; .type 32; .endef -_put: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %edx - movl 12(%ebp), %eax - movl %eax, (%edx) - popl %ebp - ret - .def _dpeek; .scl 3; .type 32; .endef -_dpeek: - pushl %ebp - movl %esp, %ebp - subl $4, %esp - movl %esi, (%esp) - call _get - leave - ret -.globl _primitive_2dup - .def _primitive_2dup; .scl 2; .type 32; .endef -_primitive_2dup: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_2dup_impl - leave - ret - .def _primitive_2dup_impl; .scl 3; .type 32; .endef -_primitive_2dup_impl: - pushl %ebp - movl %esp, %ebp - subl $16, %esp - call _dpeek - movl %eax, -4(%ebp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - addl $8, %esi - movl -8(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - leave - ret -.globl _primitive_3dup - .def _primitive_3dup; .scl 2; .type 32; .endef -_primitive_3dup: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_3dup_impl - leave - ret - .def _primitive_3dup_impl; .scl 3; .type 32; .endef -_primitive_3dup_impl: - pushl %ebp - movl %esp, %ebp - subl $20, %esp - call _dpeek - movl %eax, -4(%ebp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -12(%ebp) - addl $12, %esi - movl -4(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - movl -8(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - movl -12(%ebp), %eax - movl %eax, 4(%esp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _put - leave - ret -.globl _primitive_rot - .def _primitive_rot; .scl 2; .type 32; .endef -_primitive_rot: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_rot_impl - leave - ret - .def _primitive_rot_impl; .scl 3; .type 32; .endef -_primitive_rot_impl: - pushl %ebp - movl %esp, %ebp - subl $20, %esp - call _dpeek - movl %eax, -4(%ebp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -12(%ebp) - movl -12(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - movl -8(%ebp), %eax - movl %eax, 4(%esp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _put - leave - ret -.globl _primitive__rot - .def _primitive__rot; .scl 2; .type 32; .endef -_primitive__rot: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive__rot_impl - leave - ret - .def _primitive__rot_impl; .scl 3; .type 32; .endef -_primitive__rot_impl: - pushl %ebp - movl %esp, %ebp - subl $20, %esp - call _dpeek - movl %eax, -4(%ebp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -12(%ebp) - movl -8(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - movl -12(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, 4(%esp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _put - leave - ret -.globl _primitive_dupd - .def _primitive_dupd; .scl 2; .type 32; .endef -_primitive_dupd: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_dupd_impl - leave - ret - .def _primitive_dupd_impl; .scl 3; .type 32; .endef -_primitive_dupd_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call _dpeek - movl %eax, -4(%ebp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - movl -8(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - movl -8(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, (%esp) - call _dpush - leave - ret -.globl _primitive_swapd - .def _primitive_swapd; .scl 2; .type 32; .endef -_primitive_swapd: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_swapd_impl - leave - ret - .def _primitive_swapd_impl; .scl 3; .type 32; .endef -_primitive_swapd_impl: - pushl %ebp - movl %esp, %ebp - subl $16, %esp - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -4(%ebp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - movl -8(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, 4(%esp) - leal -8(%esi), %eax - movl %eax, (%esp) - call _put - leave - ret -.globl _primitive_nip - .def _primitive_nip; .scl 2; .type 32; .endef -_primitive_nip: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_nip_impl - leave - ret - .def _primitive_nip_impl; .scl 3; .type 32; .endef -_primitive_nip_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - movl %eax, -4(%ebp) - movl -4(%ebp), %eax - movl %eax, (%esp) - call _drepl - leave - ret - .def _drepl; .scl 3; .type 32; .endef -_drepl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl 8(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - leave - ret -.globl _primitive_2nip - .def _primitive_2nip; .scl 2; .type 32; .endef -_primitive_2nip: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_2nip_impl - leave - ret - .def _primitive_2nip_impl; .scl 3; .type 32; .endef -_primitive_2nip_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpeek - movl %eax, -4(%ebp) - subl $8, %esi - movl -4(%ebp), %eax - movl %eax, (%esp) - call _drepl - leave - ret -.globl _primitive_tuck - .def _primitive_tuck; .scl 2; .type 32; .endef -_primitive_tuck: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_tuck_impl - leave - ret - .def _primitive_tuck_impl; .scl 3; .type 32; .endef -_primitive_tuck_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call _dpeek - movl %eax, -4(%ebp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - movl -8(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, (%esp) - call _dpush - leave - ret -.globl _primitive_over - .def _primitive_over; .scl 2; .type 32; .endef -_primitive_over: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_over_impl - leave - ret - .def _primitive_over_impl; .scl 3; .type 32; .endef -_primitive_over_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, (%esp) - call _dpush - leave - ret -.globl _primitive_pick - .def _primitive_pick; .scl 2; .type 32; .endef -_primitive_pick: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_pick_impl - leave - ret - .def _primitive_pick_impl; .scl 3; .type 32; .endef -_primitive_pick_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - leal -8(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, (%esp) - call _dpush - leave - ret -.globl _primitive_swap - .def _primitive_swap; .scl 2; .type 32; .endef -_primitive_swap: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_swap_impl - leave - ret - .def _primitive_swap_impl; .scl 3; .type 32; .endef -_primitive_swap_impl: - pushl %ebp - movl %esp, %ebp - subl $16, %esp - call _dpeek - movl %eax, -4(%ebp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _get - movl %eax, -8(%ebp) - movl -8(%ebp), %eax - movl %eax, 4(%esp) - movl %esi, (%esp) - call _put - movl -4(%ebp), %eax - movl %eax, 4(%esp) - leal -4(%esi), %eax - movl %eax, (%esp) - call _put - leave - ret -.globl _primitive_to_r - .def _primitive_to_r; .scl 2; .type 32; .endef -_primitive_to_r: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_to_r_impl - leave - ret - .def _primitive_to_r_impl; .scl 3; .type 32; .endef -_primitive_to_r_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - movl %eax, (%esp) - call _rpush - leave - ret - .def _rpush; .scl 3; .type 32; .endef -_rpush: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - addl $4, %edi - movl 8(%ebp), %eax - movl %eax, 4(%esp) - movl %edi, (%esp) - call _put - leave - ret -.globl _primitive_from_r - .def _primitive_from_r; .scl 2; .type 32; .endef -_primitive_from_r: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_from_r_impl - leave - ret - .def _primitive_from_r_impl; .scl 3; .type 32; .endef -_primitive_from_r_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _rpop - movl %eax, (%esp) - call _dpush - leave - ret - .def _rpop; .scl 3; .type 32; .endef -_rpop: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %edi, (%esp) - call _get - movl %eax, -4(%ebp) - subl $4, %edi - movl -4(%ebp), %eax - leave - ret -.globl _stack_to_array - .def _stack_to_array; .scl 2; .type 32; .endef -_stack_to_array: - pushl %ebp - movl %esp, %ebp - subl $40, %esp - movl 8(%ebp), %edx - movl 12(%ebp), %eax - subl %edx, %eax - addl $4, %eax - movl %eax, -4(%ebp) - cmpl $0, -4(%ebp) - jns L58 - movl $0, -12(%ebp) - jmp L57 -L58: - movl -4(%ebp), %eax - movl %eax, -16(%ebp) - cmpl $0, -16(%ebp) - jns L60 - addl $3, -16(%ebp) -L60: - movl -16(%ebp), %eax - sarl $2, %eax - movl %eax, 4(%esp) - movl $8, (%esp) - call _allot_array_internal - movl %eax, -8(%ebp) - movl -4(%ebp), %eax - movl %eax, 8(%esp) - movl 8(%ebp), %eax - movl %eax, 4(%esp) - movl -8(%ebp), %eax - addl $8, %eax - movl %eax, (%esp) - call _memcpy - movl -8(%ebp), %eax - movl %eax, (%esp) - call _tag_object - movl %eax, (%esp) - call _dpush - movl $1, -12(%ebp) -L57: - movl -12(%ebp), %eax - leave - ret - .def _tag_object; .scl 3; .type 32; .endef -_tag_object: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - andl $-8, %eax - orl $3, %eax - popl %ebp - ret -.globl _primitive_datastack - .def _primitive_datastack; .scl 2; .type 32; .endef -_primitive_datastack: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_datastack_impl - leave - ret - .def _primitive_datastack_impl; .scl 3; .type 32; .endef -_primitive_datastack_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl %esi, 4(%esp) - movl _stack_chain, %eax - movl 24(%eax), %eax - movl (%eax), %eax - movl %eax, (%esp) - call _stack_to_array - testb %al, %al - jne L63 - movl $0, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $11, (%esp) - call _general_error -L63: - leave - ret -.globl _primitive_retainstack - .def _primitive_retainstack; .scl 2; .type 32; .endef -_primitive_retainstack: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_retainstack_impl - leave - ret - .def _primitive_retainstack_impl; .scl 3; .type 32; .endef -_primitive_retainstack_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl %edi, 4(%esp) - movl _stack_chain, %eax - movl 28(%eax), %eax - movl (%eax), %eax - movl %eax, (%esp) - call _stack_to_array - testb %al, %al - jne L66 - movl $0, 12(%esp) - movl $7, 8(%esp) - movl $7, 4(%esp) - movl $13, (%esp) - call _general_error -L66: - leave - ret -.globl _array_to_stack - .def _array_to_stack; .scl 2; .type 32; .endef -_array_to_stack: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl 8(%ebp), %eax - movl %eax, (%esp) - call _array_capacity - sall $2, %eax - movl %eax, -4(%ebp) - movl -4(%ebp), %eax - movl %eax, 8(%esp) - movl 8(%ebp), %eax - addl $8, %eax - movl %eax, 4(%esp) - movl 12(%ebp), %eax - movl %eax, (%esp) - call _memcpy - movl -4(%ebp), %eax - addl 12(%ebp), %eax - subl $4, %eax - leave - ret - .def _array_capacity; .scl 3; .type 32; .endef -_array_capacity: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - movl 4(%eax), %eax - shrl $3, %eax - popl %ebp - ret -.globl _primitive_set_datastack - .def _primitive_set_datastack; .scl 2; .type 32; .endef -_primitive_set_datastack: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_set_datastack_impl - leave - ret - .def _primitive_set_datastack_impl; .scl 3; .type 32; .endef -_primitive_set_datastack_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - movl %eax, (%esp) - call _untag_array - movl %eax, %edx - movl _stack_chain, %eax - movl 24(%eax), %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl %edx, (%esp) - call _array_to_stack - movl %eax, %esi - leave - ret - .def _untag_array; .scl 3; .type 32; .endef -_untag_array: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl 8(%ebp), %eax - movl %eax, 4(%esp) - movl $8, (%esp) - call _type_check - movl 8(%ebp), %eax - movl %eax, (%esp) - call _untag_object - leave - ret - .def _untag_object; .scl 3; .type 32; .endef -_untag_object: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - andl $-8, %eax - popl %ebp - ret - .def _type_check; .scl 3; .type 32; .endef -_type_check: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl 12(%ebp), %eax - movl %eax, (%esp) - call _type_of - cmpl 8(%ebp), %eax - je L74 - movl 12(%ebp), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %eax - movl %eax, (%esp) - call _type_error -L74: - leave - ret - .def _type_of; .scl 3; .type 32; .endef -_type_of: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - movl 8(%ebp), %eax - andl $7, %eax - movl %eax, -4(%ebp) - cmpl $3, -4(%ebp) - jne L77 - movl 8(%ebp), %eax - movl %eax, (%esp) - call _object_type - movl %eax, -8(%ebp) - jmp L76 -L77: - movl -4(%ebp), %eax - movl %eax, -8(%ebp) -L76: - movl -8(%ebp), %eax - leave - ret - .def _object_type; .scl 3; .type 32; .endef -_object_type: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl 8(%ebp), %eax - andl $-8, %eax - movl %eax, (%esp) - call _get - movl %eax, (%esp) - call _untag_header - leave - ret - .def _untag_header; .scl 3; .type 32; .endef -_untag_header: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - shrl $3, %eax - popl %ebp - ret -.globl _primitive_set_retainstack - .def _primitive_set_retainstack; .scl 2; .type 32; .endef -_primitive_set_retainstack: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_set_retainstack_impl - leave - ret - .def _primitive_set_retainstack_impl; .scl 3; .type 32; .endef -_primitive_set_retainstack_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - movl %eax, (%esp) - call _untag_array - movl %eax, %edx - movl _stack_chain, %eax - movl 28(%eax), %eax - movl (%eax), %eax - movl %eax, 4(%esp) - movl %edx, (%esp) - call _array_to_stack - movl %eax, %edi - leave - ret -.globl _primitive_getenv - .def _primitive_getenv; .scl 2; .type 32; .endef -_primitive_getenv: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_getenv_impl - leave - ret - .def _primitive_getenv_impl; .scl 3; .type 32; .endef -_primitive_getenv_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpeek - movl %eax, (%esp) - call _untag_fixnum_fast - movl %eax, -4(%ebp) - movl -4(%ebp), %eax - movl _userenv(,%eax,4), %eax - movl %eax, (%esp) - call _drepl - leave - ret - .def _untag_fixnum_fast; .scl 3; .type 32; .endef -_untag_fixnum_fast: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - sarl $3, %eax - popl %ebp - ret -.globl _primitive_setenv - .def _primitive_setenv; .scl 2; .type 32; .endef -_primitive_setenv: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_setenv_impl - leave - ret - .def _primitive_setenv_impl; .scl 3; .type 32; .endef -_primitive_setenv_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call _dpop - movl %eax, (%esp) - call _untag_fixnum_fast - movl %eax, -4(%ebp) - call _dpop - movl %eax, -8(%ebp) - movl -4(%ebp), %edx - movl -8(%ebp), %eax - movl %eax, _userenv(,%edx,4) - leave - ret -.globl _primitive_exit - .def _primitive_exit; .scl 2; .type 32; .endef -_primitive_exit: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_exit_impl - leave - ret - .def _primitive_exit_impl; .scl 3; .type 32; .endef -_primitive_exit_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - movl %eax, (%esp) - call _to_fixnum - movl %eax, (%esp) - call _exit -.globl _primitive_os_env - .def _primitive_os_env; .scl 2; .type 32; .endef -_primitive_os_env: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_os_env_impl - leave - ret - .def _primitive_os_env_impl; .scl 3; .type 32; .endef -_primitive_os_env_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call _unbox_char_string - movl %eax, -4(%ebp) - movl -4(%ebp), %eax - movl %eax, (%esp) - call _getenv - movl %eax, -8(%ebp) - cmpl $0, -8(%ebp) - jne L92 - movl $7, (%esp) - call _dpush - jmp L91 -L92: - movl -8(%ebp), %eax - movl %eax, (%esp) - call _box_char_string -L91: - leave - ret -.globl _primitive_eq - .def _primitive_eq; .scl 2; .type 32; .endef -_primitive_eq: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_eq_impl - leave - ret - .def _primitive_eq_impl; .scl 3; .type 32; .endef -_primitive_eq_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call _dpop - movl %eax, -4(%ebp) - call _dpeek - movl %eax, -8(%ebp) - movl -4(%ebp), %eax - cmpl -8(%ebp), %eax - jne L96 - movl _T, %eax - movl %eax, -12(%ebp) - jmp L97 -L96: - movl $7, -12(%ebp) -L97: - movl -12(%ebp), %eax - movl %eax, (%esp) - call _drepl - leave - ret -.globl _primitive_millis - .def _primitive_millis; .scl 2; .type 32; .endef -_primitive_millis: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_millis_impl - leave - ret - .def _primitive_millis_impl; .scl 3; .type 32; .endef -_primitive_millis_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _current_millis - movl %eax, (%esp) - movl %edx, 4(%esp) - call _box_unsigned_8 - leave - ret -.globl _primitive_sleep - .def _primitive_sleep; .scl 2; .type 32; .endef -_primitive_sleep: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_sleep_impl - leave - ret - .def _primitive_sleep_impl; .scl 3; .type 32; .endef -_primitive_sleep_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpop - movl %eax, (%esp) - call _to_cell - movl %eax, (%esp) - call _sleep_millis - leave - ret -.globl _primitive_tag - .def _primitive_tag; .scl 2; .type 32; .endef -_primitive_tag: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_tag_impl - leave - ret - .def _primitive_tag_impl; .scl 3; .type 32; .endef -_primitive_tag_impl: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - call _dpeek - andl $7, %eax - movl %eax, (%esp) - call _tag_fixnum - movl %eax, (%esp) - call _drepl - leave - ret - .def _tag_fixnum; .scl 3; .type 32; .endef -_tag_fixnum: - pushl %ebp - movl %esp, %ebp - movl 8(%ebp), %eax - sall $3, %eax - andl $-8, %eax - popl %ebp - ret -.globl _primitive_slot - .def _primitive_slot; .scl 2; .type 32; .endef -_primitive_slot: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_slot_impl - leave - ret - .def _primitive_slot_impl; .scl 3; .type 32; .endef -_primitive_slot_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call _dpop - movl %eax, (%esp) - call _untag_fixnum_fast - movl %eax, -4(%ebp) - call _dpop - movl %eax, -8(%ebp) - movl -8(%ebp), %edx - andl $-8, %edx - movl -4(%ebp), %eax - sall $2, %eax - leal (%edx,%eax), %eax - movl %eax, (%esp) - call _get - movl %eax, (%esp) - call _dpush - leave - ret -.globl _primitive_set_slot - .def _primitive_set_slot; .scl 2; .type 32; .endef -_primitive_set_slot: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl %eax, -4(%ebp) - movl %edx, -8(%ebp) - movl -8(%ebp), %eax - call _save_callstack_top - call _primitive_set_slot_impl - leave - ret - .def _primitive_set_slot_impl; .scl 3; .type 32; .endef -_primitive_set_slot_impl: - pushl %ebp - movl %esp, %ebp - subl $24, %esp - call _dpop - movl %eax, (%esp) - call _untag_fixnum_fast - movl %eax, -4(%ebp) - call _dpop - movl %eax, -8(%ebp) - call _dpop - movl %eax, -12(%ebp) - movl -12(%ebp), %eax - movl %eax, 8(%esp) - movl -4(%ebp), %eax - movl %eax, 4(%esp) - movl -8(%ebp), %eax - movl %eax, (%esp) - call _set_slot - leave - ret - .def _set_slot; .scl 3; .type 32; .endef -_set_slot: - pushl %ebp - movl %esp, %ebp - subl $8, %esp - movl 16(%ebp), %eax - movl %eax, 4(%esp) - movl 8(%ebp), %edx - andl $-8, %edx - movl 12(%ebp), %eax - sall $2, %eax - leal (%edx,%eax), %eax - movl %eax, (%esp) - call _put - movl 8(%ebp), %eax - movl %eax, (%esp) - call _write_barrier - leave - ret - .def _write_barrier; .scl 3; .type 32; .endef -_write_barrier: - pushl %ebp - movl %esp, %ebp - subl $4, %esp - movl 8(%ebp), %eax - shrl $6, %eax - addl _cards_offset, %eax - movl %eax, -4(%ebp) - movl -4(%ebp), %edx - movl -4(%ebp), %eax - movzbl (%eax), %eax - orb $-64, %al - movb %al, (%edx) - leave - ret - .comm _console_open, 16 # 1 - .comm _userenv, 256 # 256 - .comm _T, 16 # 4 - .comm _stack_chain, 16 # 4 - .comm _ds_size, 16 # 4 - .comm _rs_size, 16 # 4 - .comm _stage2, 16 # 1 - .comm _profiling_p, 16 # 1 - .comm _signal_number, 16 # 4 - .comm _signal_fault_addr, 16 # 4 - .comm _signal_callstack_top, 16 # 4 - .comm _secure_gc, 16 # 1 - .comm _data_heap, 16 # 4 - .comm _cards_offset, 16 # 4 - .comm _newspace, 16 # 4 - .comm _nursery, 16 # 4 - .comm _gc_time, 16 # 8 - .comm _nursery_collections, 16 # 4 - .comm _aging_collections, 16 # 4 - .comm _cards_scanned, 16 # 4 - .comm _performing_gc, 16 # 1 - .comm _collecting_gen, 16 # 4 - .comm _collecting_aging_again, 16 # 1 - .comm _last_code_heap_scan, 16 # 4 - .comm _growing_data_heap, 16 # 1 - .comm _old_data_heap, 16 # 4 - .comm _gc_jmp, 208 # 208 - .comm _heap_scan_ptr, 16 # 4 - .comm _gc_off, 16 # 1 - .comm _gc_locals_region, 16 # 4 - .comm _gc_locals, 16 # 4 - .comm _extra_roots_region, 16 # 4 - .comm _extra_roots, 16 # 4 - .comm _bignum_zero, 16 # 4 - .comm _bignum_pos_one, 16 # 4 - .comm _bignum_neg_one, 16 # 4 - .comm _code_heap, 16 # 8 - .comm _data_relocation_base, 16 # 4 - .comm _code_relocation_base, 16 # 4 - .comm _posix_argc, 16 # 4 - .comm _posix_argv, 16 # 4 - .def _sleep_millis; .scl 3; .type 32; .endef - .def _current_millis; .scl 3; .type 32; .endef - .def _getenv; .scl 3; .type 32; .endef - .def _exit; .scl 3; .type 32; .endef - .def _general_error; .scl 3; .type 32; .endef - .def _memcpy; .scl 3; .type 32; .endef - .def _allot_array_internal; .scl 3; .type 32; .endef - .def _save_callstack_top; .scl 3; .type 32; .endef - .def _free; .scl 3; .type 32; .endef - .def _dealloc_segment; .scl 3; .type 32; .endef - .def _alloc_segment; .scl 3; .type 32; .endef - .def _safe_malloc; .scl 3; .type 32; .endef - .def _type_error; .scl 3; .type 32; .endef - .section .drectve - - .ascii " -export:nursery,data" - .ascii " -export:cards_offset,data" - .ascii " -export:stack_chain,data" - .ascii " -export:userenv,data" - .ascii " -export:unnest_stacks" - .ascii " -export:nest_stacks" - .ascii " -export:save_stacks"