diff --git a/basis/compiler/tree/dead-code/recursive/recursive.factor b/basis/compiler/tree/dead-code/recursive/recursive.factor index 03d4e919ee..02dc42f058 100644 --- a/basis/compiler/tree/dead-code/recursive/recursive.factor +++ b/basis/compiler/tree/dead-code/recursive/recursive.factor @@ -84,7 +84,7 @@ M:: #recursive remove-dead-code* ( node -- nodes ) drop-outputs [ node drop-recursive-outputs ] | node [ (remove-dead-code) ] change-child drop node label>> [ filter-live ] change-enter-out drop - drop-inputs node drop-outputs 3array + { drop-inputs node drop-outputs } ] ; M: #return-recursive remove-dead-code* ; diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 6638951723..d73e8b7db1 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -7,7 +7,8 @@ byte-arrays classes.algebra classes.tuple.private math.functions math.private strings layouts compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker -slots.private words hashtables classes assocs ; +slots.private words hashtables classes assocs locals +float-arrays ; IN: compiler.tree.propagation.tests \ propagate must-infer @@ -587,6 +588,8 @@ MIXIN: empty-mixin [ { fixnum integer } declare bitand ] final-classes ] unit-test +[ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test + ! [ V{ string } ] [ ! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes ! ] unit-test diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 67a8ec8a2c..5328f2a263 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -62,10 +62,6 @@ M: float-regs store-return-reg load/store-float-return FSTP ; : with-aligned-stack ( n quot -- ) swap dup align-sub slip align-add ; inline -! On x86, we can always use an address as an operand -! directly. -M: x86.32 address-operand ; - M: x86.32 fixnum>slot@ 1 SHR ; M: x86.32 prepare-division CDQ ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 4770c09a83..c135d0490d 100755 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -33,13 +33,6 @@ M: float-regs vregs M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; -M: x86.64 address-operand ( address -- operand ) - #! On AMD64, we have to load 64-bit addresses into a - #! scratch register first. The usage of R11 here is a hack. - #! This word can only be called right before a subroutine - #! call, where all vregs have been flushed anyway. - temp-reg v>operand [ swap MOV ] keep ; - M: x86.64 fixnum>slot@ drop ; M: x86.64 prepare-division CQO ; @@ -49,8 +42,8 @@ M: x86.64 load-indirect ( literal reg -- ) M: stack-params %load-param-reg drop - >r temp-reg v>operand swap stack@ MOV - r> stack@ temp-reg v>operand MOV ; + >r R11 swap stack@ MOV + r> stack@ R11 MOV ; M: stack-params %save-param-reg >r stack-frame* + cell + swap r> %load-param-reg ; @@ -138,7 +131,9 @@ M: x86.64 %alien-global [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ; M: x86.64 %alien-invoke - 0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ; + R11 0 MOV + rc-absolute-cell rel-dlsym + R11 CALL ; M: x86.64 %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 171e67bcfb..04b496f12a 100755 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -39,8 +39,6 @@ GENERIC: store-return-reg ( stack@ reg-class -- ) HOOK: temp-reg-1 cpu ( -- reg ) HOOK: temp-reg-2 cpu ( -- reg ) -HOOK: address-operand cpu ( address -- operand ) - HOOK: fixnum>slot@ cpu ( op -- ) HOOK: prepare-division cpu ( -- ) diff --git a/basis/hints/hints-docs.factor b/basis/hints/hints-docs.factor index 99c4a2ddfc..347cfd3ef4 100644 --- a/basis/hints/hints-docs.factor +++ b/basis/hints/hints-docs.factor @@ -20,9 +20,24 @@ HELP: specialized-def { $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ; HELP: HINTS: -{ $values { "word" word } { "hints..." "a list of sequences of classes" } } -{ $description "Defines specialization hints for each words. Each sequence of classes in the list will cause a specialized version of the word to be compiled." } +{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes" } } +{ $description "Defines specialization hints for a word or a method." +$nl +"Each sequence of classes in the list will cause a specialized version of the word to be compiled." } { $examples "The " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:" -{ $code "HINTS: append { string string } { array array } ;" } } ; +{ $code "HINTS: append { string string } { array array } ;" } +"Specializers can also be defined on methods:" +{ $code + "GENERIC: count-occurrences ( elt obj -- n )" + "" + "M: sequence count-occurrences [ = ] with count ;" + "" + "M: assoc count-occurrences" + " swap [ = nip ] curry assoc-filter assoc-size ;" + "" + "HINTS: { sequence count-occurrences } { object array } ;" + "HINTS: { assoc count-occurrences } { object hashtable } ;" +} +} ; ABOUT: "hints" diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 1138ad872a..a10588d730 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -42,11 +42,11 @@ IN: hints : specialized-def ( word -- quot ) dup def>> swap { - { [ dup standard-method? ] [ specialize-method ] } { [ dup "specializer" word-prop ] [ "specializer" word-prop specialize-quot ] } + { [ dup standard-method? ] [ specialize-method ] } [ drop ] } cond ; @@ -54,7 +54,8 @@ IN: hints dup [ array? ] all? [ first ] when length ; : HINTS: - scan-word + scan-object + dup method-spec? [ first2 method ] when [ redefined ] [ parse-definition "specializer" set-word-prop ] bi ; parsing diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 59ec325f39..eb06d05146 100755 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -329,4 +329,6 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; [ 10 20 30 [| a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test [ T{ slice f 0 3 "abc" } ] -[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test \ No newline at end of file +[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test + +{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as \ No newline at end of file diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index bfc92ee9e2..05ea3cb524 100755 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -6,7 +6,7 @@ quotations debugger macros arrays macros splitting combinators prettyprint.backend definitions prettyprint hashtables prettyprint.sections sets sequences.private effects effects.parser generic generic.parser compiler.units accessors -locals.backend memoize macros.expander lexer +locals.backend memoize macros.expander lexer classes stack-checker.known-words ; IN: locals @@ -195,70 +195,41 @@ M: block lambda-rewrite* swap point-free , ] keep length \ curry % ; +GENERIC: rewrite-element ( obj -- ) + +: rewrite-elements ( seq -- ) + [ rewrite-element ] each ; + +: rewrite-sequence ( seq -- ) + [ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ; + +M: array rewrite-element rewrite-sequence ; + +M: vector rewrite-element rewrite-sequence ; + +M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ; + +M: tuple rewrite-element + [ tuple-slots rewrite-elements ] [ class , ] bi \ boa , ; + +M: local rewrite-element , ; + +M: word rewrite-element literalize , ; + +M: object rewrite-element , ; + +M: array local-rewrite* rewrite-element ; + +M: vector local-rewrite* rewrite-element ; + +M: tuple local-rewrite* rewrite-element ; + +M: hashtable local-rewrite* rewrite-element ; + M: object lambda-rewrite* , ; M: object local-rewrite* , ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! Broil is used to support locals in literals - -DEFER: [broil] -DEFER: [broil-hashtable] -DEFER: [broil-tuple] - -: broil-element ( obj -- quot ) - { - { [ dup number? ] [ 1quotation ] } - { [ dup string? ] [ 1quotation ] } - { [ dup sequence? ] [ [broil] ] } - { [ dup hashtable? ] [ [broil-hashtable] ] } - { [ dup tuple? ] [ [broil-tuple] ] } - { [ dup local? ] [ 1quotation ] } - { [ dup word? ] [ literalize 1quotation ] } - { [ t ] [ 1quotation ] } - } - cond ; - -: [broil] ( seq -- quot ) - [ [ broil-element ] map concat >quotation ] - [ length ] - [ ] - tri - [ nsequence ] curry curry compose ; - -MACRO: broil ( seq -- quot ) [broil] ; - -: [broil-hashtable] ( hashtable -- quot ) - >alist - [ [ broil-element ] map concat >quotation ] - [ length ] - [ ] - tri - [ nsequence >hashtable ] curry curry compose ; - -MACRO: broil-hashtable ( hashtable -- quot ) [broil-hashtable] ; - -: [broil-tuple] ( tuple -- quot ) - tuple>array - [ [ broil-element ] map concat >quotation ] - [ length ] - [ ] - tri - [ nsequence >tuple ] curry curry compose ; - -MACRO: broil-tuple ( tuple -- quot ) [broil-tuple] ; - -! Engage broil on arrays and vectors. Can't do it on 'sequence' -! because that will pick up strings and integers. What do do... - -M: array local-rewrite* ( array -- ) [broil] % ; -M: vector local-rewrite* ( vector -- ) [broil] % ; -M: tuple local-rewrite* ( tuple -- ) [broil-tuple] % ; -M: hashtable local-rewrite* ( hashtable -- ) [broil-hashtable] % ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : make-local ( name -- word ) "!" ?tail [ diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 96c2ec2fcc..c836bfc2b6 100755 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -3,7 +3,7 @@ USING: accessors kernel words parser io summary quotations sequences prettyprint continuations effects definitions compiler.units namespaces assocs tools.walker generic -inspector ; +inspector fry ; IN: tools.annotations GENERIC: reset ( word -- ) @@ -49,20 +49,18 @@ M: word reset .s ] if* "\\--" print flush ; -: (watch) ( word def -- def ) - over [ entering ] curry - rot [ leaving ] curry - swapd 3append ; +: (watch) ( word def -- def ) over '[ _ entering @ _ leaving ] ; : watch ( word -- ) dup [ (watch) ] annotate ; : (watch-vars) ( quot word vars -- newquot ) - [ - "--- Entering: " write swap . - "--- Variable values:" print - [ dup get ] H{ } map>assoc describe - ] 2curry prepose ; + rot + '[ + "--- Entering: " write _ . + "--- Variable values:" print _ [ dup get ] H{ } map>assoc describe + @ + ] ; : watch-vars ( word vars -- ) dupd [ (watch-vars) ] 2curry annotate ; diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 69454505a5..34bac61292 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -3,7 +3,7 @@ USING: arrays accessors float-arrays io io.files io.encodings.binary kernel math math.functions math.vectors -math.parser make sequences sequences.private words ; +math.parser make sequences sequences.private words hints ; IN: benchmark.raytracer ! parameters @@ -38,34 +38,40 @@ TUPLE: sphere { center float-array read-only } { radius float read-only } ; C: sphere : sphere-v ( sphere ray -- v ) - swap center>> swap orig>> v- ; inline + [ center>> ] [ orig>> ] bi* v- ; inline -: sphere-b ( ray v -- b ) swap dir>> v. ; inline +: sphere-b ( v ray -- b ) + dir>> v. ; inline -: sphere-disc ( sphere v b -- d ) - sq swap norm-sq - swap radius>> sq + ; inline +: sphere-d ( sphere b v -- d ) + [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline -: -+ ( x y -- x-y x+y ) [ - ] 2keep + ; inline +: -+ ( x y -- x-y x+y ) + [ - ] [ + ] 2bi ; inline -: sphere-b/d ( b d -- t ) +: sphere-t ( b d -- t ) -+ dup 0.0 < [ 2drop 1.0/0.0 ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline -: ray-sphere ( sphere ray -- t ) - 2dup sphere-v tuck sphere-b [ sphere-disc ] keep - over 0.0 < [ 2drop 1.0/0.0 ] [ swap sqrt sphere-b/d ] if ; - inline +: sphere-b&v ( sphere ray -- b v ) + [ sphere-v ] [ nip ] 2bi + [ sphere-b ] [ drop ] 2bi ; inline -: sphere-n ( ray sphere l -- n ) - pick dir>> n*v swap center>> v- swap orig>> v+ ; - inline +: 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 : if-ray-sphere ( hit ray sphere quot -- hit ) #! quot: hit ray sphere l -- hit [ - pick lambda>> [ 2dup swap ray-sphere dup ] dip >= - [ 3drop ] - ] dip if ; inline + [ ] [ swap ray-sphere nip ] [ 2drop lambda>> ] 3tri + [ drop ] [ < ] 2bi + ] dip [ 3drop ] if ; inline + +: 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 nip ] if-ray-sphere ; @@ -79,21 +85,17 @@ TUPLE: group < sphere { objs array read-only } ; swap [ { } make ] dip ; inline M: group intersect-scene ( hit ray group -- hit ) - [ - drop - objs>> [ [ tuck ] dip intersect-scene swap ] each - drop - ] if-ray-sphere ; + [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ; -: initial-hit T{ hit f F{ 0.0 0.0 0.0 } 1.0/0.0 } ; inline +: initial-hit T{ hit f F{ 0.0 0.0 0.0 } 1/0. } ; inline : initial-intersect ( ray scene -- hit ) - initial-hit -rot intersect-scene ; inline + [ initial-hit ] 2dip intersect-scene ; inline : ray-o ( ray hit -- o ) - over dir>> over lambda>> v*n - swap normal>> delta v*n v+ - swap orig>> v+ ; inline + [ [ orig>> ] [ normal>> delta v*n ] bi* ] + [ [ dir>> ] [ lambda>> ] bi* v*n ] + 2bi v+ v+ ; inline : sray-intersect ( ray scene hit -- ray ) swap [ ray-o light vneg ] dip initial-intersect ; inline @@ -101,10 +103,10 @@ M: group intersect-scene ( hit ray group -- hit ) : ray-g ( hit -- g ) normal>> light v. ; inline : cast-ray ( ray scene -- g ) - 2dup initial-intersect dup lambda>> 1.0/0.0 = [ + 2dup initial-intersect dup lambda>> 1/0. = [ 3drop 0.0 ] [ - [ sray-intersect lambda>> 1.0/0.0 = ] keep swap + [ sray-intersect lambda>> 1/0. = ] keep swap [ ray-g neg ] [ drop 0.0 ] if ] if ; inline diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor index 3c20a1ceff..245027ef77 100644 --- a/extra/benchmark/spectral-norm/spectral-norm.factor +++ b/extra/benchmark/spectral-norm/spectral-norm.factor @@ -32,8 +32,10 @@ IN: benchmark.spectral-norm : eval-AtA-times-u ( u n -- seq ) [ eval-A-times-u ] [ eval-At-times-u ] bi ; inline +: ones ( n -- seq ) [ 1.0 ] F{ } replicate-as ; inline + :: u/v ( n -- u v ) - n 1.0 >float-array dup + n ones dup 10 [ drop n eval-AtA-times-u