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

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

db4
Anton Gorenko 2010-07-25 17:58:56 +06:00
parent 66da664a99 3dbb8e6153
commit 3989f0b406
50 changed files with 486 additions and 339 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
basis/alien/c-types/c-types.factor
View File

@ -258,7 +258,7 @@ M: pointer c-type
2 >>align
2 >>align-first
"from_signed_2" >>boxer
"to_fixnum" >>unboxer
"to_signed_2" >>unboxer
[ >fixnum ] >>unboxer-quot
\ short define-primitive-type
@ -271,7 +271,7 @@ M: pointer c-type
2 >>align
2 >>align-first
"from_unsigned_2" >>boxer
"to_cell" >>unboxer
"to_unsigned_2" >>unboxer
[ >fixnum ] >>unboxer-quot
\ ushort define-primitive-type
@ -284,7 +284,7 @@ M: pointer c-type
1 >>align
1 >>align-first
"from_signed_1" >>boxer
"to_fixnum" >>unboxer
"to_signed_1" >>unboxer
[ >fixnum ] >>unboxer-quot
\ char define-primitive-type
@ -297,7 +297,7 @@ M: pointer c-type
1 >>align
1 >>align-first
"from_unsigned_1" >>boxer
"to_cell" >>unboxer
"to_unsigned_1" >>unboxer
[ >fixnum ] >>unboxer-quot
\ uchar define-primitive-type
@ -338,7 +338,7 @@ M: pointer c-type
4 >>align
4 >>align-first
"from_signed_4" >>boxer
"to_fixnum" >>unboxer
"to_signed_4" >>unboxer
[ >fixnum ] >>unboxer-quot
\ int define-primitive-type
@ -351,7 +351,7 @@ M: pointer c-type
4 >>align
4 >>align-first
"from_unsigned_4" >>boxer
"to_cell" >>unboxer
"to_unsigned_4" >>unboxer
[ >fixnum ] >>unboxer-quot
\ uint define-primitive-type

3
basis/calendar/calendar-tests.factor
View File

@ -185,3 +185,6 @@ IN: calendar.tests
2008 1 29 <date> 1 months time+
2008 2 29 <date> =
] unit-test
[ 0 ]
[ gmt gmt-offset>> duration>seconds ] unit-test

2
basis/calendar/calendar.factor
View File

@ -532,7 +532,7 @@ M: integer end-of-year 12 31 <date> ;
dup midnight time- ;
: since-1970 ( duration -- timestamp )
unix-1970 time+ >local-time ;
unix-1970 time+ ;
: timestamp>unix-time ( timestamp -- seconds )
unix-1970 time- second>> ;

4
basis/calendar/unix/unix.factor
View File

@ -11,14 +11,14 @@ IN: calendar.unix
: timeval>unix-time ( timeval -- timestamp )
timeval>duration since-1970 ;
: timespec>seconds ( timespec -- seconds )
: timespec>duration ( timespec -- seconds )
[ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
: timespec>nanoseconds ( timespec -- seconds )
[ sec>> 1000000000 * ] [ nsec>> ] bi + ;
: timespec>unix-time ( timespec -- timestamp )
timespec>seconds since-1970 ;
timespec>duration since-1970 ;
: get-time ( -- alien )
f time <time_t> localtime ;

1
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -299,6 +299,7 @@ M: ##compare analyze-aliases
\ ##alien-global set-new-ac ;
M: factor-call-insn analyze-aliases
call-next-method
heap-ac get ac>vregs [
[ live-slots get at clear-assoc ]
[ recent-stores get at clear-assoc ] bi

25
basis/compiler/cfg/builder/alien/boxing/boxing.factor
View File

@ -6,6 +6,7 @@ sequences sequences.generalizations system
compiler.cfg.builder.alien.params compiler.cfg.hats
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.intrinsics.allot cpu.architecture ;
QUALIFIED-WITH: alien.c-types c
IN: compiler.cfg.builder.alien.boxing
SYMBOL: struct-return-area
@ -49,9 +50,15 @@ M: c-type unbox
[ rep>> ] [ unboxer>> ] bi
[
{
! { "to_float" [ drop ] }
! { "to_double" [ drop ] }
! { "alien_offset" [ drop ^^unbox-any-c-ptr ] }
{ "to_float" [ drop ] }
{ "to_double" [ drop ] }
{ "to_signed_1" [ drop ] }
{ "to_unsigned_1" [ drop ] }
{ "to_signed_2" [ drop ] }
{ "to_unsigned_2" [ drop ] }
{ "to_signed_4" [ drop ] }
{ "to_unsigned_4" [ drop ] }
{ "alien_offset" [ drop ^^unbox-any-c-ptr ] }
[ swap ^^unbox ]
} case 1array
]
@ -107,9 +114,15 @@ GENERIC: box ( vregs reps c-type -- dst )
M: c-type box
[ [ first ] bi@ ] [ boxer>> ] bi*
{
! { "from_float" [ drop ] }
! { "from_double" [ drop ] }
! { "allot_alien" [ drop ^^box-alien ] }
{ "from_float" [ drop ] }
{ "from_double" [ drop ] }
{ "from_signed_1" [ drop c:char ^^convert-integer ] }
{ "from_unsigned_1" [ drop c:uchar ^^convert-integer ] }
{ "from_signed_2" [ drop c:short ^^convert-integer ] }
{ "from_unsigned_2" [ drop c:ushort ^^convert-integer ] }
{ "from_signed_4" [ drop c:int ^^convert-integer ] }
{ "from_unsigned_4" [ drop c:uint ^^convert-integer ] }
{ "allot_alien" [ drop ^^box-alien ] }
[ swap <gc-map> ^^box ]
} case ;

8
basis/compiler/cfg/def-use/def-use.factor
View File

@ -80,12 +80,9 @@ M: ##callback-outputs uses-vregs
tri
] with-compilation-unit
! Computing def-use chains.
SYMBOLS: defs insns uses ;
SYMBOLS: defs insns ;
: def-of ( vreg -- node ) defs get at ;
: uses-of ( vreg -- nodes ) uses get at ;
: insn-of ( vreg -- insn ) insns get at ;
: set-def-of ( obj insn assoc -- )
@ -98,8 +95,7 @@ SYMBOLS: defs insns uses ;
_ set-def-of
] with each
] each-basic-block
] keep
defs set ;
] keep defs set ;
: compute-insns ( cfg -- )
H{ } clone [

6
basis/compiler/cfg/instructions/instructions.factor
View File

@ -591,6 +591,12 @@ FOLDABLE-INSN: ##unbox-alien
def: dst/int-rep
use: src/tagged-rep ;
! Zero-extending and sign-extending integers
FOLDABLE-INSN: ##convert-integer
def: dst/int-rep
use: src/int-rep
literal: c-type ;
! Raw memory accessors
FLUSHABLE-INSN: ##load-memory
def: dst

45
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -48,52 +48,33 @@ IN: compiler.cfg.linear-scan.allocation
2dup spill-at-sync-point?
[ swap n>> spill f ] [ 2drop t ] if ;
: handle-interval ( live-interval -- )
GENERIC: handle ( obj -- )
M: live-interval handle
[ start>> deactivate-intervals ]
[ start>> activate-intervals ]
[ assign-register ]
tri ;
: (handle-sync-point) ( sync-point -- )
: handle-sync-point ( sync-point -- )
active-intervals get values
[ [ spill-at-sync-point ] with filter! drop ] with each ;
: handle-sync-point ( sync-point -- )
M: sync-point handle ( sync-point -- )
[ n>> deactivate-intervals ]
[ (handle-sync-point) ]
[ handle-sync-point ]
[ n>> activate-intervals ]
tri ;
: smallest-heap ( heap1 heap2 -- heap )
[ [ heap-peek nip ] bi@ <= ] most ;
:: (allocate-registers-step) ( unhandled-intervals unhandled-sync-points -- )
{
{
[ unhandled-intervals heap-empty? ]
[ unhandled-sync-points heap-pop drop handle-sync-point ]
}
{
[ unhandled-sync-points heap-empty? ]
[ unhandled-intervals heap-pop drop handle-interval ]
}
[
unhandled-intervals heap-peek :> ( i ik )
unhandled-sync-points heap-peek :> ( s sk )
{
{
[ ik sk < ]
[ unhandled-intervals heap-pop* i handle-interval ]
}
{
[ ik sk > ]
[ unhandled-sync-points heap-pop* s handle-sync-point ]
}
[
unhandled-intervals heap-pop*
i handle-interval
s (handle-sync-point)
]
} cond
]
} cond ;
{ [ unhandled-intervals heap-empty? ] [ unhandled-sync-points ] }
{ [ unhandled-sync-points heap-empty? ] [ unhandled-intervals ] }
[ unhandled-intervals unhandled-sync-points smallest-heap ]
} cond heap-pop drop handle ;
: (allocate-registers) ( unhandled-intervals unhandled-sync-points -- )
2dup [ heap-empty? ] both? [ 2drop ] [

7
basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
View File

@ -79,12 +79,13 @@ ERROR: bad-live-ranges interval ;
: split-for-spill ( live-interval n -- before after )
split-interval [ spill-before ] [ spill-after ] bi* ;
: find-use-position ( live-interval new -- n )
[ uses>> ] [ start>> '[ n>> _ >= ] ] bi* find nip
: find-next-use ( live-interval new -- n )
[ uses>> ] [ start>> ] bi*
'[ [ spill-slot?>> not ] [ n>> ] bi _ >= and ] find nip
[ n>> ] [ 1/0. ] if* ;
: find-use-positions ( live-intervals new assoc -- )
'[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ;
'[ [ _ find-next-use ] [ reg>> ] bi _ add-use-position ] each ;
: active-positions ( new assoc -- )
[ [ active-intervals-for ] keep ] dip

36
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -16,7 +16,7 @@ TUPLE: live-range from to ;
C: <live-range> live-range
TUPLE: vreg-use n def-rep use-rep ;
TUPLE: vreg-use n def-rep use-rep spill-slot? ;
: <vreg-use> ( n -- vreg-use ) vreg-use new swap >>n ;
@ -36,8 +36,10 @@ reg-class ;
: last-use? ( insn# uses -- use/f )
[ drop f ] [ last [ n>> = ] keep and ] if-empty ;
: (add-use) ( insn# live-interval -- use )
uses>> 2dup last-use? dup [ 2nip ] [ drop new-use ] if ;
:: (add-use) ( insn# live-interval spill-slot? -- use )
live-interval uses>> :> uses
insn# uses last-use? [ insn# uses new-use ] unless*
spill-slot? [ t >>spill-slot? ] when ;
GENERIC: covers? ( insn# obj -- ? )
@ -105,28 +107,42 @@ GENERIC: compute-live-intervals* ( insn -- )
M: insn compute-live-intervals* drop ;
:: record-def ( vreg n -- )
:: record-def ( vreg n spill-slot? -- )
vreg live-interval :> live-interval
n live-interval shorten-range
n live-interval (add-use) vreg rep-of >>def-rep drop ;
n live-interval spill-slot? (add-use) vreg rep-of >>def-rep drop ;
:: record-use ( vreg n -- )
:: record-use ( vreg n spill-slot? -- )
vreg live-interval :> live-interval
from get n live-interval add-range
n live-interval (add-use) vreg rep-of >>use-rep drop ;
n live-interval spill-slot? (add-use) vreg rep-of >>use-rep drop ;
:: record-temp ( vreg n -- )
vreg live-interval :> live-interval
n n live-interval add-range
n live-interval (add-use) vreg rep-of >>def-rep drop ;
n live-interval f (add-use) vreg rep-of >>def-rep drop ;
M: vreg-insn compute-live-intervals* ( insn -- )
dup insn#>>
[ [ defs-vregs ] dip '[ _ record-def ] each ]
[ [ uses-vregs ] dip '[ _ record-use ] each ]
[ [ defs-vregs ] dip '[ _ f record-def ] each ]
[ [ uses-vregs ] dip '[ _ f record-use ] each ]
[ [ temp-vregs ] dip '[ _ record-temp ] each ]
2tri ;
M: clobber-insn compute-live-intervals* ( insn -- )
dup insn#>>
[ [ defs-vregs ] dip '[ _ f record-def ] each ]
[ [ uses-vregs ] dip '[ _ t record-use ] each ]
[ [ temp-vregs ] dip '[ _ record-temp ] each ]
2tri ;
M: hairy-clobber-insn compute-live-intervals* ( insn -- )
dup insn#>>
[ [ defs-vregs ] dip '[ _ t record-def ] each ]
[ [ uses-vregs ] dip '[ _ t record-use ] each ]
[ [ temp-vregs ] dip '[ _ record-temp ] each ]
2tri ;

109
basis/compiler/cfg/liveness/liveness-tests.factor
View File

@ -1,13 +1,19 @@
USING: compiler.cfg.liveness compiler.cfg.debugger
compiler.cfg.instructions compiler.cfg.predecessors
compiler.cfg.registers compiler.cfg cpu.architecture
accessors namespaces sequences kernel tools.test vectors ;
USING: compiler.cfg.liveness compiler.cfg.liveness.ssa
compiler.cfg.debugger compiler.cfg.instructions
compiler.cfg.predecessors compiler.cfg.registers compiler.cfg
cpu.architecture accessors namespaces sequences kernel
tools.test vectors alien math compiler.cfg.comparisons
cpu.x86.assembler.operands ;
IN: compiler.cfg.liveness.tests
: test-liveness ( -- )
cfg new 1 get >>entry
compute-live-sets ;
: test-ssa-liveness ( -- )
cfg new 1 get >>entry
compute-ssa-live-sets ;
! Sanity check...
V{
@ -30,7 +36,7 @@ V{
1 { 2 3 } edges
test-liveness
[ ] [ test-liveness ] unit-test
[
H{
@ -56,6 +62,95 @@ V{
1 2 edge
test-liveness
[ ] [ test-liveness ] unit-test
[ H{ { 0 0 } } ] [ 2 get live-in ] unit-test
[ H{ { 0 0 } } ] [ 2 get live-in ] unit-test
! Regression
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##inc-r f 2 }
T{ ##inc-d f -2 }
T{ ##peek f 21 D -1 }
T{ ##peek f 22 D -2 }
T{ ##replace f 21 R 0 }
T{ ##replace f 22 R 1 }
T{ ##branch }
} 1 test-bb
V{
T{ ##call f >c-ptr }
T{ ##branch }
} 2 test-bb
V{
T{ ##inc-r f -1 }
T{ ##inc-d f 1 }
T{ ##peek f 25 R -1 }
T{ ##replace f 25 D 0 }
T{ ##branch }
} 3 test-bb
V{
T{ ##call f >float }
T{ ##branch }
} 4 test-bb
V{
T{ ##inc-r f -1 }
T{ ##inc-d f 2 }
T{ ##peek f 27 R -1 }
T{ ##peek f 28 D 2 }
T{ ##peek f 29 D 3 }
T{ ##load-integer f 30 1 }
T{ ##load-integer f 31 0 }
T{ ##compare-imm-branch f 27 f cc/= }
} 5 test-bb
V{
T{ ##inc-d f -1 }
T{ ##branch }
} 6 test-bb
V{
T{ ##inc-d f -1 }
T{ ##branch }
} 7 test-bb
V{
T{ ##phi f 36 H{ { 6 30 } { 7 31 } } }
T{ ##inc-d f -2 }
T{ ##unbox f 37 29 "alien_offset" int-rep }
T{ ##unbox f 38 28 "to_double" double-rep }
T{ ##unbox f 39 36 "to_cell" int-rep }
T{ ##alien-invoke f V{ } V{ { 37 int-rep 0 } { 38 double-rep 4 } { 39 int-rep 12 } } { { 40 int-rep EAX } } 0 16 "CFRunLoopRunInMode" f T{ gc-map } }
T{ ##box f 41 40 "from_signed_cell" int-rep T{ gc-map } }
T{ ##replace f 41 D 0 }
T{ ##branch }
} 8 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 9 test-bb
0 1 edge
1 2 edge
2 3 edge
3 4 edge
4 5 edge
5 { 6 7 } edges
6 8 edge
7 8 edge
8 9 edge
[ ] [ test-ssa-liveness ] unit-test
[ H{ { 28 28 } { 29 29 } { 30 30 } { 31 31 } } ] [ 5 get live-out ] unit-test
[ H{ { 28 28 } { 29 29 } { 30 30 } } ] [ 6 get live-in ] unit-test
[ H{ { 28 28 } { 29 29 } { 31 31 } } ] [ 7 get live-in ] unit-test
[ H{ { 30 30 } } ] [ 6 get 8 get edge-live-in ] unit-test

17
basis/compiler/cfg/save-contexts/save-contexts-tests.factor
View File

@ -62,3 +62,20 @@ V{
] [
0 get instructions>>
] unit-test
V{
T{ ##phi }
T{ ##box }
} 0 test-bb
0 get insert-save-context
[
V{
T{ ##phi }
T{ ##save-context f 7 8 }
T{ ##box }
}
] [
0 get instructions>>
] unit-test

1
basis/compiler/cfg/save-contexts/save-contexts.factor
View File

@ -18,6 +18,7 @@ M: insn needs-save-context? drop f ;
GENERIC: modifies-context? ( insn -- ? )
M: ##phi modifies-context? drop t ;
M: ##inc-d modifies-context? drop t ;
M: ##inc-r modifies-context? drop t ;
M: ##callback-inputs modifies-context? drop t ;

1
basis/compiler/codegen/codegen.factor
View File

@ -236,6 +236,7 @@ CODEGEN: ##box-alien %box-alien
CODEGEN: ##box-displaced-alien %box-displaced-alien
CODEGEN: ##unbox-alien %unbox-alien
CODEGEN: ##unbox-any-c-ptr %unbox-any-c-ptr
CODEGEN: ##convert-integer %convert-integer
CODEGEN: ##load-memory %load-memory
CODEGEN: ##load-memory-imm %load-memory-imm
CODEGEN: ##store-memory %store-memory

19
basis/compiler/tests/alien.factor
View File

@ -6,7 +6,7 @@ math memory namespaces namespaces.private parser
quotations sequences specialized-arrays stack-checker
stack-checker.errors system threads tools.test words
alien.complex concurrency.promises alien.data
byte-arrays classes ;
byte-arrays classes compiler.test ;
FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: char
@ -804,3 +804,20 @@ mingw? [
] with-out-parameters ;
[ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test
! Alias analysis regression
: aa-callback-1 ( -- c )
double { } cdecl [ 5.0 ] alien-callback ;
: aa-indirect-1 ( c -- x )
double { } cdecl alien-indirect ; inline
TUPLE: some-tuple x ;
[ T{ some-tuple f 5.0 } ] [
[
some-tuple new
aa-callback-1
aa-indirect-1 >>x
] compile-call
] unit-test

21
basis/compiler/tests/low-level-ir.factor
View File

@ -105,3 +105,24 @@ IN: compiler.tests.low-level-ir
T{ ##add-imm f 0 0 -16 }
} compile-test-bb
] unit-test
[ -1 ] [
V{
T{ ##load-tagged f 1 $[ -1 tag-fixnum ] }
T{ ##convert-integer f 0 1 char }
} compile-test-bb
] unit-test
[ -1 ] [
V{
T{ ##load-tagged f 1 $[ -1 9 2^ bitxor tag-fixnum ] }
T{ ##convert-integer f 0 1 char }
} compile-test-bb
] unit-test
[ $[ 255 tag-bits get neg shift ] ] [
V{
T{ ##load-tagged f 1 $[ -1 9 2^ bitxor tag-fixnum ] }
T{ ##convert-integer f 0 1 uchar }
} compile-test-bb
] unit-test

5
basis/compiler/tests/simple.factor
View File

@ -1,7 +1,7 @@
USING: compiler.test compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings alien
arrays memory vocabs parser eval quotations compiler.errors
definitions ;
definitions generic.single ;
IN: compiler.tests.simple
! Test empty word
@ -249,3 +249,6 @@ M: quotation bad-effect-test call ; inline
! Don't want compiler error to stick around
[ ] [ [ M\ quotation bad-effect-test forget ] with-compilation-unit ] unit-test
! Make sure time bombs literalize
[ [ \ + call ] compile-call ] [ no-method? ] must-fail-with

6
basis/compiler/tests/tuples.factor
View File

@ -8,3 +8,9 @@ TUPLE: color red green blue ;
[ T{ color f f f f } ]
[ [ color new ] compile-call ] unit-test
SYMBOL: foo
[ [ foo new ] compile-call ] must-fail
[ [ foo boa ] compile-call ] must-fail

10
basis/compiler/tree/finalization/finalization.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences words memoize combinators
classes classes.builtin classes.tuple classes.singleton
math.partial-dispatch fry assocs combinators.short-circuit
stack-checker.dependencies
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
@ -26,6 +27,9 @@ GENERIC: finalize* ( node -- nodes )
: splice-final ( quot -- nodes ) splice-quot finalize ;
: splice-predicate ( word -- nodes )
[ depends-on-definition ] [ def>> splice-final ] bi ;
M: #copy finalize* drop f ;
M: #shuffle finalize*
@ -44,8 +48,8 @@ GENERIC: finalize-word ( #call word -- nodes )
M: predicate finalize-word
"predicating" word-prop {
{ [ dup builtin-class? ] [ drop word>> cached-expansion ] }
{ [ dup tuple-class? ] [ drop word>> def>> splice-final ] }
{ [ dup singleton-class? ] [ drop word>> def>> splice-final ] }
{ [ dup tuple-class? ] [ drop word>> splice-predicate ] }
{ [ dup singleton-class? ] [ drop word>> splice-predicate ] }
[ drop ]
} cond ;

2
basis/cpu/architecture/architecture.factor
View File

@ -473,6 +473,8 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-alien cpu ( dst src temp -- )
HOOK: %box-displaced-alien cpu ( dst displacement base temp base-class -- )
HOOK: %convert-integer cpu ( dst src c-type -- )
HOOK: %load-memory cpu ( dst base displacement scale offset rep c-type -- )
HOOK: %load-memory-imm cpu ( dst base offset rep c-type -- )
HOOK: %store-memory cpu ( value base displacement scale offset rep c-type -- )

2
basis/cpu/x86/32/32.factor
View File

@ -209,6 +209,8 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
#! MINGW ABI incompatibility disaster
[ large-struct? ] [ mingw eq? os windows? not or ] bi* and ;
M: x86.32 %prepare-var-args ( -- ) ;
M:: x86.32 stack-cleanup ( stack-size return abi -- n )
#! a) Functions which are stdcall/fastcall/thiscall have to
#! clean up the caller's stack frame.

2
basis/cpu/x86/64/64.factor
View File

@ -140,6 +140,8 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
func "libm" load-library f %c-invoke
dst double-rep %load-return ;
M: x86.64 %prepare-var-args ( -- ) RAX RAX XOR ;
M: x86.64 stack-cleanup 3drop 0 ;
M: x86.64 %cleanup 0 assert= ;

24
basis/cpu/x86/x86.factor
View File

@ -345,6 +345,29 @@ M: x86.64 has-small-reg? 2drop t ;
[ quot call ] with-save/restore
] if ; inline
:: (%convert-integer) ( dst src bits quot -- )
dst { src } bits [| new-dst |
new-dst src int-rep %copy
new-dst dup bits n-bit-version-of quot call
dst new-dst int-rep %copy
] with-small-register ; inline
: %zero-extend ( dst src bits -- )
[ MOVZX ] (%convert-integer) ; inline
: %sign-extend ( dst src bits -- )
[ MOVSX ] (%convert-integer) ; inline
M: x86 %convert-integer ( dst src c-type -- )
{
{ c:char [ 8 %sign-extend ] }
{ c:uchar [ 8 %zero-extend ] }
{ c:short [ 16 %sign-extend ] }
{ c:ushort [ 16 %zero-extend ] }
{ c:int [ 32 %sign-extend ] }
{ c:uint [ 32 [ 2drop ] (%convert-integer) ] }
} case ;
:: %alien-integer-getter ( dst exclude address bits quot -- )
dst exclude bits [| new-dst |
new-dst dup bits n-bit-version-of dup address MOV
@ -621,6 +644,7 @@ HOOK: %cleanup cpu ( n -- )
:: emit-alien-insn ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot -- )
stack-inputs [ first3 %store-stack-param ] each
reg-inputs [ first3 %store-reg-param ] each
%prepare-var-args
quot call
cleanup %cleanup
reg-outputs [ first3 %load-reg-param ] each ; inline

6
basis/io/files/unix/unix-tests.factor
View File

@ -94,7 +94,7 @@ prepare-test-file
test-file now
[ set-file-access-time ] 2keep
[ file-info accessed>> ]
[ [ [ truncate >integer ] change-second ] bi@ ] bi* =
[ [ [ truncate >integer ] change-second >gmt ] bi@ ] bi* =
] unit-test
[ t ]
@ -102,7 +102,7 @@ prepare-test-file
test-file now
[ set-file-modified-time ] 2keep
[ file-info modified>> ]
[ [ [ truncate >integer ] change-second ] bi@ ] bi* =
[ [ [ truncate >integer ] change-second >gmt ] bi@ ] bi* =
] unit-test
[ t ]
@ -110,7 +110,7 @@ prepare-test-file
test-file now [ dup 2array set-file-times ] 2keep
[ file-info [ modified>> ] [ accessed>> ] bi ] dip
3array
[ [ truncate >integer ] change-second ] map all-equal?
[ [ truncate >integer ] change-second >gmt ] map all-equal?
] unit-test
[ ] [ test-file f now 2array set-file-times ] unit-test

2
basis/math/matrices/matrices-tests.factor
View File

@ -103,7 +103,7 @@ USING: math.matrices math.vectors tools.test math ;
[ { 1 0 0 } ] [ { 0 1 0 } { 0 0 1 } cross ] unit-test
[ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test
[ { 0.0 -0.707 0.707 } ] [ { 1.0 0.0 0.0 } { 0.0 0.707 0.707 } cross ] unit-test
[ { 0 -2 2 } ] [ { -1 -1 -1 } { 1 -1 -1 } cross ] unit-test
[ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
[ { { 4181 6765 } { 6765 10946 } } ]

3
basis/math/matrices/matrices.factor
View File

@ -114,6 +114,9 @@ IN: math.matrices
[ [ { 1 2 0 } vshuffle ] [ { 2 0 1 } vshuffle ] bi* v* ]
[ [ { 2 0 1 } vshuffle ] [ { 1 2 0 } vshuffle ] bi* v* ] 2bi v- ; inline
:: normal ( vec1 vec2 vec3 -- vec4 )
vec2 vec1 v- vec3 vec1 v- cross normalize ; inline
: proj ( v u -- w )
[ [ v. ] [ norm-sq ] bi / ] keep n*v ;

4
basis/math/vectors/simd/simd-tests.factor
View File

@ -616,10 +616,14 @@ STRUCT: simd-struct
! Test cross product
[ float-4{ 0.0 0.0 1.0 0.0 } ] [ float-4{ 1.0 0.0 0.0 0.0 } float-4{ 0.0 1.0 0.0 0.0 } cross ] unit-test
[ float-4{ 0.0 0.0 1.0 0.0 } ] [ float-4{ 1.0 0.0 0.0 0.0 } float-4{ 0.0 1.0 0.0 0.0 } [ { float-4 float-4 } declare cross ] compile-call ] unit-test
[ float-4{ 0.0 -1.0 0.0 0.0 } ] [ float-4{ 1.0 0.0 0.0 0.0 } float-4{ 0.0 0.0 1.0 0.0 } cross ] unit-test
[ float-4{ 0.0 -1.0 0.0 0.0 } ] [ float-4{ 1.0 0.0 0.0 0.0 } float-4{ 0.0 0.0 1.0 0.0 } [ { float-4 float-4 } declare cross ] compile-call ] unit-test
[ double-4{ 0.0 0.0 1.0 0.0 } ] [ double-4{ 1.0 0.0 0.0 0.0 } double-4{ 0.0 1.0 0.0 0.0 } cross ] unit-test
[ double-4{ 0.0 0.0 1.0 0.0 } ] [ double-4{ 1.0 0.0 0.0 0.0 } double-4{ 0.0 1.0 0.0 0.0 } [ { double-4 double-4 } declare cross ] compile-call ] unit-test
[ double-4{ 0.0 -1.0 0.0 0.0 } ] [ double-4{ 1.0 0.0 0.0 0.0 } double-4{ 0.0 0.0 1.0 0.0 } cross ] unit-test
[ double-4{ 0.0 -1.0 0.0 0.0 } ] [ double-4{ 1.0 0.0 0.0 0.0 } double-4{ 0.0 0.0 1.0 0.0 } [ { double-4 double-4 } declare cross ] compile-call ] unit-test
! CSSA bug
[ 4000000 ] [

61
basis/regexp/regexp-tests.factor
View File

@ -1,7 +1,5 @@
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: regexp tools.test kernel sequences regexp.parser regexp.private
eval strings multiline accessors ;
USING: arrays regexp tools.test kernel sequences regexp.parser
regexp.private eval strings multiline accessors ;
IN: regexp-tests
[ f ] [ "b" "a*" <regexp> matches? ] unit-test
@ -241,6 +239,9 @@ IN: regexp-tests
[ t ] [ 3 "xabc" R/ abc/r match-index-from >boolean ] unit-test
[ t ] [ 3 "xabc" R/ a[bB][cC]/r match-index-from >boolean ] unit-test
[ 2 ] [ 0 "llamallol" R/ ll/ match-index-from ] unit-test
[ 5 ] [ 8 "lolmallol" R/ lol/r match-index-from ] unit-test
[ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
[ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
[ t ] [ ".o" "\\.[a-z]" <regexp> matches? ] unit-test
@ -272,6 +273,10 @@ IN: regexp-tests
[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match >string ] unit-test
[ T{ slice { from 5 } { to 10 } { seq "hellohello" } } ]
[ "hellohello" R/ hello/r first-match ]
unit-test
[ { "1" "2" "3" "4" } ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
@ -282,18 +287,52 @@ IN: regexp-tests
[ { "a" "" } ] [ "a=" R/ =/ re-split [ >string ] map ] unit-test
[ { "he" "o" } ] [ "hello" R/ l+/ re-split [ >string ] map ] unit-test
[ { "h" "llo" } ] [ "hello" R/ e+/ re-split [ >string ] map ] unit-test
[ { "" "h" "" "l" "l" "o" "" } ] [ "hello" R/ e*/ re-split [ >string ] map ] unit-test
[ { { 0 5 "hellohello" } { 5 10 "hellohello" } } ]
[ "hellohello" R/ hello/ [ 3array ] map-matches ]
unit-test
[ { { 5 10 "hellohello" } { 0 5 "hellohello" } } ]
[ "hellohello" R/ hello/r [ 3array ] map-matches ]
unit-test
[ { "ABC" "DEF" "GHI" } ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matching-subseqs ] unit-test
[ 3 ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ count-matches ] unit-test
[ { "ee" "e" } ] [ "heellohello" R/ e+/ all-matching-subseqs ] unit-test
[ { "e" "ee" } ] [ "heellohello" R/ e+/r all-matching-subseqs ] unit-test
[ 0 ]
[ "123" R/ [A-Z]+/ count-matches ] unit-test
[ 3 ] [ "1ABC2DEF3GHI4" R/ [A-Z]+/ count-matches ] unit-test
[ "1.2.3.4." ]
[ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ "." re-replace ] unit-test
[ 3 ] [ "1ABC2DEF3GHI4" R/ [A-Z]+/r count-matches ] unit-test
[ 1 ] [ "" R/ / count-matches ] unit-test
[ 1 ] [ "" R/ /r count-matches ] unit-test
[ 0 ] [ "123" R/ [A-Z]+/ count-matches ] unit-test
[ 0 ] [ "123" R/ [A-Z]+/r count-matches ] unit-test
[ 6 ] [ "hello" R/ e*/ count-matches ] unit-test
[ 6 ] [ "hello" R/ e*/r count-matches ] unit-test
[ 11 ] [ "hello world" R/ l*/ count-matches ] unit-test
[ 11 ] [ "hello world" R/ l*/r count-matches ] unit-test
[ 1 ] [ "hello" R/ e+/ count-matches ] unit-test
[ 2 ] [ "hello world" R/ l+/r count-matches ] unit-test
[ "1.2.3.4." ] [ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ "." re-replace ] unit-test
[ "XhXXlXlXoX XwXoXrXlXdX" ] [ "hello world" R/ e*/ "X" re-replace ] unit-test
[ "-- title --" ] [ "== title ==" R/ =/ "-" re-replace ] unit-test
[ "" ] [ "ab" "a(?!b)" <regexp> first-match >string ] unit-test

68
basis/regexp/regexp.factor
View File

@ -50,33 +50,49 @@ PRIVATE>
<PRIVATE
:: (next-match) ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? )
i string regexp quot call dup [| j |
j i j
reverse? [ swap [ 1 + ] bi@ ] when
string
] [ drop f f f f ] if ; inline
: search-range ( i string reverse? -- seq )
[ drop dup 1 + -1 ] [ length 1 ] if range boa ; inline
[ drop -1 ] [ length ] if [a,b] ; inline
:: next-match ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? )
f f f f
:: (next-match) ( i string regexp quot: ( i string regexp -- j ) reverse? -- start end ? )
i string regexp quot call dup
[| j | reverse? [ j i ] [ i j ] if string ] [ drop f f f ] if ; inline
:: next-match ( i string regexp quot: ( i string regexp -- j ) reverse? -- start end ? )
f f f
i string reverse? search-range
[ [ 2drop 2drop ] dip string regexp quot reverse? (next-match) dup ] find 2drop ; inline
[ [ 3drop ] dip string regexp quot reverse? (next-match) dup ] find 2drop ; inline
: do-next-match ( i string regexp -- i start end ? )
: do-next-match ( i string regexp -- start end ? )
dup next-match>>
execute( i string regexp -- i start end ? ) ; inline
execute( i string regexp -- start end ? ) ; inline
:: (each-match) ( ... i string regexp quot: ( ... start end string -- ... ) -- ... )
i string regexp do-next-match [| i' start end |
start end string quot call
i' string regexp quot (each-match)
] [ 3drop ] if ; inline recursive
:: (each-match-forward) ( ... i string regexp quot: ( ... start end string -- ... ) -- ... )
i string length <= [
i string regexp do-next-match [| start end |
start end string quot call
start end eq? [ end 1 + ] [ end ] if
string regexp quot (each-match-forward)
] [ 2drop ] if
] when ; inline recursive
:: (each-match-backward) ( ... i string regexp quot: ( ... start end string -- ... ) -- ... )
i -1 >= [
i string regexp do-next-match [| start end |
start 1 + end 1 + string quot call
start end eq? [ start 1 - ] [ start ] if
string regexp quot (each-match-backward)
] [ 2drop ] if
] when ; inline recursive
: (each-match) ( ... i string regexp quot: ( ... start end string -- ... ) -- ... )
over reverse-regexp? [ (each-match-backward) ] [ (each-match-forward) ] if ; inline
GENERIC: match-iterator-start ( string regexp -- start )
M: regexp match-iterator-start 2drop 0 ;
M: reverse-regexp match-iterator-start drop length ;
: prepare-match-iterator ( string regexp -- i string regexp )
[ check-string ] dip [ end/start nip ] 2keep ; inline
[ check-string ] dip [ match-iterator-start ] 2keep ; inline
PRIVATE>
@ -107,12 +123,14 @@ PRIVATE>
PRIVATE>
: first-match ( string regexp -- slice/f )
[ prepare-match-iterator do-next-match ] [ drop ] 2bi
'[ _ slice boa nip ] [ 3drop f ] if ;
:: first-match ( string regexp -- slice/f )
string regexp prepare-match-iterator do-next-match [
regexp reverse-regexp? [ [ 1 + ] bi@ ] when
string slice boa
] [ 2drop f ] if ;
: re-contains? ( string regexp -- ? )
prepare-match-iterator do-next-match [ 3drop ] dip >boolean ;
prepare-match-iterator do-next-match [ 2drop ] dip >boolean ;
: re-split ( string regexp -- seq )
[ slice boa ] (re-split) ;
@ -141,7 +159,7 @@ M: reverse-regexp compile-regexp ( regexp -- regexp )
DEFER: compile-next-match
: next-initial-word ( i string regexp -- i start end string )
: next-initial-word ( i string regexp -- start end string )
[ compile-next-match ] with-compilation-unit do-next-match ;
: compile-next-match ( regexp -- regexp )
@ -149,7 +167,7 @@ DEFER: compile-next-match
dup \ next-initial-word = [
drop _ [ compile-regexp dfa>> def>> ] [ reverse-regexp? ] bi
'[ { array-capacity string regexp } declare _ _ next-match ]
(( i string regexp -- i start end string )) define-temp
(( i string regexp -- start end string )) define-temp
] when
] change-next-match ;

12
basis/stack-checker/backend/backend.factor
View File

@ -110,13 +110,11 @@ M: object apply-object push-literal ;
infer-quot-here
] dip recursive-state set ;
: time-bomb ( error -- )
'[ _ throw ] infer-quot-here ;
: time-bomb-quot ( obj generic -- quot )
[ literalize ] [ "default-method" word-prop ] bi* [ ] 2sequence ;
ERROR: bad-call obj ;
M: bad-call summary
drop "call must be given a callable" ;
: time-bomb ( obj generic -- )
time-bomb-quot infer-quot-here ;
: infer-literal-quot ( literal -- )
dup recursive-quotation? [
@ -127,7 +125,7 @@ M: bad-call summary
[ [ recursion>> ] keep add-local-quotation ]
bi infer-quot
] [
value>> \ bad-call boa time-bomb
value>> \ call time-bomb
] if
] if ;

7
basis/stack-checker/known-words/known-words.factor
View File

@ -156,17 +156,12 @@ M: object infer-call* \ call bad-macro-input ;
\ compose [ infer-compose ] "special" set-word-prop
ERROR: bad-executable obj ;
M: bad-executable summary
drop "execute must be given a word" ;
: infer-execute ( -- )
pop-literal nip
dup word? [
apply-object
] [
\ bad-executable boa time-bomb
\ execute time-bomb
] if ;
\ execute [ infer-execute ] "special" set-word-prop

4
basis/stack-checker/transforms/transforms.factor
View File

@ -145,7 +145,9 @@ IN: stack-checker.transforms
[ depends-on-tuple-layout ]
[ [ "boa-check" word-prop [ ] or ] dip ] 2bi
'[ @ _ <tuple-boa> ]
] [ drop f ] if
] [
\ boa time-bomb
] if
] 1 define-transform
\ boa t "no-compile" set-word-prop

4
basis/ui/gadgets/labels/labels.factor
View File

@ -106,12 +106,12 @@ M: f >label drop <gadget> ;
{ 5 5 } >>gap ; inline
PRIVATE>
: label-on-left ( gadget label -- button )
: label-on-left ( gadget label -- track )
label-on-left/right
swap >label f track-add
swap 1 track-add ;
: label-on-right ( label gadget -- button )
: label-on-right ( label gadget -- track )
label-on-left/right
swap f track-add
swap >label 1 track-add ;

11
basis/ui/gadgets/worlds/worlds.factor
View File

@ -129,6 +129,7 @@ M: world request-focus-on ( child gadget -- )
[ T{ rgba f 1.0 1.0 1.0 1.0 } ] if ;
GENERIC# apply-world-attributes 1 ( world attributes -- world )
M: world apply-world-attributes
{
[ title>> >>title ]
@ -166,15 +167,11 @@ flush-layout-cache-hook [ [ ] ] initialize
GENERIC: begin-world ( world -- )
GENERIC: end-world ( world -- )
GENERIC: resize-world ( world -- )
M: world begin-world
drop ;
M: world end-world
drop ;
M: world resize-world
drop ;
M: world begin-world drop ;
M: world end-world drop ;
M: world resize-world drop ;
M: world dim<<
[ call-next-method ]

7
basis/ui/ui.factor
View File

@ -81,6 +81,9 @@ M: world graft*
[ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
] bi ;
: dispose-window-resources ( world -- )
[ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ;
M: world ungraft*
{
[ set-gl-context ]
@ -89,9 +92,9 @@ M: world ungraft*
[ hand-clicked close-global ]
[ hand-gadget close-global ]
[ end-world ]
[ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
[ [ (close-window) f ] change-handle drop ]
[ dispose-window-resources ]
[ unfocus-world ]
[ [ (close-window) f ] change-handle drop ]
[ promise>> t swap fulfill ]
} cleave ;

6
core/classes/tuple/tuple-tests.factor
View File

@ -273,8 +273,14 @@ test-server-slot-values
! Dynamically changing inheritance hierarchy
TUPLE: electronic-device ;
: computer?' ( a -- b ) computer? ;
[ t ] [ laptop new computer?' ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
[ t ] [ laptop new computer?' ] unit-test
[ f ] [ electronic-device laptop class<= ] unit-test
[ t ] [ server electronic-device class<= ] unit-test
[ t ] [ laptop server class-or electronic-device class<= ] unit-test

77
extra/gdbm/gdbm-tests.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2010 Dmitry Shubin.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays continuations gdbm io.directories
io.files.temp kernel sequences sets tools.test ;
io.files.temp kernel sequences sets system tools.test ;
IN: gdbm.tests
: db-path ( -- filename ) "test.db" temp-file ;
@ -12,52 +12,53 @@ IN: gdbm.tests
: with-test.db ( quot -- ) test.db swap with-gdbm ; inline
CLEANUP
os windows? cpu x86.64? and [
CLEANUP
[
test.db reader >>role [ ] with-gdbm
] [ gdbm-file-open-error = ] must-fail-with
[ f ] [ [ "foo" exists? ] with-test.db ] unit-test
[ ] [ [ "foo" 41 insert ] with-test.db ] unit-test
[
db-path [ "foo" 42 insert ] with-gdbm-writer
] [ gdbm-cannot-replace = ] must-fail-with
[ ]
[
[
"foo" 42 replace
"bar" 43 replace
"baz" 44 replace
] with-test.db
] unit-test
test.db reader >>role [ ] with-gdbm
] [ gdbm-file-open-error = ] must-fail-with
[ 42 t ] [ db-path [ "foo" fetch* ] with-gdbm-reader ] unit-test
[ f ] [ [ "foo" exists? ] with-test.db ] unit-test
[ f f ] [ [ "unknown" fetch* ] with-test.db ] unit-test
[ ] [ [ "foo" 41 insert ] with-test.db ] unit-test
[
[
300 set-cache-size 300 set-cache-size
] with-test.db
] [ gdbm-option-already-set = ] must-fail-with
db-path [ "foo" 42 insert ] with-gdbm-writer
] [ gdbm-cannot-replace = ] must-fail-with
[ t ]
[
V{ } [ [ 2array append ] each-record ] with-test.db
V{ "foo" "bar" "baz" 42 43 44 } set=
[ ]
[
[
"foo" 42 replace
"bar" 43 replace
"baz" 44 replace
] with-test.db
] unit-test
] unit-test
[ 42 t ] [ db-path [ "foo" fetch* ] with-gdbm-reader ] unit-test
[ f ]
[
test.db newdb >>role [ "foo" exists? ] with-gdbm
] unit-test
[ f f ] [ [ "unknown" fetch* ] with-test.db ] unit-test
[
[
300 set-cache-size 300 set-cache-size
] with-test.db
] [ gdbm-option-already-set = ] must-fail-with
[ t ]
[
V{ } [ [ 2array append ] each-record ] with-test.db
V{ "foo" "bar" "baz" 42 43 44 } set=
] unit-test
[ f ]
[
test.db newdb >>role [ "foo" exists? ] with-gdbm
] unit-test
CLEANUP
CLEANUP
] unless

4
extra/gpu/demos/bunny/bunny.factor
View File

@ -119,10 +119,6 @@ UNIFORM-TUPLE: loading-uniforms
100000 <uint-vector>
(parse-bunny-model) ; inline
:: normal ( a b c -- normal )
c a v-
b a v- cross normalize ; inline
:: calc-bunny-normal ( a b c vertexes -- )
a b c [ vertexes nth vertex>> ] tri@ normal :> n
a b c [ vertexes nth [ n v+ ] change-normal drop ] tri@ ; inline

17
vm/alien.cpp
View File

@ -27,11 +27,6 @@ char *factor_vm::pinned_alien_offset(cell obj)
}
}
VM_C_API char *pinned_alien_offset(cell obj, factor_vm *parent)
{
return parent->pinned_alien_offset(obj);
}
/* make an alien */
cell factor_vm::allot_alien(cell delegate_, cell displacement)
{
@ -62,11 +57,6 @@ cell factor_vm::allot_alien(void *address)
return allot_alien(false_object,(cell)address);
}
VM_C_API cell allot_alien(void *address, factor_vm *vm)
{
return vm->allot_alien(address);
}
/* make an alien pointing at an offset of another alien */
void factor_vm::primitive_displaced_alien()
{
@ -90,7 +80,7 @@ void factor_vm::primitive_displaced_alien()
if the object is a byte array, as a sanity check. */
void factor_vm::primitive_alien_address()
{
ctx->push(allot_cell((cell)pinned_alien_offset(ctx->pop())));
ctx->push(from_unsigned_cell((cell)pinned_alien_offset(ctx->pop())));
}
/* pop ( alien n ) from datastack, return alien's address plus n */
@ -182,9 +172,4 @@ char *factor_vm::alien_offset(cell obj)
}
}
VM_C_API char *alien_offset(cell obj, factor_vm *parent)
{
return parent->alien_offset(obj);
}
}

4
vm/alien.hpp
View File

@ -1,8 +1,4 @@
namespace factor
{
VM_C_API char *alien_offset(cell object, factor_vm *vm);
VM_C_API char *pinned_alien_offset(cell object, factor_vm *vm);
VM_C_API cell allot_alien(void *address, factor_vm *vm);
}

7
vm/code_heap.cpp
View File

@ -222,9 +222,10 @@ struct code_block_accumulator {
/* Note: the entry point is always a multiple of the heap
alignment (16 bytes). We cannot allocate while iterating
through the code heap, so it is not possible to call allot_cell()
here. It is OK, however, to add it as if it were a fixnum, and
have library code shift it to the left by 4. */
through the code heap, so it is not possible to call
from_unsigned_cell() here. It is OK, however, to add it as
if it were a fixnum, and have library code shift it to the
left by 4. */
cell entry_point = (cell)compiled->entry_point();
assert((entry_point & (data_alignment - 1)) == 0);
assert((entry_point & TAG_MASK) == FIXNUM_TYPE);

4
vm/errors.cpp
View File

@ -102,12 +102,12 @@ void factor_vm::memory_protection_error(cell addr, stack_frame *stack)
else if(ctx->callstack_seg->overflow_p(addr))
general_error(ERROR_CALLSTACK_UNDERFLOW,false_object,false_object,stack);
else
general_error(ERROR_MEMORY,allot_cell(addr),false_object,stack);
general_error(ERROR_MEMORY,from_unsigned_cell(addr),false_object,stack);
}
void factor_vm::signal_error(cell signal, stack_frame *stack)
{
general_error(ERROR_SIGNAL,allot_cell(signal),false_object,stack);
general_error(ERROR_SIGNAL,from_unsigned_cell(signal),false_object,stack);
}
void factor_vm::divide_by_zero_error()

96
vm/math.cpp
View File

@ -21,7 +21,7 @@ void factor_vm::primitive_fixnum_divint()
fixnum x = untag_fixnum(ctx->peek());
fixnum result = x / y;
if(result == -fixnum_min)
ctx->replace(allot_integer(-fixnum_min));
ctx->replace(from_signed_cell(-fixnum_min));
else
ctx->replace(tag_fixnum(result));
}
@ -32,7 +32,7 @@ void factor_vm::primitive_fixnum_divmod()
cell x = ((cell *)ctx->datastack)[-1];
if(y == tag_fixnum(-1) && x == tag_fixnum(fixnum_min))
{
((cell *)ctx->datastack)[-1] = allot_integer(-fixnum_min);
((cell *)ctx->datastack)[-1] = from_signed_cell(-fixnum_min);
((cell *)ctx->datastack)[0] = tag_fixnum(0);
}
else
@ -335,7 +335,7 @@ void factor_vm::primitive_float_greatereq()
void factor_vm::primitive_float_bits()
{
ctx->push(from_unsigned_4(float_bits((float)untag_float_check(ctx->pop()))));
ctx->push(from_unsigned_cell(float_bits((float)untag_float_check(ctx->pop()))));
}
void factor_vm::primitive_bits_float()
@ -383,76 +383,6 @@ VM_C_API cell to_cell(cell tagged, factor_vm *parent)
return parent->to_cell(tagged);
}
cell factor_vm::from_signed_1(s8 n)
{
return tag_fixnum(n);
}
VM_C_API cell from_signed_1(s8 n, factor_vm *parent)
{
return parent->from_signed_1(n);
}
cell factor_vm::from_unsigned_1(u8 n)
{
return tag_fixnum(n);
}
VM_C_API cell from_unsigned_1(u8 n, factor_vm *parent)
{
return parent->from_unsigned_1(n);
}
cell factor_vm::from_signed_2(s16 n)
{
return tag_fixnum(n);
}
VM_C_API cell from_signed_2(s16 n, factor_vm *parent)
{
return parent->from_signed_2(n);
}
cell factor_vm::from_unsigned_2(u16 n)
{
return tag_fixnum(n);
}
VM_C_API cell from_unsigned_2(u16 n, factor_vm *parent)
{
return parent->from_unsigned_2(n);
}
cell factor_vm::from_signed_4(s32 n)
{
return allot_integer(n);
}
VM_C_API cell from_signed_4(s32 n, factor_vm *parent)
{
return parent->from_signed_4(n);
}
cell factor_vm::from_unsigned_4(u32 n)
{
return allot_cell(n);
}
VM_C_API cell from_unsigned_4(u32 n, factor_vm *parent)
{
return parent->from_unsigned_4(n);
}
cell factor_vm::from_signed_cell(fixnum integer)
{
return allot_integer(integer);
}
cell factor_vm::from_unsigned_cell(cell integer)
{
return allot_cell(integer);
}
VM_C_API cell from_signed_cell(fixnum integer, factor_vm *parent)
{
return parent->from_signed_cell(integer);
@ -529,38 +459,18 @@ VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent)
return parent->to_unsigned_8(obj);
}
VM_C_API cell from_float(float flo, factor_vm *parent)
{
return parent->allot_float(flo);
}
/* Cannot allocate */
float factor_vm::to_float(cell value)
{
return (float)untag_float_check(value);
}
VM_C_API float to_float(cell value, factor_vm *parent)
{
return parent->to_float(value);
}
VM_C_API cell from_double(double flo, factor_vm *parent)
{
return parent->allot_float(flo);
}
/* Cannot allocate */
double factor_vm::to_double(cell value)
{
return untag_float_check(value);
}
VM_C_API double to_double(cell value, factor_vm *parent)
{
return parent->to_double(value);
}
/* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On
overflow, they call these functions. */
inline void factor_vm::overflow_fixnum_add(fixnum x, fixnum y)

15
vm/math.hpp
View File

@ -5,7 +5,7 @@ static const fixnum fixnum_max = (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
static const fixnum fixnum_min = (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)));
static const fixnum array_size_max = ((cell)1 << (WORD_SIZE - TAG_BITS - 2));
inline cell factor_vm::allot_integer(fixnum x)
inline cell factor_vm::from_signed_cell(fixnum x)
{
if(x < fixnum_min || x > fixnum_max)
return tag<bignum>(fixnum_to_bignum(x));
@ -13,7 +13,7 @@ inline cell factor_vm::allot_integer(fixnum x)
return tag_fixnum(x);
}
inline cell factor_vm::allot_cell(cell x)
inline cell factor_vm::from_unsigned_cell(cell x)
{
if(x > (cell)fixnum_max)
return tag<bignum>(cell_to_bignum(x));
@ -74,17 +74,6 @@ inline cell factor_vm::unbox_array_size()
return unbox_array_size_slow();
}
VM_C_API cell from_float(float flo, factor_vm *vm);
VM_C_API float to_float(cell value, factor_vm *vm);
VM_C_API cell from_double(double flo, factor_vm *vm);
VM_C_API double to_double(cell value, factor_vm *vm);
VM_C_API cell from_signed_1(s8 n, factor_vm *vm);
VM_C_API cell from_unsigned_1(u8 n, factor_vm *vm);
VM_C_API cell from_signed_2(s16 n, factor_vm *vm);
VM_C_API cell from_unsigned_2(u16 n, factor_vm *vm);
VM_C_API cell from_signed_4(s32 n, factor_vm *vm);
VM_C_API cell from_unsigned_4(u32 n, factor_vm *vm);
VM_C_API cell from_signed_cell(fixnum integer, factor_vm *vm);
VM_C_API cell from_unsigned_cell(cell integer, factor_vm *vm);
VM_C_API cell from_signed_8(s64 n, factor_vm *vm);

2
vm/objects.cpp
View File

@ -79,7 +79,7 @@ cell factor_vm::object_size(cell tagged)
void factor_vm::primitive_size()
{
ctx->push(allot_cell(object_size(ctx->pop())));
ctx->push(from_unsigned_cell(object_size(ctx->pop())));
}
struct slot_become_fixup : no_fixup {

12
vm/primitives.hpp
View File

@ -138,12 +138,12 @@ namespace factor
_(unsigned_cell,cell,from_unsigned_cell,to_cell) \
_(signed_8,s64,from_signed_8,to_signed_8) \
_(unsigned_8,u64,from_unsigned_8,to_unsigned_8) \
_(signed_4,s32,from_signed_4,to_fixnum) \
_(unsigned_4,u32,from_unsigned_4,to_cell) \
_(signed_2,s16,from_signed_2,to_fixnum) \
_(unsigned_2,u16,from_unsigned_2,to_cell) \
_(signed_1,s8,from_signed_1,to_fixnum) \
_(unsigned_1,u8,from_unsigned_1,to_cell) \
_(signed_4,s32,from_signed_cell,to_fixnum) \
_(unsigned_4,u32,from_unsigned_cell,to_cell) \
_(signed_2,s16,from_signed_cell,to_fixnum) \
_(unsigned_2,u16,from_unsigned_cell,to_cell) \
_(signed_1,s8,from_signed_cell,to_fixnum) \
_(unsigned_1,u8,from_unsigned_cell,to_cell) \
_(float,float,allot_float,to_float) \
_(double,double,allot_float,to_double) \
_(cell,void *,allot_alien,pinned_alien_offset)

4
vm/quotations.cpp
View File

@ -328,8 +328,8 @@ void factor_vm::primitive_quotation_code()
{
quotation *quot = untag_check<quotation>(ctx->pop());
ctx->push(allot_cell((cell)quot->code->entry_point()));
ctx->push(allot_cell((cell)quot->code + quot->code->size()));
ctx->push(from_unsigned_cell((cell)quot->code->entry_point()));
ctx->push(from_unsigned_cell((cell)quot->code + quot->code->size()));
}
/* Allocates memory */

12
vm/vm.hpp
View File

@ -475,14 +475,6 @@ struct factor_vm
void primitive_bits_double();
fixnum to_fixnum(cell tagged);
cell to_cell(cell tagged);
cell from_signed_1(s8 n);
cell from_unsigned_1(u8 n);
cell from_signed_2(s16 n);
cell from_unsigned_2(u16 n);
cell from_signed_4(s32 n);
cell from_unsigned_4(u32 n);
cell from_signed_cell(fixnum integer);
cell from_unsigned_cell(cell integer);
cell from_signed_8(s64 n);
s64 to_signed_8(cell obj);
cell from_unsigned_8(u64 n);
@ -492,8 +484,8 @@ struct factor_vm
inline void overflow_fixnum_add(fixnum x, fixnum y);
inline void overflow_fixnum_subtract(fixnum x, fixnum y);
inline void overflow_fixnum_multiply(fixnum x, fixnum y);
inline cell allot_integer(fixnum x);
inline cell allot_cell(cell x);
inline cell from_signed_cell(fixnum x);
inline cell from_unsigned_cell(cell x);
inline cell allot_float(double n);
inline bignum *float_to_bignum(cell tagged);
inline double bignum_to_float(cell tagged);

8
vm/words.cpp
View File

@ -91,13 +91,13 @@ void factor_vm::primitive_word_code()
if(profiling_p)
{
ctx->push(allot_cell((cell)w->profiling->entry_point()));
ctx->push(allot_cell((cell)w->profiling + w->profiling->size()));
ctx->push(from_unsigned_cell((cell)w->profiling->entry_point()));
ctx->push(from_unsigned_cell((cell)w->profiling + w->profiling->size()));
}
else
{
ctx->push(allot_cell((cell)w->code->entry_point()));
ctx->push(allot_cell((cell)w->code + w->code->size()));
ctx->push(from_unsigned_cell((cell)w->code->entry_point()));
ctx->push(from_unsigned_cell((cell)w->code + w->code->size()));
}
}