diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index aa46271fed..c4a7aa8dc3 100644 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -27,11 +27,11 @@ GENERIC: alien-node-abi ( node -- str ) : alien-node-return* ( node -- ctype ) alien-node-return dup large-struct? [ drop "void" ] when ; +: c-type-stack-align ( type -- align ) + dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ; + : parameter-align ( n type -- n delta ) - over >r - dup c-type-stack-align? [ c-type-align ] [ drop cell ] if - align - dup r> - ; + over >r c-type-stack-align align dup r> - ; : parameter-sizes ( types -- total offsets ) #! Compute stack frame locations. @@ -91,24 +91,33 @@ M: float-regs inc-reg-class [ dup class get swap inc-reg-class ] keep ; : alloc-parameter ( parameter -- reg reg-class ) - c-type c-type-reg-class dup reg-class-full? + c-type-reg-class dup reg-class-full? [ spill-param ] [ fastcall-param ] if [ param-reg ] keep ; : (flatten-int-type) ( size -- ) - cell /i "void*" % ; + cell /i "void*" c-type % ; -: flatten-int-type ( n type -- n ) - [ parameter-align (flatten-int-type) ] keep - stack-size cell align dup (flatten-int-type) + ; +GENERIC: flatten-value-type ( type -- ) -: flatten-value-type ( n type -- n ) - dup c-type c-type-reg-class T{ int-regs } = - [ flatten-int-type ] [ , ] if ; +M: object flatten-value-type , ; + +M: struct-type flatten-value-type ( type -- ) + stack-size cell align (flatten-int-type) ; + +M: long-long-type flatten-value-type ( type -- ) + stack-size cell align (flatten-int-type) ; : flatten-value-types ( params -- params ) #! Convert value type structs to consecutive void*s. - [ 0 [ flatten-value-type ] reduce drop ] { } make ; + [ + 0 [ + c-type + [ parameter-align (flatten-int-type) ] keep + [ stack-size cell align + ] keep + flatten-value-type + ] reduce drop + ] { } make ; : each-parameter ( parameters quot -- ) >r [ parameter-sizes nip ] keep r> 2each ; inline @@ -127,11 +136,11 @@ M: float-regs inc-reg-class #! Moves values from C stack to registers (if word is #! %load-param-reg) and registers to C stack (if word is #! %save-param-reg). - swap + >r alien-node-parameters* flatten-value-types - [ pick >r alloc-parameter r> execute ] each-parameter - drop ; inline + r> [ >r alloc-parameter r> execute ] curry each-parameter ; + inline : if-void ( type true false -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 838fe3251c..3f8b1da052 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -260,7 +260,7 @@ H{ } clone update-map set { "" "tuples.private" } { "tuple>array" "tuples" } { "profiling" "tools.profiler.private" } - { "become" "tuples.private" } + { "become" "kernel.private" } { "(sleep)" "threads.private" } { "" "float-arrays" } { "curry" "kernel" } @@ -271,6 +271,7 @@ H{ } clone update-map set { "innermost-frame-scan" "kernel.private" } { "set-innermost-frame-quot" "kernel.private" } { "call-clear" "kernel" } + { "strip-compiled-quotations" "quotations" } } dup length [ >r first2 r> make-primitive ] 2each diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor index 518a8cd119..aa6b7aea7c 100644 --- a/core/compiler/test/alien.factor +++ b/core/compiler/test/alien.factor @@ -234,6 +234,50 @@ FUNCTION: test-struct-7 ffi_test_30 ; [ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test +C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ; + +FUNCTION: double ffi_test_32 test-struct-8 x int y ; + +[ 9.0 ] [ + "test-struct-8" + 1.0 over set-test-struct-8-x + 2.0 over set-test-struct-8-y + 3 ffi_test_32 +] unit-test + +C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ; + +FUNCTION: double ffi_test_33 test-struct-9 x int y ; + +[ 9.0 ] [ + "test-struct-9" + 1.0 over set-test-struct-9-x + 2.0 over set-test-struct-9-y + 3 ffi_test_33 +] unit-test + +C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ; + +FUNCTION: double ffi_test_34 test-struct-10 x int y ; + +[ 9.0 ] [ + "test-struct-10" + 1.0 over set-test-struct-10-x + 2 over set-test-struct-10-y + 3 ffi_test_34 +] unit-test + +C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ; + +FUNCTION: double ffi_test_35 test-struct-11 x int y ; + +[ 9.0 ] [ + "test-struct-11" + 1 over set-test-struct-11-x + 2 over set-test-struct-11-y + 3 ffi_test_35 +] unit-test + ! Test callbacks : callback-1 "void" { } "cdecl" [ ] alien-callback ; diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early.factor index ae7cf12502..8482f4767f 100644 --- a/core/compiler/test/templates-early.factor +++ b/core/compiler/test/templates-early.factor @@ -187,3 +187,30 @@ SYMBOL: template-chosen ! This should not fail [ ] [ [ end-basic-block ] { } make drop ] unit-test ] with-scope + +! Regression +SYMBOL: templates-chosen + +V{ } clone templates-chosen set + +: template-choice-1 ; + +\ template-choice-1 +[ "template-choice-1" templates-chosen get push ] +H{ + { +input+ { { f "obj" } { [ ] "n" } } } + { +output+ { "obj" } } +} define-intrinsic + +: template-choice-2 ; + +\ template-choice-2 +[ "template-choice-2" templates-chosen get push drop ] +{ { f "x" } { f "y" } } define-if-intrinsic + +[ ] [ + [ 2 template-choice-1 template-choice-2 ] compile-quot drop +] unit-test + +[ V{ "template-choice-1" "template-choice-2" } ] +[ templates-chosen get ] unit-test diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index f7349855dd..dc8f337f33 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -89,7 +89,7 @@ C: continuation set-catchstack set-namestack set-retainstack - >r set-datastack drop 4 getenv f r> + >r set-datastack drop 4 getenv f 4 setenv f r> set-callstack ; PRIVATE> diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 708c75e0bd..55513b0930 100644 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2 cpu.x86.allot cpu.architecture kernel kernel.private math namespaces sequences generator.registers generator.fixup system -alien ; +alien alien.compiler alien.structs slots splitting math.functions ; IN: cpu.x86.64 PREDICATE: x86-backend amd64-backend @@ -175,3 +175,32 @@ USE: cpu.x86.intrinsics \ set-alien-signed-4 small-reg-32 define-setter T{ x86-backend f 8 } compiler-backend set-global + +! The ABI for passing structs by value is pretty messed up +"void*" c-type clone "__stack_value" define-primitive-type +T{ stack-params } "__stack_value" c-type set-c-type-reg-class + +: struct-types&offset ( struct-type -- pairs ) + struct-type-fields [ + dup slot-spec-type swap slot-spec-offset 2array + ] map ; + +: split-struct ( pairs -- seq ) + [ + [ first2 8 mod zero? [ t , ] when , ] each + ] { } make { t } split [ empty? not ] subset ; + +: flatten-large-struct ( type -- ) + heap-size cell align + cell /i "__stack_value" c-type % ; + +M: struct-type flatten-value-type ( type -- seq ) + dup heap-size 16 > [ + flatten-large-struct + ] [ + struct-types&offset split-struct [ + [ c-type c-type-reg-class ] map + T{ int-regs } swap member? + "void*" "double" ? c-type , + ] each + ] if ; diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index c828474742..3b39afaa24 100644 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -586,7 +586,7 @@ IN: cpu.x86.intrinsics "value" operand [ swap MOV ] %alien-accessor ] H{ { +input+ { - { unboxed-c-ptr "value" c-ptr } + { unboxed-c-ptr "value" pinned-c-ptr } { unboxed-c-ptr "alien" c-ptr } { f "offset" fixnum } } } diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor new file mode 100644 index 0000000000..14d1c03be3 --- /dev/null +++ b/core/definitions/definitions-tests.factor @@ -0,0 +1,39 @@ +IN: temporary +USING: tools.test generic kernel definitions sequences ; + +TUPLE: combination-1 ; + +M: combination-1 perform-combination 2drop { } [ ] each [ ] ; + +SYMBOL: generic-1 + +generic-1 T{ combination-1 } define-generic + +[ ] object \ generic-1 define-method + +[ ] [ { combination-1 { object generic-1 } } forget-all ] unit-test + +GENERIC: some-generic + +USE: arrays + +M: array some-generic ; + +USE: bit-arrays + +M: bit-array some-generic ; + +USE: byte-arrays + +M: byte-array some-generic ; + +TUPLE: some-class ; + +M: some-class some-generic ; + +TUPLE: another-class some-generic ; + +[ ] [ + { some-generic some-class { another-class some-generic } } + forget-all +] unit-test diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 9d31c8d87d..c9213c137b 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -13,6 +13,8 @@ GENERIC: forget ( defspec -- ) M: object forget drop ; +: forget-all ( definitions -- ) [ forget ] each ; + GENERIC: synopsis* ( defspec -- ) GENERIC: definer ( defspec -- start end ) diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 214aafd75c..68e63ac605 100644 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -458,8 +458,23 @@ M: loc lazy-store dup loc? over cached? or [ 2drop ] [ %move ] if ] each-loc ; +: reset-phantom ( phantom -- ) + #! Kill register assignments but preserve constants and + #! class information. + dup phantom-locs* + over [ + dup constant? [ nip ] [ + operand-class over set-operand-class + ] if + ] 2map + over delete-all + swap push-all ; + +: reset-phantoms ( -- ) + [ reset-phantom ] each-phantom ; + : finalize-contents ( -- ) - finalize-locs finalize-vregs [ delete-all ] each-phantom ; + finalize-locs finalize-vregs reset-phantoms ; : %gc ( -- ) 0 frame-required @@ -468,8 +483,8 @@ M: loc lazy-store ! Loading stacks to vregs : free-vregs? ( int# float# -- ? ) - T{ float-regs f 8 } free-vregs length < - >r T{ int-regs } free-vregs length < r> and ; + T{ float-regs f 8 } free-vregs length <= + >r T{ int-regs } free-vregs length <= r> and ; : phantom&spec ( phantom spec -- phantom' spec' ) [ length f pad-left ] keep @@ -585,24 +600,18 @@ M: loc lazy-store 2dup first value-matches? >r >r operand-class 2 r> ?nth class-matches? r> and ; -: template-specs-match? ( -- ? ) - phantom-d get +input+ get - [ spec-matches? ] phantom&spec-agree? ; - : template-matches? ( spec -- ? ) - clone [ - template-specs-match? - [ guess-template-vregs free-vregs? ] [ f ] if - ] bind ; - -: (find-template) ( templates -- pair/f ) - [ second template-matches? ] find nip ; + phantom-d get +input+ rot at + [ spec-matches? ] phantom&spec-agree? ; : ensure-template-vregs ( -- ) guess-template-vregs free-vregs? [ finalize-contents compute-free-vregs ] unless ; +: clear-phantoms ( -- ) + [ delete-all ] each-phantom ; + PRIVATE> : set-operand-classes ( classes -- ) @@ -614,15 +623,11 @@ PRIVATE> #! Commit all deferred stacking shuffling, and ensure the #! in-memory data and retain stacks are up to date with #! respect to the compiler's current picture. - finalize-contents finalize-heights + finalize-contents + clear-phantoms + finalize-heights fresh-objects get dup empty? swap delete-all [ %gc ] unless ; -: do-template ( pair -- ) - #! Use with return value from find-template - first2 - clone [ template-inputs call template-outputs ] bind - compute-free-vregs ; inline - : with-template ( quot hash -- ) clone [ ensure-template-vregs @@ -630,6 +635,10 @@ PRIVATE> ] bind compute-free-vregs ; inline +: do-template ( pair -- ) + #! Use with return value from find-template + first2 with-template ; + : fresh-object ( obj -- ) fresh-objects get push ; : fresh-object? ( obj -- ? ) fresh-objects get memq? ; @@ -651,10 +660,7 @@ PRIVATE> : find-template ( templates -- pair/f ) #! Pair has shape { quot hash } - compute-free-vregs - dup (find-template) [ ] [ - finalize-contents (find-template) - ] ?if ; + [ second template-matches? ] find nip ; : operand-tag ( operand -- tag/f ) operand-class class-tag ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 0de8bd42d2..a9216a2fd3 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -14,6 +14,15 @@ M: generic definition drop f ; GENERIC: perform-combination ( word combination -- quot ) +M: object perform-combination + #! We delay the invalid method combination error for a + #! reason. If we call forget-vocab on a vocabulary which + #! defines a method combination, a generic using this + #! method combination, and a method on the generic, and the + #! method combination is forgotten first, then forgetting + #! the method will throw an error. We don't want that. + nip [ "Invalid method combination" throw ] curry ; + : make-generic ( word -- ) dup dup "combination" word-prop perform-combination @@ -94,7 +103,7 @@ M: method-spec forget first2 [ delete-at ] with-methods ; dup associate implementors* ; : forget-methods ( class -- ) - [ implementors ] keep [ swap 2array forget ] curry each ; + [ implementors ] keep [ swap 2array ] curry map forget-all ; M: class forget ( class -- ) dup forget-methods diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 62be94d709..871838c3f3 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -1,7 +1,9 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: memory -USING: arrays kernel sequences vectors system ; +USING: arrays kernel sequences vectors system hashtables +kernel.private sbufs growable assocs namespaces quotations +math strings combinators ; : (each-object) ( quot -- ) next-object dup @@ -14,3 +16,29 @@ USING: arrays kernel sequences vectors system ; pusher >r each-object r> >array ; inline : save ( -- ) image save-image ; + + + +: compress-image ( -- ) + prepare-compress-image "bad-strings" [ + [ + { + { [ dup quotation? ] [ t ] } + { [ dup wrapper? ] [ t ] } + { [ dup fixnum? ] [ f ] } + { [ dup number? ] [ t ] } + { [ dup string? ] [ dup "bad-strings" get memq? not ] } + { [ t ] [ f ] } + } cond nip + ] intern-objects + ] with-variable ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 0eb4d3162c..235d0e935a 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -416,7 +416,7 @@ SYMBOL: parse-hook ] keep ; : forget-smudged ( -- ) - smudged-usage [ forget ] each + smudged-usage forget-all over empty? [ 2dup smudged-usage-warning ] unless 2drop ; : record-definitions ( file -- ) diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index e9fc483c38..ef21e9cf89 100644 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -299,3 +299,7 @@ unit-test [ 2 break 2 \ + (step-into) . ] (remove-breakpoints) ] unit-test +[ [ 2 . ] ] [ + [ 2 \ break (step-into) . ] (remove-breakpoints) +] unit-test + diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 4a728b81de..01cff3b7b3 100644 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -99,7 +99,12 @@ SYMBOL: -> building get dup empty? [ drop \ (step-into) , ] [ - pop dup wrapper? [ wrapped ] when , + pop dup wrapper? [ + wrapped dup \ break eq? + [ drop ] [ , ] if + ] [ + , + ] if ] if ; : (remove-breakpoints) ( quot -- newquot ) diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index f544a41dcf..57ae7d7a53 100644 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -71,7 +71,7 @@ M: pathname where pathname-string 1 2array ; : forget-source ( path -- ) dup source-file dup unxref-source - source-file-definitions [ drop forget ] assoc-each + source-file-definitions keys forget-all source-files get delete-at ; M: pathname forget pathname-string forget-source ; diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index cb5e700c40..0d3475c951 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -76,7 +76,7 @@ SYMBOL: load-vocab-hook [ ] subset ; : forget-vocab ( vocab -- ) - dup vocab-words [ nip forget ] assoc-each + dup vocab-words values forget-all vocab-name dictionary get delete-at ; : child-vocab? ( prefix name -- ? ) diff --git a/core/words/words.factor b/core/words/words.factor index 342b20508c..93c08ff435 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -6,14 +6,14 @@ slots.private math namespaces sequences strings vectors sbufs quotations assocs hashtables sorting math.parser words.private vocabs ; -GENERIC: execute ( word -- ) - -M: word execute (execute) ; - : word ( -- word ) \ word get-global ; : set-word ( word -- ) \ word set-global ; +GENERIC: execute ( word -- ) + +M: word execute (execute) ; + ! Used by the compiler SYMBOL: changed-words @@ -201,7 +201,6 @@ M: word (forget-word) reveal ; : forget-word ( word -- ) - dup f "methods" set-word-prop dup delete-xref dup unchanged-word (forget-word) ; diff --git a/extra/automata/ui/deploy.factor b/extra/automata/ui/deploy.factor new file mode 100644 index 0000000000..eb261ed93f --- /dev/null +++ b/extra/automata/ui/deploy.factor @@ -0,0 +1,16 @@ +USING: tools.deploy.config ; +V{ + { strip-prettyprint? t } + { strip-globals? t } + { strip-word-props? t } + { strip-word-names? t } + { strip-dictionary? t } + { strip-debugger? t } + { strip-c-types? t } + { deploy-math? t } + { deploy-compiled? t } + { deploy-io? f } + { deploy-ui? t } + { "stop-after-last-window?" t } + { "bundle-name" "Cellular Automata.app" } +} diff --git a/extra/boids/ui/deploy.factor b/extra/boids/ui/deploy.factor new file mode 100644 index 0000000000..0b22fa5200 --- /dev/null +++ b/extra/boids/ui/deploy.factor @@ -0,0 +1,13 @@ +USING: tools.deploy.config ; +V{ + { strip-word-props? t } + { strip-word-names? t } + { strip-dictionary? t } + { strip-debugger? t } + { strip-c-types? t } + { deploy-math? t } + { deploy-compiled? t } + { deploy-io? f } + { deploy-ui? t } + { "bundle-name" "Boids.app" } +} diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index c33acb0f3a..3042b87ad6 100644 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -57,10 +57,7 @@ IN: bunny ] unless ; : draw-triangle ( ns vs triple -- ) - [ - dup roll nth first3 glNormal3d - swap nth first3 glVertex3d - ] each-with2 ; + [ dup roll nth gl-normal swap nth gl-vertex ] each-with2 ; : draw-bunny ( ns vs is -- ) GL_TRIANGLES [ [ draw-triangle ] each-with2 ] do-state ; diff --git a/extra/cabal/cabal.factor b/extra/cabal/cabal.factor index 278729fb8a..cc51bcf308 100644 --- a/extra/cabal/cabal.factor +++ b/extra/cabal/cabal.factor @@ -69,13 +69,15 @@ cond ; ! : handle-client ( client -- ) dup users> push ! dup [ >user [ handle-user-loop ] with-stream* ] with-scope ; -: handle-client ( client -- ) dup users> push +: handle-client ( client -- ) + dup users> push dup [ >user [ handle-user-loop ] with-stream ] with-scope ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : accept-client-loop ( server -- ) -dup >r accept [ handle-client ] in-thread r> accept-client-loop ; +[ accept [ handle-client ] curry in-thread ] keep +accept-client-loop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor index 7db2965a54..aaff1d2038 100644 --- a/extra/contributors/contributors.factor +++ b/extra/contributors/contributors.factor @@ -1,29 +1,24 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: memory io io.files io.styles io.launcher -sequences prettyprint kernel arrays xml xml.utilities system -hashtables sorting math.parser assocs ; +USING: io.files io.launcher io.styles io hashtables kernel +sequences combinators.lib assocs system sorting math.parser ; IN: contributors -: changelog ( -- xml ) +: changelog ( -- authors ) image parent-dir cd - "darcs changes --xml-output" read-xml ; - -: authors ( xml -- seq ) - children-tags [ "author" swap at ] map ; - -: patch-count ( authors author -- n ) - [ = ] curry subset length ; + "git-log --pretty=format:%an" lines ; : patch-counts ( authors -- assoc ) - dup prune [ [ patch-count ] keep 2array ] curry* map ; + dup prune + [ dup rot [ = ] curry* count ] curry* + { } map>assoc ; : contributors ( -- ) - changelog authors patch-counts sort-keys + changelog patch-counts sort-values standard-table-style [ [ [ - first2 + first2 swap [ write ] with-cell [ number>string write ] with-cell ] with-row diff --git a/extra/golden-section/deploy.factor b/extra/golden-section/deploy.factor index 318d03ee4c..3923d258f0 100644 --- a/extra/golden-section/deploy.factor +++ b/extra/golden-section/deploy.factor @@ -1,12 +1,17 @@ USING: tools.deploy.config ; V{ + { strip-io? t } + { strip-prettyprint? t } + { strip-globals? t } { strip-word-props? t } { strip-word-names? t } { strip-dictionary? t } { strip-debugger? t } + { strip-c-types? t } { deploy-math? t } { deploy-compiled? t } { deploy-io? f } { deploy-ui? t } + { "stop-after-last-window?" t } { "bundle-name" "Golden Section.app" } } diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor index db728d1eda..2f346e94c6 100644 --- a/extra/hello-ui/deploy.factor +++ b/extra/hello-ui/deploy.factor @@ -1,12 +1,16 @@ USING: tools.deploy.config ; V{ + { strip-prettyprint? t } + { strip-globals? t } { strip-word-props? t } - { strip-word-names? t } + { strip-word-names? f } { strip-dictionary? t } { strip-debugger? t } + { strip-c-types? t } { deploy-math? t } { deploy-compiled? t } { deploy-io? f } { deploy-ui? t } + { "stop-after-last-window?" t } { "bundle-name" "Hello World.app" } } diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 1fa0e20503..145f7ecea7 100644 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,11 +1,15 @@ USING: tools.deploy.config ; V{ + { strip-prettyprint? t } + { strip-globals? t } { strip-word-props? t } { strip-word-names? t } { strip-dictionary? t } { strip-debugger? t } + { strip-c-types? t } { deploy-math? f } { deploy-compiled? f } { deploy-io? f } { deploy-ui? f } + { "stop-after-last-window?" t } } diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index f20d8d2bd8..da38e43392 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -14,7 +14,7 @@ IN: jamshred.gl : draw-segment-vertex ( segment theta -- ) over segment-color gl-color segment-vertex-and-normal - first3 glNormal3d first3 glVertex3d ; + gl-normal gl-vertex ; : draw-vertex-pair ( theta next-segment segment -- ) rot tuck draw-segment-vertex draw-segment-vertex ; diff --git a/extra/lsys/tortoise/graphics/graphics.factor b/extra/lsys/tortoise/graphics/graphics.factor index 23bf66c2f8..c212ab435d 100644 --- a/extra/lsys/tortoise/graphics/graphics.factor +++ b/extra/lsys/tortoise/graphics/graphics.factor @@ -1,6 +1,7 @@ -USING: kernel math vectors sequences opengl.gl math.vectors math.matrices - vars opengl.lib self pos ori turtle lsys.tortoise lsys.strings ; +USING: kernel math vectors sequences opengl.gl math.vectors +math.matrices vars opengl self pos ori turtle lsys.tortoise +lsys.strings ; IN: lsys.tortoise.graphics @@ -12,7 +13,7 @@ IN: lsys.tortoise.graphics : (polygon) ( vertices -- ) GL_POLYGON glBegin -dup polygon-normal gl-normal-3f [ gl-vertex-3f ] each +dup polygon-normal gl-normal [ gl-vertex ] each glEnd ; : polygon ( vertices -- ) dup length 3 >= [ (polygon) ] [ drop ] if ; @@ -31,7 +32,7 @@ VAR: vertices ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: record-vertex ( -- ) pos> gl-vertex-3f ; +: record-vertex ( -- ) pos> gl-vertex ; : draw-forward ( length -- ) GL_LINES glBegin record-vertex step-turtle record-vertex glEnd ; @@ -78,10 +79,10 @@ VAR: color-table ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : material-color ( color -- ) -GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material-fv ; +GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ; : set-color ( i -- ) -dup >color color-table> nth dup gl-color-4f material-color ; +dup >color color-table> nth dup gl-color material-color ; : inc-color ( -- ) color> 1+ set-color ; diff --git a/extra/lsys/ui/deploy.factor b/extra/lsys/ui/deploy.factor new file mode 100644 index 0000000000..22b6d0e4a3 --- /dev/null +++ b/extra/lsys/ui/deploy.factor @@ -0,0 +1,13 @@ +USING: tools.deploy ; +V{ + { strip-word-props? t } + { strip-word-names? t } + { strip-dictionary? t } + { strip-debugger? t } + { strip-c-types? t } + { deploy-math? t } + { deploy-compiled? t } + { deploy-io? f } + { deploy-ui? t } + { "bundle-name" "Lindenmayer Systems.app" } +} diff --git a/extra/lsys/ui/ui.factor b/extra/lsys/ui/ui.factor index efdaa9caba..2602adfcee 100644 --- a/extra/lsys/ui/ui.factor +++ b/extra/lsys/ui/ui.factor @@ -1,5 +1,6 @@ USING: kernel namespaces threads math math.vectors quotations sequences + opengl opengl.gl colors ui @@ -11,7 +12,7 @@ USING: kernel namespaces threads math math.vectors quotations sequences ui.gadgets.lib ui.gadgets.slate ui.gadgets.theme - vars rewrite-closures opengl.lib + vars rewrite-closures self pos ori turtle opengl.camera lsys.tortoise lsys.tortoise.graphics lsys.strings ; @@ -34,7 +35,7 @@ VAR: model : display ( -- ) -black gl-clear-color +black gl-clear GL_FLAT glShadeModel @@ -48,13 +49,11 @@ glLoadIdentity camera> do-look-at -GL_COLOR_BUFFER_BIT glClear - GL_FRONT_AND_BACK GL_LINE glPolygonMode -white gl-color-4f +white gl-color -GL_LINES glBegin { 0 0 0 } gl-vertex-3f { 0 0 1 } gl-vertex-3f glEnd +GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd color> set-color diff --git a/extra/opengl/authors.txt b/extra/opengl/authors.txt index 1901f27a24..e1907c6d91 100644 --- a/extra/opengl/authors.txt +++ b/extra/opengl/authors.txt @@ -1 +1,2 @@ Slava Pestov +Eduardo Cavazos diff --git a/extra/opengl/camera/camera.factor b/extra/opengl/camera/camera.factor index 030a5d0989..c324e53edc 100644 --- a/extra/opengl/camera/camera.factor +++ b/extra/opengl/camera/camera.factor @@ -1,5 +1,5 @@ -USING: kernel namespaces math.vectors opengl.lib pos ori turtle self ; +USING: kernel namespaces math.vectors opengl pos ori turtle self ; IN: opengl.camera @@ -13,4 +13,4 @@ IN: opengl.camera [ 90 pitch-up pos> 1 step-turtle pos> swap v- ] save-self ; : do-look-at ( camera -- ) -[ >self camera-eye camera-focus camera-up glu-look-at ] with-scope ; +[ >self camera-eye camera-focus camera-up gl-look-at ] with-scope ; diff --git a/extra/opengl/lib/lib.factor b/extra/opengl/lib/lib.factor deleted file mode 100644 index 4e52710b85..0000000000 --- a/extra/opengl/lib/lib.factor +++ /dev/null @@ -1,19 +0,0 @@ -USING: kernel alien.c-types sequences opengl.gl opengl.glu ; - -IN: opengl.lib - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: gl-color-4f ( 4seq -- ) first4 glColor4f ; - -: gl-clear-color ( 4seq -- ) first4 glClearColor ; - -: gl-vertex-3f ( array -- ) first3 glVertex3f ; - -: gl-normal-3f ( array -- ) first3 glNormal3f ; - -: gl-material-fv ( face pname params -- ) >c-float-array glMaterialfv ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: glu-look-at ( eye focus up -- ) >r >r first3 r> first3 r> first3 gluLookAt ; \ No newline at end of file diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 0cb16cccbd..13ce47ba52 100644 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2005, 2006 Slava Pestov. +! Copyright (C) 2005, 2007 Slava Pestov. +! Portions copyright (C) 2007 Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types io kernel math namespaces -sequences math.vectors opengl.gl opengl.glu ; +sequences math.vectors opengl.gl opengl.glu combinators ; IN: opengl : coordinates [ first2 ] 2apply ; @@ -10,8 +11,11 @@ IN: opengl : gl-color ( color -- ) first4 glColor4d ; inline +: gl-clear-color ( color -- ) + first4 glClearColor ; + : gl-clear ( color -- ) - first4 glClearColor GL_COLOR_BUFFER_BIT glClear ; + gl-clear-color GL_COLOR_BUFFER_BIT glClear ; : gl-error ( -- ) glGetError dup zero? [ @@ -28,7 +32,17 @@ IN: opengl swap [ glMatrixMode glPushMatrix call ] keep glMatrixMode glPopMatrix ; inline -: gl-vertex ( point -- ) first2 glVertex2d ; inline +: gl-vertex ( point -- ) + dup length { + { 2 [ first2 glVertex2d ] } + { 3 [ first3 glVertex3d ] } + { 4 [ first4 glVertex4d ] } + } case ; + +: gl-normal ( normal -- ) first3 glNormal3d ; + +: gl-material ( face pname params -- ) + >c-float-array glMaterialfv ; : gl-line ( a b -- ) GL_LINES [ gl-vertex gl-vertex ] do-state ; @@ -67,6 +81,9 @@ IN: opengl : do-attribs ( bits quot -- ) swap glPushAttrib call glPopAttrib ; inline +: gl-look-at ( eye focus up -- ) + >r >r first3 r> first3 r> first3 gluLookAt ; + TUPLE: sprite loc dim dim2 dlist texture ; : ( loc dim dim2 -- sprite ) diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index 832f9f4a1a..2b7353ad03 100644 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -4,6 +4,7 @@ USING: vocabs.loader io.files io kernel sequences assocs splitting parser prettyprint ; IN: tools.deploy.config +SYMBOL: strip-io? SYMBOL: strip-globals? SYMBOL: strip-word-props? SYMBOL: strip-word-names? @@ -22,6 +23,7 @@ SYMBOL: deploy-image : default-config ( -- assoc ) V{ + { strip-io? f } { strip-prettyprint? t } { strip-globals? t } { strip-word-props? t } diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index 9a7f99a99d..5701d0fa1b 100644 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -57,4 +57,5 @@ PRIVATE> deploy-command-line stage2 ; : deploy ( vocab -- ) + "" resource-path cd vm over ".image" append rot dup deploy-config deploy* ; diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 9eabf1a67e..d19c8f4a2b 100644 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -15,19 +15,20 @@ IN: tools.deploy.shaker : strip-init-hooks ( -- ) "Stripping startup hooks" show - "command-line" init-hooks get delete-at ; + "command-line" init-hooks get delete-at + strip-io? get [ "io.backend" init-hooks get delete-at ] when ; : strip-debugger ( -- ) strip-debugger? get [ "Stripping debugger" show - "resource:extra/tools/deploy/strip-debugger.factor" + "resource:extra/tools/deploy/shaker/strip-debugger.factor" run-file ] when ; : strip-cocoa ( -- ) "cocoa" vocab [ "Stripping unused Cocoa methods" show - "resource:extra/tools/deploy/strip-cocoa.factor" + "resource:extra/tools/deploy/shaker/strip-cocoa.factor" run-file ] when ; @@ -90,6 +91,8 @@ USING: bit-arrays byte-arrays io.streams.nested ; { } set-retainstack V{ } set-namestack V{ } set-catchstack + "Stripping compiled quotations" show + strip-compiled-quotations "Saving final image" show [ save-image-and-exit ] call-clear ; @@ -100,14 +103,14 @@ SYMBOL: deploy-vocab \ boot , init-hooks get values concat % , - "io.backend" init-hooks get at [ \ flush , ] when + strip-io? get [ \ flush , ] unless ] [ ] make "Boot quotation: " write dup . flush set-boot-quot ; : retained-globals ( -- seq ) [ builtins , - io-backend , + strip-io? get [ io-backend , ] unless strip-dictionary? get [ { @@ -178,6 +181,8 @@ SYMBOL: deploy-vocab deploy-vocab get require r> [ call ] when* strip + "Compressing image" show + compress-image finish-deploy ] [ print-error flush 1 exit diff --git a/extra/tools/deploy/strip-cocoa.factor b/extra/tools/deploy/shaker/strip-cocoa.factor similarity index 100% rename from extra/tools/deploy/strip-cocoa.factor rename to extra/tools/deploy/shaker/strip-cocoa.factor diff --git a/extra/tools/deploy/strip-debugger.factor b/extra/tools/deploy/shaker/strip-debugger.factor similarity index 68% rename from extra/tools/deploy/strip-debugger.factor rename to extra/tools/deploy/shaker/strip-debugger.factor index a1aea339b2..38f5268c80 100644 --- a/extra/tools/deploy/strip-debugger.factor +++ b/extra/tools/deploy/shaker/strip-debugger.factor @@ -1,4 +1,6 @@ USING: kernel ; IN: debugger +: print-error die ; + : error. die ; diff --git a/extra/tools/interpreter/interpreter.factor b/extra/tools/interpreter/interpreter.factor index 526e105e4e..f1e36032a0 100644 --- a/extra/tools/interpreter/interpreter.factor +++ b/extra/tools/interpreter/interpreter.factor @@ -65,12 +65,14 @@ M: word (step-into) (step-into-execute) ; { >n ndrop >c c> continue continue-with - (continue-with) stop break + (continue-with) stop } [ dup [ execute break ] curry "step-into" set-word-prop ] each +\ break [ break ] "step-into" set-word-prop + ! Stepping : change-innermost-frame ( quot interpreter -- ) interpreter-continuation [ diff --git a/extra/ui/tools/walker/walker-tests.factor b/extra/ui/tools/walker/walker-tests.factor index 7ca8b8f2e9..04af885eff 100644 --- a/extra/ui/tools/walker/walker-tests.factor +++ b/extra/ui/tools/walker/walker-tests.factor @@ -65,4 +65,10 @@ IN: temporary [ ] [ yield ] unit-test [ t ] [ walker get-tool walker-active? ] unit-test + + [ ] [ "walker" get com-continue ] unit-test + + [ ] [ "walker" get com-continue ] unit-test + + [ ] [ "walker" get com-continue ] unit-test ] with-scope diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index 2ec4cd7dd6..fabdf26818 100644 --- a/extra/ui/tools/walker/walker.factor +++ b/extra/ui/tools/walker/walker.factor @@ -67,7 +67,11 @@ M: walker call-tool* ( continuation walker -- ) : com-continue ( walker -- ) #! Reset walker first, in case step-all ends up calling #! the walker again. - dup walker-interpreter swap reset-walker step-all ; + dup walker-active? [ + dup walker-interpreter swap reset-walker step-all + ] [ + drop + ] if ; : walker-help "ui-walker" help-window ; diff --git a/vm/data_gc.c b/vm/data_gc.c index 24d75cf20c..89e5ac3b56 100644 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -446,7 +446,8 @@ INLINE void *copy_untagged_object(void *pointer, CELL size) INLINE void forward_object(CELL pointer, CELL newpointer) { - put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED)); + if(pointer != newpointer) + put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED)); } INLINE CELL copy_object_impl(CELL pointer) diff --git a/vm/debug.c b/vm/debug.c index bd71960754..f0d74233d1 100644 --- a/vm/debug.c +++ b/vm/debug.c @@ -1,14 +1,23 @@ #include "master.h" +void print_chars(F_STRING* str) +{ + CELL i; + for(i = 0; i < string_capacity(str); i++) + putchar(cget(SREF(str,i))); +} + void print_word(F_WORD* word, CELL nesting) { - if(type_of(word->name) == STRING_TYPE) + + if(type_of(word->vocabulary) == STRING_TYPE) { - F_STRING *string = untag_string(word->name); - CELL i; - for(i = 0; i < string_capacity(string); i++) - putchar(cget(SREF(string,i))); + print_chars(untag_string(word->vocabulary)); + printf(":"); } + + if(type_of(word->name) == STRING_TYPE) + print_chars(untag_string(word->name)); else { printf("#cards_end - data_heap->cards)); } +void dump_objects(F_FIXNUM type) +{ + begin_scan(); + + CELL obj; + while((obj = next_object()) != F) + { + if(type == -1 || type_of(obj) == type) + { + print_nested_obj(obj,3); + printf("\n"); + } + } + + /* end scan */ + gc_off = false; +} + void factorbug(void) { reset_stdio(); @@ -200,8 +225,10 @@ void factorbug(void) printf("g -- dump generations\n"); printf("card -- print card containing address\n"); printf("addr -- print address containing card\n"); + printf("data -- data heap dump\n"); + printf("words -- words dump\n"); printf("code -- code heap dump\n"); - + for(;;) { char cmd[1024]; @@ -268,6 +295,10 @@ void factorbug(void) exit(1); else if(strcmp(cmd,"im") == 0) save_image(STR_FORMAT("fep.image")); + else if(strcmp(cmd,"data") == 0) + dump_objects(-1); + else if(strcmp(cmd,"words") == 0) + dump_objects(WORD_TYPE); else if(strcmp(cmd,"code") == 0) dump_heap(&code_heap); else diff --git a/vm/factor.c b/vm/factor.c index 3f471f87f1..270ad29208 100644 --- a/vm/factor.c +++ b/vm/factor.c @@ -19,6 +19,7 @@ void default_parameters(F_PARAMETERS *p) p->young_size = 2 * CELLS; p->aging_size = 4 * CELLS; p->secure_gc = false; + p->fep = false; } /* Get things started */ @@ -101,6 +102,8 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded else if(factor_arg(argv[i],STR_FORMAT("-codeheap=%d"),&p.code_size)); else if(STRCMP(argv[i],STR_FORMAT("-securegc")) == 0) p.secure_gc = true; + else if(STRCMP(argv[i],STR_FORMAT("-fep")) == 0) + p.fep = true; else if(STRNCMP(argv[i],STR_FORMAT("-i="),3) == 0) p.image = argv[i] + 3; } @@ -127,6 +130,10 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded userenv[EMBEDDED_ENV] = (embedded ? T : F); nest_stacks(); + + if(p.fep) + factorbug(); + c_to_factor_toplevel(userenv[BOOT_ENV]); unnest_stacks(); diff --git a/vm/ffi_test.c b/vm/ffi_test.c index bb8a38b0d9..f6e70fd6ac 100644 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -225,3 +225,23 @@ struct test_struct_7 ffi_test_30(void) } void ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41) { } + +double ffi_test_32(struct test_struct_8 x, int y) +{ + return (x.x + x.y) * y; +} + +double ffi_test_33(struct test_struct_9 x, int y) +{ + return (x.x + x.y) * y; +} + +double ffi_test_34(struct test_struct_10 x, int y) +{ + return (x.x + x.y) * y; +} + +double ffi_test_35(struct test_struct_11 x, int y) +{ + return (x.x + x.y) * y; +} diff --git a/vm/ffi_test.h b/vm/ffi_test.h index 8e392034ce..27e402b74f 100644 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -49,3 +49,11 @@ DLLEXPORT struct test_struct_6 ffi_test_29(void); struct test_struct_7 { char x, y, z, a, b, c, d; }; DLLEXPORT struct test_struct_7 ffi_test_30(void); DLLEXPORT void ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41); +struct test_struct_8 { double x; double y; }; +DLLEXPORT double ffi_test_32(struct test_struct_8 x, int y); +struct test_struct_9 { float x; float y; }; +DLLEXPORT double ffi_test_33(struct test_struct_9 x, int y); +struct test_struct_10 { float x; int y; }; +DLLEXPORT double ffi_test_34(struct test_struct_10 x, int y); +struct test_struct_11 { int x; int y; }; +DLLEXPORT double ffi_test_35(struct test_struct_11 x, int y); diff --git a/vm/image.h b/vm/image.h index a15f850bb3..ba953677cf 100644 --- a/vm/image.h +++ b/vm/image.h @@ -31,6 +31,7 @@ typedef struct { CELL gen_count, young_size, aging_size; CELL code_size; bool secure_gc; + bool fep; } F_PARAMETERS; void load_image(F_PARAMETERS *p); diff --git a/vm/primitives.c b/vm/primitives.c index 649b7294f9..2438b6b1aa 100644 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -194,4 +194,5 @@ void *primitives[] = { primitive_innermost_stack_frame_scan, primitive_set_innermost_stack_frame_quot, primitive_call_clear, + primitive_strip_compiled_quotations, }; diff --git a/vm/quotations.c b/vm/quotations.c index ba9325f0dc..ace8740d64 100644 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -231,3 +231,22 @@ DEFINE_PRIMITIVE(quotation_xt) F_QUOTATION *quot = untag_quotation(dpeek()); drepl(allot_cell((CELL)quot->xt)); } + +DEFINE_PRIMITIVE(strip_compiled_quotations) +{ + begin_scan(); + + CELL obj; + while((obj = next_object()) != F) + { + if(type_of(obj) == QUOTATION_TYPE) + { + F_QUOTATION *quot = untag_object(obj); + quot->compiled = F; + quot->xt = lazy_jit_compile; + } + } + + /* end scan */ + gc_off = false; +} diff --git a/vm/quotations.h b/vm/quotations.h index 5757e10c97..d70d37ac44 100644 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -6,3 +6,4 @@ DECLARE_PRIMITIVE(curry); DECLARE_PRIMITIVE(array_to_quotation); DECLARE_PRIMITIVE(quotation_xt); DECLARE_PRIMITIVE(uncurry); +DECLARE_PRIMITIVE(strip_compiled_quotations);