[ { vector } declare length>> ]
count-unboxed-allocations
] unit-test
+
+! Bug found while tweaking benchmark.raytracer-simd
+
+TUPLE: point-2d { x read-only } { y read-only } ;
+TUPLE: point-3d < point-2d { z read-only } ;
+
+[ 0 ] [
+ [ { point-2d } declare dup point-3d? [ z>> ] [ x>> ] if ]
+ count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+ [ point-2d boa dup point-3d? [ z>> ] [ x>> ] if ]
+ count-unboxed-allocations
+] unit-test
: record-tuple-allocation ( #call -- )
dup immutable-tuple-boa?
- [ [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ]
+ [ [ in-d>> but-last { } like ] [ out-d>> first ] bi record-allocation ]
[ record-unknown-allocation ]
if ;
: slot-offset ( #call -- n/f )
- dup in-d>>
- [ second node-value-info literal>> ]
- [ first node-value-info class>> ] 2bi
- 2dup [ fixnum? ] [ tuple class<= ] bi* and [
- over 2 >= [ drop 2 - ] [ 2drop f ] if
+ dup in-d>> second node-value-info literal>> dup [ 2 - ] when ;
+
+: valid-slot-offset? ( slot# in -- ? )
+ over [
+ allocation dup [
+ dup array? [ bounds-check? ] [ 2drop f ] if
+ ] [ 2drop t ] if
] [ 2drop f ] if ;
+: unknown-slot-call ( out slot# in -- )
+ [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ;
+
: record-slot-call ( #call -- )
- [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri over
+ [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
+ 2dup valid-slot-offset?
[ [ record-slot-access ] [ copy-slot-value ] 3bi ]
- [ [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ]
+ [ unknown-slot-call ]
if ;
M: #call escape-analysis*
! Speeds up 2^
: 2^? ( #call -- ? )
- in-d>> first2 [ value-info ] bi@
- [ { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ]
- [ class>> fixnum class<= ]
- bi* and ;
+ in-d>> first value-info literal>> 1 eq? ;
\ shift [
- 2^? [
+ 2^? [
cell-bits tag-bits get - 1 -
'[
>fixnum dup 0 < [ 2drop 0 ] [
] with-destructors ;
: <fd> ( n -- fd )
- #! We drop the error code rather than calling io-error,
- #! since on OS X 10.3, this operation fails from init-io
- #! when running the Factor.app (presumably because fd 0 and
- #! 1 are closed).
fd new-disposable swap >>fd ;
M: fd dispose
[ drop 0 ] [ (io-error) ] if
] when ;
-: ?flag ( n mask symbol -- n )
- pick rot bitand 0 > [ , ] [ drop ] if ;
+:: ?flag ( n mask symbol -- n )
+ n mask bitand 0 > [ symbol , ] when n ;
classes.struct unix.ffi ;
IN: io.directories.unix.linux
-M: unix find-next-file ( DIR* -- dirent )
+M: linux find-next-file ( DIR* -- dirent )
dirent <struct>
f <void*>
[ [ readdir64_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep
HOOK: file-system-info os ( path -- file-system-info )
{
- { [ os unix? ] [ "io.files.info" ] }
+ { [ os unix? ] [ "io.files.info.unix" ] }
{ [ os windows? ] [ "io.files.info.windows" ] }
} cond require
: write-object ( str obj -- ) presented associate format ;
: write-image ( image -- ) [ "" ] dip image associate format ;
-
-SYMBOL: stack-effect-style
-H{
- { foreground COLOR: FactorDarkGreen }
- { font-style plain }
-} stack-effect-style set-global
] if ;
: byte-array-bit-count ( byte-array -- n )
- 0 [ byte-bit-count + ] reduce ;
+ 0 [ byte-bit-count + ] reduce ; inline
PRIVATE>
+++ /dev/null
-USING: kernel arrays math.vectors sequences math ;
-
-IN: math.points
-
-<PRIVATE
-
-: X ( x -- point ) 0 0 3array ;
-: Y ( y -- point ) 0 swap 0 3array ;
-: Z ( z -- point ) 0 0 rot 3array ;
-
-PRIVATE>
-
-: v+x ( seq x -- seq ) X v+ ;
-: v-x ( seq x -- seq ) X v- ;
-
-: v+y ( seq y -- seq ) Y v+ ;
-: v-y ( seq y -- seq ) Y v- ;
-
-: v+z ( seq z -- seq ) Z v+ ;
-: v-z ( seq z -- seq ) Z v- ;
-
-: rise ( pt2 pt1 -- n ) [ second ] bi@ - ;
-: run ( pt2 pt1 -- n ) [ first ] bi@ - ;
-: slope ( pt pt -- slope ) [ rise ] [ run ] 2bi / ;
-: midpoint ( point point -- point ) v+ 2 v/n ;
-: linear-solution ( pt pt -- x ) [ drop first2 ] [ slope ] 2bi / - ;
\ No newline at end of file
: vocab-style ( vocab -- style )
dim-color colored-presentation-style ;
+SYMBOL: stack-effect-style
+
+H{
+ { foreground COLOR: FactorDarkGreen }
+ { font-style plain }
+} stack-effect-style set-global
+
: effect-style ( effect -- style )
presented associate stack-effect-style get assoc-union ;
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math sorting words parser io summary
quotations sequences prettyprint continuations effects
: word-timing. ( -- )
word-timing get
- >alist [ 1000000 /f ] assoc-map sort-values
+ >alist [ 1,000,000,000 /f ] assoc-map sort-values
simple-table. ;
[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test\r
\r
[ ] [ "tools.deploy.test.17" shake-and-bake run-temp-image ] unit-test\r
+\r
+[ t ] [\r
+ "tools.deploy.test.18" shake-and-bake\r
+ deploy-test-command ascii [ readln ] with-process-reader\r
+ "test.image" temp-file =\r
+] unit-test\r
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays accessors io.backend io.streams.c init fry
-namespaces math make assocs kernel parser parser.notes lexer
-strings.parser vocabs sequences sequences.deep sequences.private
-words memory kernel.private continuations io vocabs.loader
-system strings sets vectors quotations byte-arrays sorting
-compiler.units definitions generic generic.standard
+USING: arrays accessors io.backend io.pathnames io.streams.c
+init fry namespaces math make assocs kernel parser parser.notes
+lexer strings.parser vocabs sequences sequences.deep
+sequences.private words memory kernel.private continuations io
+vocabs.loader system strings sets vectors quotations byte-arrays
+sorting compiler.units definitions generic generic.standard
generic.single tools.deploy.config combinators classes
classes.builtin slots.private grouping command-line ;
QUALIFIED: bootstrap.stage2
"io.thread" startup-hooks get delete-at
] unless
strip-io? [
- "io.files" startup-hooks get delete-at
"io.backend" startup-hooks get delete-at
"io.thread" startup-hooks get delete-at
] when
strip-dictionary? [
{
- ! "compiler.units"
"vocabs"
"vocabs.cache"
"source-files.errors"
input-stream
output-stream
error-stream
+ vm
+ image
+ current-directory
} %
"io-thread" "io.thread" lookup ,
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io.streams.c math.parser system ;
+IN: tools.deploy.test.18
+
+: main ( -- ) image show ;
+
+MAIN: main
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-name "tools.deploy.test.18" }
+ { deploy-ui? f }
+ { deploy-c-types? f }
+ { deploy-unicode? f }
+ { "stop-after-last-window?" t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-word-props? f }
+ { deploy-math? f }
+ { deploy-threads? f }
+ { deploy-word-defs? f }
+}
! Copyright (C) 2007, 2009 Daniel Ehrenberg, Slava Pestov, and Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel sequences
-sequences.private namespaces math quotations assocs.private ;
+sequences.private namespaces math quotations assocs.private
+sets ;
IN: assocs
ARTICLE: "alists" "Association lists"
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
+$nl
+"Set-theoretic operations:"
{ $subsections
assoc-subset?
assoc-intersect
substitute
extract-keys
}
+"Adding elements to sets:"
+{ $subsections
+ conjoin
+ conjoin-at
+}
"Destructive operations:"
{ $subsections
assoc-union!
[ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test
[ f ] [ \ forgotten-predicate-test? predicate? ] unit-test
+
+GENERIC: generic-predicate? ( a -- b )
+
+[ ] [ "IN: classes.tests TUPLE: generic-predicate ;" eval( -- ) ] unit-test
+
+[ f ] [ \ generic-predicate? generic? ] unit-test
: classes ( -- seq ) implementors-map get keys ;
+PREDICATE: predicate < word "predicating" word-prop >boolean ;
+
: create-predicate-word ( word -- predicate )
- [ name>> "?" append ] [ vocabulary>> ] bi create ;
+ [ name>> "?" append ] [ vocabulary>> ] bi create
+ dup predicate? [ dup reset-generic ] unless ;
: predicate-word ( word -- predicate )
"predicate" word-prop first ;
-PREDICATE: predicate < word "predicating" word-prop >boolean ;
-
M: predicate flushable? drop t ;
M: predicate forget*
] unit-test
[ 31337 ] [ factor-crashes-anymore ] unit-test
+
+TUPLE: tuple-predicate-redefine-test ;
+
+[ ] [ "IN: classes.tuple.tests TUPLE: tuple-predicate-redefine-test ;" eval( -- ) ] unit-test
+
+[ t ] [ \ tuple-predicate-redefine-test? predicate? ] unit-test
"Adding elements to sets:"
{ $subsections
adjoin
- conjoin
- conjoin-at
}
{ $see-also member? member-eq? any? all? "assocs-sets" } ;
! Factor port of the raytracer benchmark from
-! http://www.ffconsultancy.com/free/ray_tracer/languages.html
+! http://www.ffconsultancy.com/languages/ray_tracer/index.html
USING: arrays accessors io io.files io.files.temp
io.encodings.binary kernel math math.constants math.functions
-math.vectors math.vectors.simd math.vectors.simd.cords math.parser
-make sequences sequences.private words hints classes.struct ;
-QUALIFIED-WITH: alien.c-types c
+math.vectors math.vectors.simd math.vectors.simd.cords
+math.parser make sequences words combinators ;
IN: benchmark.raytracer-simd
+<< SYNTAX: no-compile word t "no-compile" set-word-prop ; >>
+
! parameters
! Normalized { -1 -3 2 }.
CONSTANT: size 200
-: delta ( -- n ) epsilon sqrt ; inline
+: delta ( -- n ) epsilon sqrt ; inline no-compile
TUPLE: ray { orig double-4 read-only } { dir double-4 read-only } ;
C: <hit> hit
-GENERIC: intersect-scene ( hit ray scene -- hit )
-
TUPLE: sphere { center double-4 read-only } { radius float read-only } ;
C: <sphere> sphere
-: sphere-v ( sphere ray -- v )
- [ center>> ] [ orig>> ] bi* v- ; inline
+: sphere-v ( sphere ray -- v ) [ center>> ] [ orig>> ] bi* v- ; inline no-compile
-: sphere-b ( v ray -- b )
- dir>> v. ; inline
+: sphere-b ( v ray -- b ) dir>> v. ; inline no-compile
-: sphere-d ( sphere b v -- d )
- [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline
+: sphere-d ( sphere b v -- d ) [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline no-compile
-: -+ ( x y -- x-y x+y )
- [ - ] [ + ] 2bi ; inline
+: -+ ( x y -- x-y x+y ) [ - ] [ + ] 2bi ; inline no-compile
: sphere-t ( b d -- t )
-+ dup 0.0 <
- [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
+ [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline no-compile
: sphere-b&v ( sphere ray -- b v )
[ sphere-v ] [ nip ] 2bi
- [ sphere-b ] [ drop ] 2bi ; inline
+ [ sphere-b ] [ drop ] 2bi ; inline no-compile
: ray-sphere ( sphere ray -- t )
[ drop ] [ sphere-b&v ] 2bi
[ drop ] [ sphere-d ] 3bi
- dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline
+ dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline no-compile
-: if-ray-sphere ( hit ray sphere quot -- hit )
- #! quot: hit ray sphere l -- hit
+: if-ray-sphere ( hit ray sphere quot: ( hit ray sphere l -- hit ) -- hit )
[
[ ] [ swap ray-sphere nip ] [ 2drop lambda>> ] 3tri
[ drop ] [ < ] 2bi
- ] dip [ 3drop ] if ; inline
+ ] dip [ 3drop ] if ; inline no-compile
: sphere-n ( ray sphere l -- n )
[ [ orig>> ] [ dir>> ] bi ] [ center>> ] [ ] tri*
- swap [ v*n ] dip v- v+ ; inline
-
-M: sphere intersect-scene ( hit ray sphere -- hit )
- [ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
-
-HINTS: M\ sphere intersect-scene { hit ray sphere } ;
+ swap [ v*n ] dip v- v+ ; inline no-compile
TUPLE: group < sphere { objs array read-only } ;
: <group> ( objs bound -- group )
- [ center>> ] [ radius>> ] bi rot group boa ; inline
+ swap [ [ center>> ] [ radius>> ] bi ] dip group boa ; inline no-compile
: make-group ( bound quot -- )
- swap [ { } make ] dip <group> ; inline
+ swap [ { } make ] dip <group> ; inline no-compile
-M: group intersect-scene ( hit ray group -- hit )
- [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ;
-
-HINTS: M\ group intersect-scene { hit ray group } ;
+: intersect-scene ( hit ray scene -- hit )
+ {
+ { [ dup group? ] [ [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ] }
+ { [ dup sphere? ] [ [ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ] }
+ } cond ; inline recursive no-compile
CONSTANT: initial-hit T{ hit f double-4{ 0.0 0.0 0.0 0.0 } 1/0. }
: initial-intersect ( ray scene -- hit )
- [ initial-hit ] 2dip intersect-scene ; inline
+ [ initial-hit ] 2dip intersect-scene ; inline no-compile
: ray-o ( ray hit -- o )
[ [ orig>> ] [ normal>> delta v*n ] bi* ]
[ [ dir>> ] [ lambda>> ] bi* v*n ]
- 2bi v+ v+ ; inline
+ 2bi v+ v+ ; inline no-compile
: sray-intersect ( ray scene hit -- ray )
- swap [ ray-o light vneg <ray> ] dip initial-intersect ; inline
+ swap [ ray-o light vneg <ray> ] dip initial-intersect ; inline no-compile
-: ray-g ( hit -- g ) normal>> light v. ; inline
+: ray-g ( hit -- g ) normal>> light v. ; inline no-compile
: cast-ray ( ray scene -- g )
2dup initial-intersect dup lambda>> 1/0. = [
] [
[ sray-intersect lambda>> 1/0. = ] keep swap
[ ray-g neg ] [ drop 0.0 ] if
- ] if ; inline
+ ] if ; inline no-compile
: create-center ( c r d -- c2 )
- [ 3.0 12.0 sqrt / * ] dip n*v v+ ; inline
+ [ 3.0 12.0 sqrt / * ] dip n*v v+ ; inline no-compile
DEFER: create ( level c r -- scene )
: create-step ( level c r d -- scene )
over [ create-center ] dip 2.0 / [ 1 - ] 2dip create ;
-: create-offsets ( quot -- )
+CONSTANT: create-offsets
{
double-4{ -1.0 1.0 -1.0 0.0 }
double-4{ 1.0 1.0 -1.0 0.0 }
double-4{ -1.0 1.0 1.0 0.0 }
double-4{ 1.0 1.0 1.0 0.0 }
- } swap each ; inline
+ }
: create-bound ( c r -- sphere ) 3.0 * <sphere> ;
: create-group ( level c r -- scene )
2dup create-bound [
2dup <sphere> ,
- [ [ 3dup ] dip create-step , ] create-offsets 3drop
+ create-offsets [ create-step , ] with with with each
] make-group ;
: create ( level c r -- scene )
pick 1 = [ <sphere> nip ] [ create-group ] if ;
: ss-point ( dx dy -- point )
- [ oversampling /f ] bi@ 0.0 0.0 double-4-boa ;
-
-: ss-grid ( -- ss-grid )
- oversampling iota [ oversampling iota [ ss-point ] with map ] map ;
-
-: ray-grid ( point ss-grid -- ray-grid )
- [
- [ v+ normalize double-4{ 0.0 0.0 -4.0 0.0 } swap <ray> ] with map
- ] with map ;
-
-: ray-pixel ( scene point -- n )
- ss-grid ray-grid [ 0.0 ] 2dip
- [ [ swap cast-ray + ] with each ] with each ;
-
-: pixel-grid ( -- grid )
- size iota reverse [
+ [ oversampling /f ] bi@ 0.0 0.0 double-4-boa ; inline no-compile
+
+: ray-pixel ( scene point -- ray-grid )
+ [ 0.0 ] 2dip
+ oversampling iota [
+ oversampling iota [
+ ss-point v+ normalize
+ double-4{ 0.0 0.0 -4.0 0.0 } swap <ray>
+ swap cast-ray +
+ ] with with with each
+ ] with with each ; inline no-compile
+
+: ray-trace ( scene -- grid )
+ size iota <reversed> [
size iota [
[ size 0.5 * - ] bi@ swap size
- 0.0 double-4-boa
- ] with map
- ] map ;
+ 0.0 double-4-boa ray-pixel
+ ] with with map
+ ] with map ;
: pgm-header ( w h -- )
"P5\n" % swap # " " % # "\n255\n" % ;
: pgm-pixel ( n -- ) 255 * 0.5 + >fixnum , ;
-: ray-trace ( scene -- pixels )
- pixel-grid [ [ ray-pixel ] with map ] with map ;
-
: run ( -- string )
levels double-4{ 0.0 -1.0 0.0 0.0 } 1.0 create ray-trace [
size size pgm-header
: clone-factor ( -- )
{ "git" "clone" } home "factor" append-path suffix try-process ;
+: save-git-id ( -- )
+ git-id "git-id" to-file ;
+
+: delete-git-tree ( -- )
+ ".git" delete-tree ;
+
+: download-images ( -- )
+ images [ download-image ] each ;
+
: prepare-source ( -- )
- "factor" [
- ".git" delete-tree
- images [ download-image ] each
- ] with-directory ;
+ "factor" [ save-git-id delete-git-tree download-images ] with-directory ;
: package-name ( version -- string )
"factor-src-" ".zip" surround ;
--- /dev/null
+USING: kernel arrays math.vectors sequences math ;
+
+IN: math.points
+
+<PRIVATE
+
+: X ( x -- point ) 0 0 3array ;
+: Y ( y -- point ) 0 swap 0 3array ;
+: Z ( z -- point ) 0 0 rot 3array ;
+
+PRIVATE>
+
+: v+x ( seq x -- seq ) X v+ ;
+: v-x ( seq x -- seq ) X v- ;
+
+: v+y ( seq y -- seq ) Y v+ ;
+: v-y ( seq y -- seq ) Y v- ;
+
+: v+z ( seq z -- seq ) Z v+ ;
+: v-z ( seq z -- seq ) Z v- ;
+
+: rise ( pt2 pt1 -- n ) [ second ] bi@ - ;
+: run ( pt2 pt1 -- n ) [ first ] bi@ - ;
+: slope ( pt pt -- slope ) [ rise ] [ run ] 2bi / ;
+: midpoint ( point point -- point ) v+ 2 v/n ;
+: linear-solution ( pt pt -- x ) [ drop first2 ] [ slope ] 2bi / - ;
\ No newline at end of file
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.smart formatting fry io kernel macros math
-math.functions math.statistics memory sequences tools.time ;
+USING: combinators.smart formatting fry io kernel macros math math.functions
+math.statistics memory sequences tools.time ;
IN: project-euler.ave-time
MACRO: collect-benchmarks ( quot n -- seq )
- swap '[ _ [ [ [ _ nullary ] preserving ] gc benchmark 1000 / ] replicate ] ;
+ swap '[ _ [ [ [ _ nullary ] preserving ] gc benchmark 6 10^ / ] replicate ] ;
: ave-time ( quot n -- )
[
projects / factor.git / commitdiff