steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-04-07 20:20:14 -05:00
parent 4c08b7dc81 ce0f86167e
commit 37d6dc70e8
13 changed files with 109 additions and 2313 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
build-support/factor.sh
View File

@ -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
}

2
extra/builder/builder.factor
View File

@ -106,7 +106,7 @@ IN: builder
+closed+ >>stdin
"../test-log" >>stdout
+stdout+ >>stderr
120 minutes >>timeout ;
240 minutes >>timeout ;
: do-builder-test ( -- )
builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;

50
extra/db/db.factor
View File

@ -11,14 +11,19 @@ TUPLE: db
update-statements
delete-statements ;
: <db> ( 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,13 @@ 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 +49,13 @@ 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 ;
: <statement> ( 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: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
@ -88,10 +95,13 @@ M: nonthrowable-statement execute-statement ( statement -- )
dup #rows >>max
0 >>n drop ;
: <result-set> ( 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 ;
: sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ;
@ -110,7 +120,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 )

3
extra/db/postgresql/ffi/ffi.factor
View File

@ -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 >>

59
extra/db/postgresql/postgresql.factor
View File

@ -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 ;
: <postgresql-statement> ( statement in out -- postgresql-statement )
<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 <db> 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 <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 ;

84
extra/db/sqlite/sqlite.factor
View File

@ -5,61 +5,48 @@ 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 <db>
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 ;
TUPLE: sqlite-result-set has-more? ;
TUPLE: sqlite-result-set < result-set has-more? ;
M: sqlite-db <simple-statement> ( str in out -- obj )
<prepared-statement> ;
M: sqlite-db <prepared-statement> ( 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
@ -69,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 ;
@ -86,25 +73,24 @@ M: sqlite-db insert-tuple* ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
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 <result-set>
dup handle>> sqlite-result-set construct-result-set
dup advance-row ;
M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
@ -119,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 ;
@ -134,7 +120,7 @@ M: sqlite-db <insert-native-statement> ( 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%
@ -145,11 +131,11 @@ M: sqlite-db <insert-nonnative-statement> ( 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 <update-tuple-statement> ( class -- statement )
[
@ -157,7 +143,7 @@ M: sqlite-db <update-tuple-statement> ( 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 ;
@ -166,23 +152,23 @@ M: sqlite-db <delete-tuple-statement> ( 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 <select-by-slots-statement> ( 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
[ slot-name>> swap get-slot-named ] with subset
dup empty? [ drop ] [ where-clause ] if ";" 0%
] sqlite-make ;

8
extra/db/tuples/tuples-tests.factor
View File

@ -260,10 +260,10 @@ C: <secret> 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

1
extra/hardware-info/backend/backend.factor
View File

@ -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 )

4
extra/hardware-info/hardware-info.factor
View File

@ -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 ;

2
extra/hardware-info/macosx/macosx.factor
View File

@ -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 ;

4
vm/data_gc.h
View File

@ -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];

687
vm/errors.s
View File

@ -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"

1511
vm/run.s
View File

File diff suppressed because it is too large Load Diff