From e2ceb113374da17e7749046b1af45e3764d5e383 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 17 Jul 2010 15:57:44 -0400 Subject: [PATCH 01/21] stack-checker: calling 'boa' on a non-tuple would compile as a no-op rather than an error (reported by Joe Groff); clean up some other error reporting code too --- basis/compiler/tests/simple.factor | 5 ++++- basis/compiler/tests/tuples.factor | 6 ++++++ basis/stack-checker/backend/backend.factor | 12 +++++------- basis/stack-checker/known-words/known-words.factor | 7 +------ basis/stack-checker/transforms/transforms.factor | 4 +++- 5 files changed, 19 insertions(+), 15 deletions(-) diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index df67cadd78..8b1fc3569f 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -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 diff --git a/basis/compiler/tests/tuples.factor b/basis/compiler/tests/tuples.factor index 978c27768f..e92057faf9 100644 --- a/basis/compiler/tests/tuples.factor +++ b/basis/compiler/tests/tuples.factor @@ -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 diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 7a18133eff..d757e02ca9 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -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 ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 9791919392..4b43c4c2f1 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -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 diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 610d3f8600..d24be0e783 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -145,7 +145,9 @@ IN: stack-checker.transforms [ depends-on-tuple-layout ] [ [ "boa-check" word-prop [ ] or ] dip ] 2bi '[ @ _ ] - ] [ drop f ] if + ] [ + \ boa time-bomb + ] if ] 1 define-transform \ boa t "no-compile" set-word-prop From 88ca7abd5480a8f9dda8c8a2dade81737bb39949 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 17 Jul 2010 16:08:36 -0400 Subject: [PATCH 02/21] ui.gadgets.worlds: dispose of the handle after ungrabbing input --- basis/ui/gadgets/worlds/worlds.factor | 11 ++++------- basis/ui/ui.factor | 2 +- 2 files changed, 5 insertions(+), 8 deletions(-) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index e713b0f999..7e064ee76b 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -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 ] diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index d65f4725a9..fad774cbcc 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -90,8 +90,8 @@ M: world ungraft* [ hand-gadget close-global ] [ end-world ] [ [ [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ] - [ [ (close-window) f ] change-handle drop ] [ unfocus-world ] + [ [ (close-window) f ] change-handle drop ] [ promise>> t swap fulfill ] } cleave ; From 35e5c572ce291dd0bc94d715b50d36edbad8a4a5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 17 Jul 2010 16:09:25 -0400 Subject: [PATCH 03/21] ui: cleanup --- basis/ui/ui.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index fad774cbcc..68bb064328 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -81,6 +81,9 @@ M: world graft* [ [ clean-up-broken-window ] [ ui-error ] bi* ] recover ] bi ; +: dispose-window-resources ( world -- ) + [ [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ; + M: world ungraft* { [ set-gl-context ] @@ -89,7 +92,7 @@ M: world ungraft* [ hand-clicked close-global ] [ hand-gadget close-global ] [ end-world ] - [ [ [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ] + [ dispose-window-resources ] [ unfocus-world ] [ [ (close-window) f ] change-handle drop ] [ promise>> t swap fulfill ] From 6914e69d69099565e5af356ee6487259df121934 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 18 Jul 2010 16:27:02 -0400 Subject: [PATCH 04/21] calendar.unix: rename timespec>seconds to timespec>duration to be consistent with timeval>duration --- basis/calendar/unix/unix.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index a1e83cc1c1..9f7d165925 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -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 localtime ; From 57081d5b5ec400cd022eb7e944f380041209c7fe Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 18 Jul 2010 13:42:51 -0700 Subject: [PATCH 05/21] calendar: since-1970 shouldn't >local-time; this causes words that want to return GMT to return local time too --- basis/calendar/calendar.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index d9a6dfb370..4e6b35161f 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -532,7 +532,7 @@ M: integer end-of-year 12 31 ; dup midnight time- ; : since-1970 ( duration -- timestamp ) - unix-1970 time+ >local-time ; + unix-1970 time+ ; : timestamp>unix-time ( timestamp -- seconds ) unix-1970 time- second>> ; From fd053eb0289a24b03e57283a8c4cc5ec12e71ae5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 18 Jul 2010 13:45:00 -0700 Subject: [PATCH 06/21] calendar: unit test for gmt --- basis/calendar/calendar-tests.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index 5cfb042608..a79183b309 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -185,3 +185,6 @@ IN: calendar.tests 2008 1 29 1 months time+ 2008 2 29 = ] unit-test + +[ 0 ] +[ gmt gmt-offset>> duration>seconds ] unit-test From 80d0ed0110ba09d86123c49bb99ba1a8a38a1957 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 18 Jul 2010 17:30:49 -0400 Subject: [PATCH 07/21] ui.gadgets.labels: fix stack effects for label-on-left and label-on-right --- basis/ui/gadgets/labels/labels.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor index 5e91e5bfb7..0c1aecad52 100644 --- a/basis/ui/gadgets/labels/labels.factor +++ b/basis/ui/gadgets/labels/labels.factor @@ -106,12 +106,12 @@ M: f >label drop ; { 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 ; From b776a925465b59ab0231a54f8e4f50640ffe19c9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 18 Jul 2010 17:38:29 -0400 Subject: [PATCH 08/21] compiler.cfg.linear-scan: fix bad interaction between split position calculation and register-clobbering instructions --- .../linear-scan/allocation/allocation.factor | 45 ++++++------------- .../allocation/spilling/spilling.factor | 7 +-- .../live-intervals/live-intervals.factor | 36 ++++++++++----- 3 files changed, 43 insertions(+), 45 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 92f09c650f..d4f79e5cb3 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -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-sync-points unhandled-intervals smallest-heap ] + } cond heap-pop drop handle ; : (allocate-registers) ( unhandled-intervals unhandled-sync-points -- ) 2dup [ heap-empty? ] both? [ 2drop ] [ diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index e773cb9e46..bc1f538a5c 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -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 diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 665ffc324d..fbe0cd4507 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -16,7 +16,7 @@ TUPLE: live-range from to ; C: live-range -TUPLE: vreg-use n def-rep use-rep ; +TUPLE: vreg-use n def-rep use-rep spill-slot? ; : ( 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 ; From adc9db3ea8bafa4a922960e2396fd59f67e8e091 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 19 Jul 2010 06:46:50 -0400 Subject: [PATCH 09/21] compiler.cfg.linear-scan.allocation: fix wrong order --- basis/compiler/cfg/linear-scan/allocation/allocation.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index d4f79e5cb3..f102a6ae9c 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -73,7 +73,7 @@ M: sync-point handle ( sync-point -- ) { { [ unhandled-intervals heap-empty? ] [ unhandled-sync-points ] } { [ unhandled-sync-points heap-empty? ] [ unhandled-intervals ] } - [ unhandled-sync-points unhandled-intervals smallest-heap ] + [ unhandled-intervals unhandled-sync-points smallest-heap ] } cond heap-pop drop handle ; : (allocate-registers) ( unhandled-intervals unhandled-sync-points -- ) From 8e46305288ae85c658e57ae5b8a41f0df4885813 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 19 Jul 2010 09:27:10 -0400 Subject: [PATCH 10/21] compiler.cfg.save-contexts: don't insert ##save-context in front of ##phi --- basis/compiler/cfg/def-use/def-use.factor | 8 +- .../cfg/liveness/liveness-tests.factor | 109 ++++++++++++++++-- .../save-contexts/save-contexts-tests.factor | 17 +++ .../cfg/save-contexts/save-contexts.factor | 1 + 4 files changed, 122 insertions(+), 13 deletions(-) diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index bfbf13e1a9..99e87b277b 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -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 [ diff --git a/basis/compiler/cfg/liveness/liveness-tests.factor b/basis/compiler/cfg/liveness/liveness-tests.factor index e4f5144e1f..b86f04b8b0 100644 --- a/basis/compiler/cfg/liveness/liveness-tests.factor +++ b/basis/compiler/cfg/liveness/liveness-tests.factor @@ -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 \ No newline at end of file +[ 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 \ No newline at end of file diff --git a/basis/compiler/cfg/save-contexts/save-contexts-tests.factor b/basis/compiler/cfg/save-contexts/save-contexts-tests.factor index e074d95b1a..ad89abb97f 100644 --- a/basis/compiler/cfg/save-contexts/save-contexts-tests.factor +++ b/basis/compiler/cfg/save-contexts/save-contexts-tests.factor @@ -62,3 +62,20 @@ V{ ] [ 0 get instructions>> ] unit-test + +V{ + T{ ##phi } + T{ ##add } +} 0 test-bb + +0 get insert-save-context + +[ + V{ + T{ ##phi } + T{ ##save-context f 7 8 } + T{ ##add } + } +] [ + 0 get instructions>> +] unit-test diff --git a/basis/compiler/cfg/save-contexts/save-contexts.factor b/basis/compiler/cfg/save-contexts/save-contexts.factor index e20cb68020..57691f1a4e 100644 --- a/basis/compiler/cfg/save-contexts/save-contexts.factor +++ b/basis/compiler/cfg/save-contexts/save-contexts.factor @@ -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 ; From b23aac1beb465cdc99fce390e8b46a9aefafd469 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 19 Jul 2010 10:09:28 -0400 Subject: [PATCH 11/21] compiler.cfg: open-code parameter boxing and unboxing for certain C types --- basis/alien/c-types/c-types.factor | 12 +-- .../cfg/builder/alien/boxing/boxing.factor | 25 +++-- .../cfg/instructions/instructions.factor | 6 ++ .../save-contexts/save-contexts-tests.factor | 4 +- basis/compiler/codegen/codegen.factor | 1 + basis/compiler/tests/low-level-ir.factor | 21 ++++ basis/cpu/architecture/architecture.factor | 2 + basis/cpu/x86/x86.factor | 23 +++++ vm/alien.cpp | 17 +--- vm/alien.hpp | 4 - vm/code_heap.cpp | 7 +- vm/errors.cpp | 4 +- vm/math.cpp | 96 +------------------ vm/math.hpp | 15 +-- vm/objects.cpp | 2 +- vm/primitives.hpp | 12 +-- vm/quotations.cpp | 4 +- vm/vm.hpp | 12 +-- vm/words.cpp | 8 +- 19 files changed, 107 insertions(+), 168 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 389883535f..46c2209db9 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -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 diff --git a/basis/compiler/cfg/builder/alien/boxing/boxing.factor b/basis/compiler/cfg/builder/alien/boxing/boxing.factor index abfad6a451..180b22e477 100644 --- a/basis/compiler/cfg/builder/alien/boxing/boxing.factor +++ b/basis/compiler/cfg/builder/alien/boxing/boxing.factor @@ -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 ^^box ] } case ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index f78b77d2f0..5ce7124b4e 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -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 diff --git a/basis/compiler/cfg/save-contexts/save-contexts-tests.factor b/basis/compiler/cfg/save-contexts/save-contexts-tests.factor index ad89abb97f..fe06d4c7de 100644 --- a/basis/compiler/cfg/save-contexts/save-contexts-tests.factor +++ b/basis/compiler/cfg/save-contexts/save-contexts-tests.factor @@ -65,7 +65,7 @@ V{ V{ T{ ##phi } - T{ ##add } + T{ ##box } } 0 test-bb 0 get insert-save-context @@ -74,7 +74,7 @@ V{ V{ T{ ##phi } T{ ##save-context f 7 8 } - T{ ##add } + T{ ##box } } ] [ 0 get instructions>> diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index e3746090cd..1d7f9eb14e 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -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 diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor index 6ec8791ad3..473bd4788f 100644 --- a/basis/compiler/tests/low-level-ir.factor +++ b/basis/compiler/tests/low-level-ir.factor @@ -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 diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index e69a1cd283..d40450e298 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -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 -- ) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index c5fce25df0..16037dc62a 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -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 dup bits n-bit-version-of dup src MOV + 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 diff --git a/vm/alien.cpp b/vm/alien.cpp index 1fa86389a1..71708a5fa1 100755 --- a/vm/alien.cpp +++ b/vm/alien.cpp @@ -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); -} - } diff --git a/vm/alien.hpp b/vm/alien.hpp index cd0120db6f..412ef35bb4 100755 --- a/vm/alien.hpp +++ b/vm/alien.hpp @@ -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); - } diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index 96d9541665..b42261619b 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -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); diff --git a/vm/errors.cpp b/vm/errors.cpp index 1867965108..61d4a73194 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -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() diff --git a/vm/math.cpp b/vm/math.cpp index e64db2690e..b872e7057f 100755 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -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) diff --git a/vm/math.hpp b/vm/math.hpp index dc6d37bcfd..ffe60dced5 100644 --- a/vm/math.hpp +++ b/vm/math.hpp @@ -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(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(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); diff --git a/vm/objects.cpp b/vm/objects.cpp index a370e3f712..98368a6f83 100644 --- a/vm/objects.cpp +++ b/vm/objects.cpp @@ -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 { diff --git a/vm/primitives.hpp b/vm/primitives.hpp index 5df73f5fac..f7291430b5 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -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_unsigned_cell,to_fixnum) \ + _(unsigned_4,u32,from_unsigned_cell,to_cell) \ + _(signed_2,s16,from_unsigned_cell,to_fixnum) \ + _(unsigned_2,u16,from_unsigned_cell,to_cell) \ + _(signed_1,s8,from_unsigned_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) diff --git a/vm/quotations.cpp b/vm/quotations.cpp index faa770c512..b3c4f14887 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -328,8 +328,8 @@ void factor_vm::primitive_quotation_code() { quotation *quot = untag_check(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 */ diff --git a/vm/vm.hpp b/vm/vm.hpp index 40b3df5ecf..90e1184c7c 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -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); diff --git a/vm/words.cpp b/vm/words.cpp index 31041a6a19..243e476f94 100644 --- a/vm/words.cpp +++ b/vm/words.cpp @@ -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())); } } From cc0d69416f133542fc45700bad7db27a08e04189 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 19 Jul 2010 16:03:27 -0400 Subject: [PATCH 12/21] vm: fix alien-signed-1/2/4 primitives --- vm/primitives.hpp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/vm/primitives.hpp b/vm/primitives.hpp index f7291430b5..77c255afd5 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -138,11 +138,11 @@ 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_unsigned_cell,to_fixnum) \ + _(signed_4,s32,from_signed_cell,to_fixnum) \ _(unsigned_4,u32,from_unsigned_cell,to_cell) \ - _(signed_2,s16,from_unsigned_cell,to_fixnum) \ + _(signed_2,s16,from_signed_cell,to_fixnum) \ _(unsigned_2,u16,from_unsigned_cell,to_cell) \ - _(signed_1,s8,from_unsigned_cell,to_fixnum) \ + _(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) \ From 0fbe78be004dfd7782e16edb79310d827e34544c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 19 Jul 2010 16:03:39 -0400 Subject: [PATCH 13/21] cpu.x86.64: fix calling varargs functions --- basis/cpu/x86/32/32.factor | 2 ++ basis/cpu/x86/64/64.factor | 2 ++ basis/cpu/x86/x86.factor | 5 +++-- 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 7ed80d1e39..3808fb47ba 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -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. diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 0aad0382fd..fad1a747e6 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -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= ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 16037dc62a..6442044d35 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -347,8 +347,8 @@ M: x86.64 has-small-reg? 2drop t ; :: (%convert-integer) ( dst src bits quot -- ) dst { src } bits [| new-dst | - new-dst dup bits n-bit-version-of dup src MOV - quot call + 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 @@ -644,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 From b6fe62299e8561e2bc416cc5730162aceda8d6b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 19 Jul 2010 19:56:00 -0400 Subject: [PATCH 14/21] compiler.cfg.alias-analysis: factor-call-insns which defined values were not handled properly --- .../cfg/alias-analysis/alias-analysis.factor | 1 + basis/compiler/tests/alien.factor | 19 ++++++++++++++++++- 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index dbceb24968..5ba0bd1300 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -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 diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index f263e1e0f8..d2c51c2302 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -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 From f7bd876caed4ce7f04638b1da2816faee69ffa81 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 21 Jul 2010 00:23:35 -0400 Subject: [PATCH 15/21] io.files.unix: fix tests for recent calendar.unix vocab changes --- basis/io/files/unix/unix-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/io/files/unix/unix-tests.factor b/basis/io/files/unix/unix-tests.factor index 06f7473aed..3028dc70c8 100644 --- a/basis/io/files/unix/unix-tests.factor +++ b/basis/io/files/unix/unix-tests.factor @@ -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 From abf9efe731f1074073cd36d49e6736a01ddbad5a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 22 Jul 2010 14:34:59 -0700 Subject: [PATCH 16/21] gdbm: don't run tests on 64-bit Windows since there's no gdbm there --- extra/gdbm/gdbm-tests.factor | 75 ++++++++++++++++++------------------ 1 file changed, 38 insertions(+), 37 deletions(-) diff --git a/extra/gdbm/gdbm-tests.factor b/extra/gdbm/gdbm-tests.factor index 4a102deeb1..a588d4d650 100644 --- a/extra/gdbm/gdbm-tests.factor +++ b/extra/gdbm/gdbm-tests.factor @@ -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 From b0ec82c64e63db1e2b0fb5c21c25c473fa6c691b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 22 Jul 2010 17:29:20 -0700 Subject: [PATCH 17/21] gdbm: fix tests --- extra/gdbm/gdbm-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/gdbm/gdbm-tests.factor b/extra/gdbm/gdbm-tests.factor index a588d4d650..18ca0d02aa 100644 --- a/extra/gdbm/gdbm-tests.factor +++ b/extra/gdbm/gdbm-tests.factor @@ -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 ; From c04de94b96d6c2929e89878d6cefe09c50b68419 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 23 Jul 2010 16:31:15 -0700 Subject: [PATCH 18/21] compiler.tree.finalization: record dependencies on inlined predicates --- basis/compiler/tree/finalization/finalization.factor | 10 +++++++--- core/classes/tuple/tuple-tests.factor | 6 ++++++ 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index fca35a5653..72ea22422b 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -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 ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 5aec400fbe..722cdd998a 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -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 C: laptop C: 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 From 44dc1aadc0bd68677cb201c87c78bd50f3e3e21f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 23 Jul 2010 19:44:39 -0700 Subject: [PATCH 19/21] regexp: fix match iteration with empty matches, and fix reverse regexes since they were totally broken (bugs reported by Joe Groff and various others) --- basis/regexp/regexp-tests.factor | 61 ++++++++++++++++++++++------ basis/regexp/regexp.factor | 68 ++++++++++++++++++++------------ 2 files changed, 93 insertions(+), 36 deletions(-) diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 2488f568da..609636c1d1 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -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*" 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]" matches? ] unit-test [ f ] [ "a" "[a-z.-]@[a-z]" matches? ] unit-test [ t ] [ ".o" "\\.[a-z]" matches? ] unit-test @@ -272,6 +273,10 @@ IN: regexp-tests [ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" 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)" first-match >string ] unit-test diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index bbfe440967..de0c1a03a7 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -50,33 +50,49 @@ PRIVATE> > - 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 ; From cdb52119a0e073689c02735a454e584f5b70c96c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 23 Jul 2010 20:40:44 -0700 Subject: [PATCH 20/21] regexp: fix test --- basis/regexp/regexp-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 609636c1d1..d53f50c6d1 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -291,7 +291,7 @@ 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 +[ { "" "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 ] From 3dbb8e6153205ff6165dcf4edbfa0dfcbd2f0341 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 23 Jul 2010 20:41:08 -0700 Subject: [PATCH 21/21] math.matrices: move normal word from gpu.demos.bunny and reverse sign --- basis/math/matrices/matrices-tests.factor | 2 +- basis/math/matrices/matrices.factor | 3 +++ basis/math/vectors/simd/simd-tests.factor | 4 ++++ extra/gpu/demos/bunny/bunny.factor | 4 ---- 4 files changed, 8 insertions(+), 5 deletions(-) diff --git a/basis/math/matrices/matrices-tests.factor b/basis/math/matrices/matrices-tests.factor index b827741209..3996a475ba 100644 --- a/basis/math/matrices/matrices-tests.factor +++ b/basis/math/matrices/matrices-tests.factor @@ -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 } } ] diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 216d2c31bb..35d6f380cb 100644 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -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 ; diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor index 3b8ae7d2b4..5a0a98107c 100644 --- a/basis/math/vectors/simd/simd-tests.factor +++ b/basis/math/vectors/simd/simd-tests.factor @@ -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 ] [ diff --git a/extra/gpu/demos/bunny/bunny.factor b/extra/gpu/demos/bunny/bunny.factor index 28deff905c..f29e12c1a2 100644 --- a/extra/gpu/demos/bunny/bunny.factor +++ b/extra/gpu/demos/bunny/bunny.factor @@ -119,10 +119,6 @@ UNIFORM-TUPLE: loading-uniforms 100000 (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