From 982e704626a9597f78277de134ea38281e71f9b0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 May 2010 18:22:35 -0400 Subject: [PATCH 01/14] compiler.cfg.linear-scan: clean up clobber-insn handling --- .../linear-scan/allocation/allocation.factor | 7 +- .../allocation/spilling/spilling.factor | 22 ++- .../allocation/splitting/splitting.factor | 7 +- .../linear-scan/assignment/assignment.factor | 14 +- .../cfg/linear-scan/linear-scan-tests.factor | 143 +++++++++++++----- .../live-intervals/live-intervals.factor | 55 +++---- 6 files changed, 153 insertions(+), 95 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index ed7690bd77..c1b3f04ff4 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -35,10 +35,9 @@ IN: compiler.cfg.linear-scan.allocation } cond ; : spill-at-sync-point ( live-interval n -- ? ) - ! If the live interval has a usage at 'n', don't spill it, - ! since this means its being defined by the sync point - ! instruction. Output t if this is the case. - 2dup [ uses>> ] dip '[ n>> _ = ] any? + ! If the live interval has a definition at 'n', don't spill + 2dup [ uses>> ] dip + '[ [ def-rep>> ] [ n>> _ = ] bi and ] any? [ 2drop t ] [ spill f ] if ; : handle-sync-point ( n -- ) diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 3ab4005359..be5ab9d481 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -28,14 +28,20 @@ ERROR: bad-live-ranges interval ; [ swap first from<< ] 2bi ; +: last-use-rep ( live-interval -- rep/f ) + last-use [ def-rep>> ] [ use-rep>> ] bi or ; inline + : assign-spill ( live-interval -- ) - dup [ vreg>> ] [ last-use rep>> ] bi - assign-spill-slot >>spill-to drop ; + dup last-use-rep dup [ + >>spill-rep + dup [ vreg>> ] [ spill-rep>> ] bi + assign-spill-slot >>spill-to drop + ] [ 2drop ] if ; : spill-before ( before -- before/f ) ! If the interval does not have any usages before the spill location, ! then it is the second child of an interval that was split. We reload - ! the value and let the resolve pass insert a split later. + ! the value and let the resolve pass insert a spill later. dup uses>> empty? [ drop f ] [ { [ ] @@ -46,9 +52,15 @@ ERROR: bad-live-ranges interval ; } cleave ] if ; +: first-use-rep ( live-interval -- rep/f ) + first-use use-rep>> ; inline + : assign-reload ( live-interval -- ) - dup [ vreg>> ] [ first-use rep>> ] bi - assign-spill-slot >>reload-from drop ; + dup first-use-rep dup [ + >>reload-rep + dup [ vreg>> ] [ reload-rep>> ] bi + assign-spill-slot >>reload-from drop + ] [ 2drop ] if ; : spill-after ( after -- after/f ) ! If the interval has no more usages after the spill location, diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index d41a06806b..6346ea41f5 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators fry hints kernel locals +USING: accessors arrays assocs combinators +combinators.short-circuit fry hints kernel locals math sequences sets sorting splitting namespaces compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.live-intervals ; @@ -25,7 +26,9 @@ IN: compiler.cfg.linear-scan.allocation.splitting ] bi ; : split-uses ( uses n -- before after ) - '[ n>> _ <= ] partition ; + [ '[ n>> _ < ] filter ] + [ '[ n>> _ > ] filter ] + 2bi ; ERROR: splitting-too-early ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 1682cf9eb6..1780a1c907 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -93,7 +93,7 @@ SYMBOL: machine-live-outs init-unhandled ; : insert-spill ( live-interval -- ) - [ reg>> ] [ last-use rep>> ] [ spill-to>> ] tri ##spill ; + [ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill ; : handle-spill ( live-interval -- ) dup spill-to>> [ insert-spill ] [ drop ] if ; @@ -113,18 +113,10 @@ SYMBOL: machine-live-outs pending-interval-heap get (expire-old-intervals) ; : insert-reload ( live-interval -- ) - [ reg>> ] [ first-use rep>> ] [ reload-from>> ] tri ##reload ; - -: insert-reload? ( live-interval -- ? ) - ! Don't insert a reload if the register will be written to - ! before being read again. - { - [ reload-from>> ] - [ first-use type>> +use+ eq? ] - } 1&& ; + [ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload ; : handle-reload ( live-interval -- ) - dup insert-reload? [ insert-reload ] [ drop ] if ; + dup reload-from>> [ insert-reload ] [ drop ] if ; : activate-interval ( live-interval -- ) [ add-pending ] [ handle-reload ] bi ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 9e6ec76d2c..11e190d226 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -91,18 +91,20 @@ H{ { reg-class float-regs } { start 0 } { end 2 } - { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } } } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } } } { ranges V{ T{ live-range f 0 2 } } } { spill-to T{ spill-slot f 0 } } + { spill-rep float-rep } } T{ live-interval { vreg 1 } { reg-class float-regs } { start 5 } { end 5 } - { uses V{ T{ vreg-use f float-rep 5 } } } + { uses V{ T{ vreg-use f 5 f float-rep } } } { ranges V{ T{ live-range f 5 5 } } } { reload-from T{ spill-slot f 0 } } + { reload-rep float-rep } } ] [ T{ live-interval @@ -110,29 +112,22 @@ H{ { reg-class float-regs } { start 0 } { end 5 } - { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } } { ranges V{ T{ live-range f 0 5 } } } } 2 split-for-spill ] unit-test [ - T{ live-interval - { vreg 2 } - { reg-class float-regs } - { start 0 } - { end 1 } - { uses V{ T{ vreg-use f float-rep 0 } } } - { ranges V{ T{ live-range f 0 1 } } } - { spill-to T{ spill-slot f 4 } } - } + f T{ live-interval { vreg 2 } { reg-class float-regs } { start 1 } { end 5 } - { uses V{ T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } } + { uses V{ T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } } { ranges V{ T{ live-range f 1 5 } } } { reload-from T{ spill-slot f 4 } } + { reload-rep float-rep } } ] [ T{ live-interval @@ -140,7 +135,7 @@ H{ { reg-class float-regs } { start 0 } { end 5 } - { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } } { ranges V{ T{ live-range f 0 5 } } } } 0 split-for-spill ] unit-test @@ -151,18 +146,20 @@ H{ { reg-class float-regs } { start 0 } { end 1 } - { uses V{ T{ vreg-use f float-rep 0 } } } + { uses V{ T{ vreg-use f 0 float-rep f } } } { ranges V{ T{ live-range f 0 1 } } } { spill-to T{ spill-slot f 8 } } + { spill-rep float-rep } } T{ live-interval { vreg 3 } { reg-class float-regs } { start 20 } { end 30 } - { uses V{ T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } } + { uses V{ T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } } { ranges V{ T{ live-range f 20 30 } } } { reload-from T{ spill-slot f 8 } } + { reload-rep float-rep } } ] [ T{ live-interval @@ -170,11 +167,75 @@ H{ { reg-class float-regs } { start 0 } { end 30 } - { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } } { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } } } 10 split-for-spill ] unit-test +! Don't insert reload if first usage is a def +[ + T{ live-interval + { vreg 4 } + { reg-class float-regs } + { start 0 } + { end 1 } + { uses V{ T{ vreg-use f 0 float-rep f } } } + { ranges V{ T{ live-range f 0 1 } } } + { spill-to T{ spill-slot f 12 } } + { spill-rep float-rep } + } + T{ live-interval + { vreg 4 } + { reg-class float-regs } + { start 20 } + { end 30 } + { uses V{ T{ vreg-use f 20 float-rep f } T{ vreg-use f 30 f float-rep } } } + { ranges V{ T{ live-range f 20 30 } } } + } +] [ + T{ live-interval + { vreg 4 } + { reg-class float-regs } + { start 0 } + { end 30 } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 20 float-rep f } T{ vreg-use f 30 f float-rep } } } + { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } } + } 10 split-for-spill +] unit-test + +! Multiple representations +[ + T{ live-interval + { vreg 5 } + { reg-class float-regs } + { start 0 } + { end 11 } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 10 double-rep float-rep } } } + { ranges V{ T{ live-range f 0 11 } } } + { spill-to T{ spill-slot f 16 } } + { spill-rep double-rep } + } + T{ live-interval + { vreg 5 } + { reg-class float-regs } + { start 20 } + { end 20 } + { uses V{ T{ vreg-use f 20 f double-rep } } } + { ranges V{ T{ live-range f 20 20 } } } + { reload-from T{ spill-slot f 16 } } + { reload-rep double-rep } + } +] [ + T{ live-interval + { vreg 5 } + { reg-class float-regs } + { start 0 } + { end 20 } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 10 double-rep float-rep } T{ vreg-use f 20 f double-rep } } } + { ranges V{ T{ live-range f 0 20 } } } + } 15 split-for-spill +] unit-test + H{ { 1 int-rep } { 2 int-rep } @@ -196,7 +257,7 @@ H{ { reg 1 } { start 1 } { end 15 } - { uses V{ T{ vreg-use f int-rep 1 } T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 7 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 15 } } } + { uses V{ T{ vreg-use f 1 int-rep f } T{ vreg-use f 3 f int-rep } T{ vreg-use f 7 f int-rep } T{ vreg-use f 10 f int-rep } T{ vreg-use f 15 f int-rep } } } } T{ live-interval { vreg 2 } @@ -204,7 +265,7 @@ H{ { reg 2 } { start 3 } { end 8 } - { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 4 } T{ vreg-use f int-rep 8 } } } + { uses V{ T{ vreg-use f 3 int-rep f } T{ vreg-use f 4 f int-rep } T{ vreg-use f 8 f int-rep } } } } T{ live-interval { vreg 3 } @@ -212,7 +273,7 @@ H{ { reg 3 } { start 3 } { end 10 } - { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 10 } } } + { uses V{ T{ vreg-use f 3 int-rep f } T{ vreg-use f 10 f int-rep } } } } } } @@ -223,7 +284,7 @@ H{ { reg-class int-regs } { start 5 } { end 5 } - { uses V{ T{ vreg-use f int-rep 5 } } } + { uses V{ T{ vreg-use f 5 int-rep f } } } } spill-status ] unit-test @@ -243,7 +304,7 @@ H{ { reg 1 } { start 1 } { end 15 } - { uses V{ T{ vreg-use f int-rep 1 } } } + { uses V{ T{ vreg-use f 1 int-rep f } } } } T{ live-interval { vreg 2 } @@ -251,7 +312,7 @@ H{ { reg 2 } { start 3 } { end 8 } - { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 8 } } } + { uses V{ T{ vreg-use f 3 int-rep f } T{ vreg-use f 8 f int-rep } } } } } } @@ -262,7 +323,7 @@ H{ { reg-class int-regs } { start 5 } { end 5 } - { uses V{ T{ vreg-use f int-rep 5 } } } + { uses V{ T{ vreg-use f 5 int-rep f } } } } spill-status ] unit-test @@ -276,7 +337,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 0 } { end 100 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } } { ranges V{ T{ live-range f 0 100 } } } } } @@ -291,7 +352,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 0 } { end 10 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 10 f int-rep } } } { ranges V{ T{ live-range f 0 10 } } } } T{ live-interval @@ -299,7 +360,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 11 } { end 20 } - { uses V{ T{ vreg-use f int-rep 11 } T{ vreg-use f int-rep 20 } } } + { uses V{ T{ vreg-use f 11 int-rep f } T{ vreg-use f 20 f int-rep } } } { ranges V{ T{ live-range f 11 20 } } } } } @@ -314,7 +375,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 0 } { end 100 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } } { ranges V{ T{ live-range f 0 100 } } } } T{ live-interval @@ -322,7 +383,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 30 } { end 60 } - { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 60 } } } + { uses V{ T{ vreg-use f 30 int-rep f } T{ vreg-use f 60 f int-rep } } } { ranges V{ T{ live-range f 30 60 } } } } } @@ -337,7 +398,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 0 } { end 100 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } } { ranges V{ T{ live-range f 0 100 } } } } T{ live-interval @@ -345,7 +406,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 30 } { end 200 } - { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 200 } } } + { uses V{ T{ vreg-use f 30 int-rep f } T{ vreg-use f 200 f int-rep } } } { ranges V{ T{ live-range f 30 200 } } } } } @@ -360,7 +421,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 0 } { end 100 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } } { ranges V{ T{ live-range f 0 100 } } } } T{ live-interval @@ -368,7 +429,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 30 } { end 100 } - { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 100 } } } + { uses V{ T{ vreg-use f 30 int-rep f } T{ vreg-use f 100 f int-rep } } } { ranges V{ T{ live-range f 30 100 } } } } } @@ -392,7 +453,7 @@ H{ { reg-class int-regs } { start 0 } { end 20 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 10 f int-rep } T{ vreg-use f 20 f int-rep } } } { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } } } T{ live-interval @@ -400,7 +461,7 @@ H{ { reg-class int-regs } { start 0 } { end 20 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 10 f int-rep } T{ vreg-use f 20 f int-rep } } } { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } } } T{ live-interval @@ -408,7 +469,7 @@ H{ { reg-class int-regs } { start 4 } { end 8 } - { uses V{ T{ vreg-use f int-rep 6 } } } + { uses V{ T{ vreg-use f 6 int-rep f } } } { ranges V{ T{ live-range f 4 8 } } } } T{ live-interval @@ -416,7 +477,7 @@ H{ { reg-class int-regs } { start 4 } { end 8 } - { uses V{ T{ vreg-use f int-rep 8 } } } + { uses V{ T{ vreg-use f 8 int-rep f } } } { ranges V{ T{ live-range f 4 8 } } } } @@ -426,7 +487,7 @@ H{ { reg-class int-regs } { start 4 } { end 8 } - { uses V{ T{ vreg-use f int-rep 8 } } } + { uses V{ T{ vreg-use f 8 int-rep f } } } { ranges V{ T{ live-range f 4 8 } } } } } @@ -443,7 +504,7 @@ H{ { reg-class int-regs } { start 0 } { end 10 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 6 } T{ vreg-use f int-rep 10 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 6 f int-rep } T{ vreg-use f 10 f int-rep } } } { ranges V{ T{ live-range f 0 10 } } } } @@ -453,7 +514,7 @@ H{ { reg-class int-regs } { start 2 } { end 8 } - { uses V{ T{ vreg-use f int-rep 8 } } } + { uses V{ T{ vreg-use f 8 int-rep f } } } { ranges V{ T{ live-range f 2 8 } } } } } @@ -595,7 +656,7 @@ H{ { start 8 } { end 10 } { ranges V{ T{ live-range f 8 10 } } } - { uses V{ T{ vreg-use f int-rep 8 } T{ vreg-use f int-rep 10 } } } + { uses V{ T{ vreg-use f 8 int-rep f } T{ vreg-use f 10 f int-rep } } } } register-status ] unit-test 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 c4b255d12a..50efbd43e4 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -16,15 +16,13 @@ TUPLE: live-range from to ; C: live-range -SYMBOLS: +def+ +use+ +memory+ ; +TUPLE: vreg-use n def-rep use-rep ; -TUPLE: vreg-use rep n type ; - -C: vreg-use +: ( n -- vreg-use ) vreg-use new swap >>n ; TUPLE: live-interval vreg -reg spill-to reload-from +reg spill-to spill-rep reload-from reload-rep start end ranges uses reg-class ; @@ -32,6 +30,15 @@ reg-class ; : last-use ( live-interval -- use ) uses>> last ; inline +: new-use ( insn# uses -- use ) + [ dup ] dip push ; + +: 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 ; + GENERIC: covers? ( insn# obj -- ? ) M: f covers? 2drop f ; @@ -67,12 +74,6 @@ M: live-interval covers? ( insn# live-interval -- ? ) 2dup extend-range? [ extend-range ] [ add-new-range ] if ; -:: add-use ( rep n type live-interval -- ) - type +memory+ eq? [ - rep n type - live-interval uses>> push - ] unless ; - : ( vreg reg-class -- live-interval ) \ live-interval new V{ } clone >>uses @@ -97,40 +98,30 @@ GENERIC: compute-live-intervals* ( insn -- ) M: insn compute-live-intervals* drop ; -:: record-def ( vreg n type -- ) - vreg rep-of :> rep +:: record-def ( vreg n -- ) vreg live-interval :> live-interval n live-interval shorten-range - rep n type live-interval add-use ; + n live-interval (add-use) vreg rep-of >>def-rep drop ; -:: record-use ( vreg n type -- ) - vreg rep-of :> rep +:: record-use ( vreg n -- ) vreg live-interval :> live-interval from get n live-interval add-range - rep n type live-interval add-use ; + n live-interval (add-use) vreg rep-of >>use-rep drop ; :: record-temp ( vreg n -- ) - vreg rep-of :> rep vreg live-interval :> live-interval n n live-interval add-range - rep n +def+ live-interval add-use ; + n live-interval (add-use) vreg rep-of >>def-rep drop ; -M:: vreg-insn compute-live-intervals* ( insn -- ) - insn insn#>> :> n - - insn defs-vreg [ n +def+ record-def ] when* - insn uses-vregs [ n +use+ record-use ] each - insn temp-vregs [ n record-temp ] each ; - -M:: clobber-insn compute-live-intervals* ( insn -- ) - insn insn#>> :> n - - insn defs-vreg [ n +use+ record-def ] when* - insn uses-vregs [ n +memory+ record-use ] each - insn temp-vregs [ n record-temp ] each ; +M: vreg-insn compute-live-intervals* ( insn -- ) + dup insn#>> + [ [ defs-vreg ] dip '[ _ record-def ] when* ] + [ [ uses-vregs ] dip '[ _ record-use ] each ] + [ [ temp-vregs ] dip '[ _ record-temp ] each ] + 2tri ; : handle-live-out ( bb -- ) live-out dup assoc-empty? [ drop ] [ From f988dad79cbbc62741f16dfcd2702581e7974a8c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 May 2010 18:26:00 -0400 Subject: [PATCH 02/14] compiler.cfg: add ##load-float instruction for single precision floating point constants --- .../cfg/instructions/instructions.factor | 4 ++++ .../cfg/representations/peephole/peephole.factor | 16 ++++++++++++++-- basis/compiler/codegen/codegen.factor | 1 + basis/compiler/codegen/fixup/fixup.factor | 15 ++------------- basis/cpu/architecture/architecture.factor | 5 +++-- basis/cpu/x86/32/32.factor | 9 ++++++--- basis/cpu/x86/64/64.factor | 9 ++++++--- 7 files changed, 36 insertions(+), 23 deletions(-) diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index d4e019d8dd..91d01adb83 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -34,6 +34,10 @@ INSN: ##load-tagged def: dst/tagged-rep literal: val ; +INSN: ##load-float +def: dst/float-rep +literal: val ; + INSN: ##load-double def: dst/double-rep literal: val ; diff --git a/basis/compiler/cfg/representations/peephole/peephole.factor b/basis/compiler/cfg/representations/peephole/peephole.factor index 22366f5714..c3e7fa06a5 100644 --- a/basis/compiler/cfg/representations/peephole/peephole.factor +++ b/basis/compiler/cfg/representations/peephole/peephole.factor @@ -42,8 +42,16 @@ M: ##load-integer optimize-insn [ call-next-method ] } cond ; -! When a float is unboxed, we replace the ##load-reference with a ##load-double -! if the architecture supports it +! When a constant float is unboxed, we replace the +! ##load-reference with a ##load-float or ##load-double if the +! architecture supports it +: convert-to-load-float? ( insn -- ? ) + { + [ drop fused-unboxing? ] + [ dst>> rep-of float-rep? ] + [ obj>> float? ] + } 1&& ; + : convert-to-load-double? ( insn -- ? ) { [ drop fused-unboxing? ] @@ -74,6 +82,10 @@ M: ##load-integer optimize-insn M: ##load-reference optimize-insn { + { + [ dup convert-to-load-float? ] + [ [ dst>> ] [ obj>> ] bi ##load-float here ] + } { [ dup convert-to-load-double? ] [ [ dst>> ] [ obj>> ] bi ##load-double here ] diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 604fb2570e..d5e4987ee0 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -122,6 +122,7 @@ SYNTAX: CODEGEN: CODEGEN: ##load-integer %load-immediate CODEGEN: ##load-tagged %load-immediate CODEGEN: ##load-reference %load-reference +CODEGEN: ##load-float %load-float CODEGEN: ##load-double %load-double CODEGEN: ##load-vector %load-vector CODEGEN: ##peek %peek diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index 427c7ff94c..4bae4f96da 100644 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -12,10 +12,6 @@ IN: compiler.codegen.fixup [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri swap set-alien-unsigned-4 ; -: push-double ( value vector -- ) - [ length ] [ B{ 0 0 0 0 0 0 0 0 } swap push-all ] [ underlying>> ] tri - swap set-alien-double ; - ! Owner SYMBOL: compiling-word @@ -136,15 +132,8 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ; : align-code ( n -- ) alignment (align-code) ; -GENERIC# emit-data 1 ( obj label -- ) - -M: float emit-data - 8 align-code - resolve-label - building get push-double ; - -M: byte-array emit-data - 16 align-code +: emit-data ( obj label -- ) + over length align-code resolve-label building get push-all ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 8f69b24729..19a9b02785 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -224,6 +224,7 @@ HOOK: complex-addressing? cpu ( -- ? ) HOOK: %load-immediate cpu ( reg val -- ) HOOK: %load-reference cpu ( reg obj -- ) +HOOK: %load-float cpu ( reg val -- ) HOOK: %load-double cpu ( reg val -- ) HOOK: %load-vector cpu ( reg val rep -- ) @@ -504,8 +505,8 @@ M: reg-class param-reg param-regs nth ; M: stack-params param-reg 2drop ; -! Does this architecture support %load-double, %load-vector and -! objects in %compare-imm? +! Does this architecture support %load-float, %load-double, +! and %load-vector? HOOK: fused-unboxing? cpu ( -- ? ) ! Can this value be an immediate operand for %add-imm, %sub-imm, diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index d7c95ff15e..8618affaed 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -27,12 +27,15 @@ M: x86.32 temp-reg ECX ; M: x86.32 immediate-comparand? ( obj -- ? ) drop t ; -M: x86.32 %load-double ( dst val -- ) - [ 0 [] MOVSD ] dip rc-absolute rel-binary-literal ; - M:: x86.32 %load-vector ( dst val rep -- ) dst 0 [] rep copy-memory* val rc-absolute rel-binary-literal ; +M: x86.32 %load-float ( dst val -- ) + float-rep %load-vector ; + +M: x86.32 %load-double ( dst val -- ) + double-rep %load-vector ; + M: x86.32 %mov-vm-ptr ( reg -- ) 0 MOV 0 rc-absolute-cell rel-vm ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 928daa741e..5baeed81b8 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -46,12 +46,15 @@ M: x86.64 %mov-vm-ptr ( reg -- ) M: x86.64 %vm-field ( dst offset -- ) [ vm-reg ] dip [+] MOV ; -M: x86.64 %load-double ( dst val -- ) - [ 0 [RIP+] MOVSD ] dip rc-relative rel-binary-literal ; - M:: x86.64 %load-vector ( dst val rep -- ) dst 0 [RIP+] rep copy-memory* val rc-relative rel-binary-literal ; +M: x86.64 %load-float ( dst val -- ) + float-rep %load-vector ; + +M: x86.64 %load-double ( dst val -- ) + double-rep %load-vector ; + M: x86.64 %set-vm-field ( src offset -- ) [ vm-reg ] dip [+] swap MOV ; From fa99cc8f0e0b9ecc79b7cb0071f1328e2cc5268f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 7 May 2010 18:26:16 -0400 Subject: [PATCH 03/14] ui.backend.windows: faster wheel mouse scroll rate --- basis/ui/backend/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 46bea3e256..8dae849a1f 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -476,7 +476,7 @@ SYMBOL: nc-buttons swap [ push ] [ remove! drop ] if ; : mouse-scroll ( wParam -- array ) - >lo-hi [ -120 /f ] map ; + >lo-hi [ -80 /f ] map ; : mouse-event>gesture ( uMsg -- button ) key-modifiers swap message>button From c211c3e84ecae712886b30d38293c80dfa44cde7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 9 May 2010 21:36:52 -0400 Subject: [PATCH 04/14] FFI rewrite part 1: split up ##alien-invoke and friends into smaller instructions --- basis/alien/arrays/arrays.factor | 40 +-- basis/alien/c-types/c-types-docs.factor | 15 - basis/alien/c-types/c-types.factor | 39 +-- basis/bootstrap/compiler/compiler.factor | 2 + basis/bootstrap/help/help.factor | 4 +- basis/calendar/calendar-docs.factor | 2 +- basis/classes/struct/struct.factor | 12 +- .../cfg/block-joining/block-joining.factor | 4 +- .../branch-splitting/branch-splitting.factor | 21 +- .../build-stack-frame.factor | 8 +- basis/compiler/cfg/builder/alien/alien.factor | 293 ++++++++++++++++++ .../compiler/cfg/builder/blocks/blocks.factor | 8 +- basis/compiler/cfg/builder/builder.factor | 58 +--- basis/compiler/cfg/cfg.factor | 1 + basis/compiler/cfg/checker/checker.factor | 41 +-- .../dataflow-analysis.factor | 24 +- .../cfg/instructions/instructions.factor | 77 ++++- .../cfg/intrinsics/fixnum/fixnum.factor | 6 +- .../representations/rewrite/rewrite.factor | 13 +- basis/compiler/cfg/rpo/rpo.factor | 6 +- .../compiler/cfg/scheduling/scheduling.factor | 14 +- .../cfg/stacks/finalize/finalize.factor | 2 +- basis/compiler/cfg/utilities/utilities.factor | 6 - basis/compiler/codegen/alien/alien.factor | 207 ------------- basis/compiler/codegen/alien/authors.txt | 1 - basis/compiler/codegen/codegen.factor | 31 ++ basis/compiler/compiler.factor | 4 +- basis/compiler/tests/alien.factor | 5 - basis/compiler/tests/linkage-errors.factor | 21 ++ basis/cpu/architecture/architecture.factor | 4 +- basis/cpu/ppc/ppc.factor | 11 +- basis/cpu/x86/32/32.factor | 11 +- basis/cpu/x86/64/64.factor | 10 +- 33 files changed, 506 insertions(+), 495 deletions(-) create mode 100644 basis/compiler/cfg/builder/alien/alien.factor delete mode 100644 basis/compiler/codegen/alien/alien.factor delete mode 100644 basis/compiler/codegen/alien/authors.txt create mode 100644 basis/compiler/tests/linkage-errors.factor diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index dc9d3e0d05..bf87cfd9f1 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -22,17 +22,11 @@ M: array c-type-align first c-type-align ; M: array c-type-align-first first c-type-align-first ; -M: array unbox-parameter drop void* unbox-parameter ; - -M: array unbox-return drop void* unbox-return ; - -M: array box-parameter drop void* box-parameter ; - -M: array box-return drop void* box-return ; +M: array base-type drop void* base-type ; M: array stack-size drop void* stack-size ; -M: array flatten-c-type drop { int-rep } ; +M: array flatten-c-type drop void* flatten-c-type ; PREDICATE: string-type < pair first2 [ c-string = ] [ word? ] bi* and ; @@ -43,35 +37,19 @@ M: string-type c-type-class drop object ; M: string-type c-type-boxed-class drop object ; -M: string-type heap-size - drop void* heap-size ; +M: string-type heap-size drop void* heap-size ; -M: string-type c-type-align - drop void* c-type-align ; +M: string-type c-type-align drop void* c-type-align ; -M: string-type c-type-align-first - drop void* c-type-align-first ; +M: string-type c-type-align-first drop void* c-type-align-first ; -M: string-type unbox-parameter - drop void* unbox-parameter ; +M: string-type base-type drop void* base-type ; -M: string-type unbox-return - drop void* unbox-return ; +M: string-type stack-size drop void* stack-size ; -M: string-type box-parameter - drop void* box-parameter ; +M: string-type c-type-rep drop int-rep ; -M: string-type box-return - drop void* box-return ; - -M: string-type stack-size - drop void* stack-size ; - -M: string-type c-type-rep - drop int-rep ; - -M: string-type flatten-c-type - drop { int-rep } ; +M: string-type flatten-c-type drop void* flatten-c-type ; M: string-type c-type-boxer-quot second dup binary = diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index 9592fb1812..bf26dd5f88 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -43,21 +43,6 @@ HELP: c-setter { $description "Outputs a quotation which writes values of this C type to a C structure." } { $errors "Throws an error if the type does not exist." } ; -HELP: box-parameter -{ $values { "n" math:integer } { "c-type" "a C type" } } -{ $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." } -{ $notes "This is an internal word used by the compiler when compiling callbacks." } ; - -HELP: box-return -{ $values { "c-type" "a C type" } } -{ $description "Generates code for converting a C value stored in return registers into a Factor object to be pushed on the data stack." } -{ $notes "This is an internal word used by the compiler when compiling alien calls." } ; - -HELP: unbox-return -{ $values { "c-type" "a C type" } } -{ $description "Generates code for converting a Factor value on the data stack into a C value to be stored in the return registers." } -{ $notes "This is an internal word used by the compiler when compiling callbacks." } ; - HELP: define-deref { $values { "c-type" "a C type" } } { $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." } diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 98b15b7af8..d916ce9dec 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -111,27 +111,11 @@ GENERIC: c-type-align-first ( name -- n ) M: abstract-c-type c-type-align-first align-first>> ; -: c-type-box ( n c-type -- ) - [ rep>> ] [ boxer>> ] bi %box ; +GENERIC: base-type ( c-type -- c-type ) -: c-type-unbox ( n c-type -- ) - [ rep>> ] [ unboxer>> ] bi %unbox ; +M: c-type-name base-type c-type ; -GENERIC: box-parameter ( n c-type -- ) - -M: c-type box-parameter c-type-box ; - -GENERIC: box-return ( c-type -- ) - -M: c-type box-return f swap c-type-box ; - -GENERIC: unbox-parameter ( n c-type -- ) - -M: c-type unbox-parameter c-type-unbox ; - -GENERIC: unbox-return ( c-type -- ) - -M: c-type unbox-return f swap c-type-unbox ; +M: c-type base-type ; : little-endian? ( -- ? ) 1 *char 1 = ; foldable @@ -179,10 +163,7 @@ PROTOCOL: c-type-protocol c-type-setter c-type-align c-type-align-first - box-parameter - box-return - unbox-parameter - unbox-return + base-type heap-size stack-size flatten-c-type ; @@ -204,18 +185,6 @@ TUPLE: long-long-type < c-type ; : ( -- c-type ) long-long-type new ; -M: long-long-type unbox-parameter ( n c-type -- ) - unboxer>> %unbox-long-long ; - -M: long-long-type unbox-return ( c-type -- ) - f swap unbox-parameter ; - -M: long-long-type box-parameter ( n c-type -- ) - boxer>> %box-long-long ; - -M: long-long-type box-return ( c-type -- ) - f swap box-parameter ; - M: long-long-type flatten-c-type int-rep (flatten-c-type) ; diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 56109e2de6..9c753ce08f 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -117,6 +117,8 @@ gc " done" print flush + "alien.syntax" require + "alien.complex" require "io.streams.byte-array.fast" require ] unless diff --git a/basis/bootstrap/help/help.factor b/basis/bootstrap/help/help.factor index 553b91a6ae..f77829ae86 100644 --- a/basis/bootstrap/help/help.factor +++ b/basis/bootstrap/help/help.factor @@ -6,12 +6,10 @@ IN: bootstrap.help : load-help ( -- ) "help.lint" require "help.vocabs" require - "alien.syntax" require - "compiler" require t load-help? set-global - [ vocab ] load-vocab-hook [ + [ dup vocab [ ] [ no-vocab ] ?if ] load-vocab-hook [ dictionary get values [ docs-loaded?>> not ] filter [ load-docs ] each diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index a5a31ebd65..e76aace464 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -8,7 +8,7 @@ HELP: duration { $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ; HELP: timestamp -{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two duarionts with the " { $link <=> } " word." } ; +{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two durations with the " { $link <=> } " word." } ; { timestamp duration } related-words diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 74b4882ffb..d33f6fa35d 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -169,20 +169,10 @@ M: struct-c-type c-type ; : if-value-struct ( ctype true false -- ) [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline -M: struct-c-type unbox-parameter - [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ; - -M: struct-c-type box-parameter - [ %box-large-struct ] [ box-parameter ] if-value-struct ; - : if-small-struct ( c-type true false -- ? ) [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline -M: struct-c-type unbox-return - [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ; - -M: struct-c-type box-return - [ %box-small-struct ] [ %box-large-struct ] if-small-struct ; +M: struct-c-type base-type ; M: struct-c-type stack-size [ heap-size cell align ] [ stack-size ] if-value-struct ; diff --git a/basis/compiler/cfg/block-joining/block-joining.factor b/basis/compiler/cfg/block-joining/block-joining.factor index 3f98c3711f..54cff306ed 100644 --- a/basis/compiler/cfg/block-joining/block-joining.factor +++ b/basis/compiler/cfg/block-joining/block-joining.factor @@ -10,9 +10,9 @@ IN: compiler.cfg.block-joining ! before stack analysis. : join-block? ( bb -- ? ) { - [ kill-block? not ] + [ kill-block?>> not ] [ predecessors>> length 1 = ] - [ predecessor kill-block? not ] + [ predecessor kill-block?>> not ] [ predecessor successors>> length 1 = ] [ [ predecessor ] keep back-edge? not ] } 1&& ; diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor index 1daabf6f0e..b6cde4d435 100644 --- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor +++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2009 Doug Coleman, Slava Pestov. +! Copyright (C) 2009, 2010 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators.short-circuit kernel math math.order -sequences assocs namespaces vectors fry arrays splitting -compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.predecessors -compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ; +USING: accessors combinators combinators.short-circuit kernel +math math.order sequences assocs namespaces vectors fry arrays +splitting compiler.cfg.def-use compiler.cfg compiler.cfg.rpo +compiler.cfg.predecessors compiler.cfg.renaming +compiler.cfg.instructions compiler.cfg.utilities ; IN: compiler.cfg.branch-splitting : clone-instructions ( insns -- insns' ) @@ -15,10 +16,12 @@ IN: compiler.cfg.branch-splitting ! 'back-edge?' work. swap - [ instructions>> clone-instructions >>instructions ] - [ successors>> clone >>successors ] - [ number>> >>number ] - tri ; + { + [ instructions>> clone-instructions >>instructions ] + [ successors>> clone >>successors ] + [ kill-block?>> >>kill-block? ] + [ number>> >>number ] + } cleave ; : new-blocks ( bb -- copies ) dup predecessors>> [ diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index 8f98ab7add..747e0f54cf 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -14,13 +14,7 @@ GENERIC: compute-stack-frame* ( insn -- ) frame-required? on stack-frame [ max-stack-frame ] change ; -UNION: stack-frame-insn - ##alien-invoke - ##alien-indirect - ##alien-assembly - ##alien-callback ; - -M: stack-frame-insn compute-stack-frame* +M: ##stack-frame compute-stack-frame* stack-frame>> request-stack-frame ; M: ##call compute-stack-frame* drop frame-required? on ; diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor new file mode 100644 index 0000000000..8bdf4ccb46 --- /dev/null +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -0,0 +1,293 @@ +! Copyright (C) 2008, 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays layouts math math.order math.parser +combinators fry sequences locals alien alien.private +alien.strings alien.c-types alien.libraries classes.struct +namespaces kernel strings libc quotations cpu.architecture +compiler.alien compiler.utilities compiler.tree compiler.cfg +compiler.cfg.builder compiler.cfg.builder.blocks +compiler.cfg.instructions compiler.cfg.stack-frame +compiler.cfg.stacks ; +FROM: compiler.errors => no-such-symbol no-such-library ; +IN: compiler.cfg.builder.alien + +GENERIC: next-fastcall-param ( rep -- ) + +: ?dummy-stack-params ( rep -- ) + dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ; + +: ?dummy-int-params ( rep -- ) + dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ; + +: ?dummy-fp-params ( rep -- ) + drop dummy-fp-params? [ float-regs inc ] when ; + +M: int-rep next-fastcall-param + int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ; + +M: float-rep next-fastcall-param + float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ; + +M: double-rep next-fastcall-param + float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ; + +GENERIC# reg-class-full? 1 ( reg-class abi -- ? ) + +M: stack-params reg-class-full? 2drop t ; + +M: reg-class reg-class-full? + [ get ] swap '[ _ param-regs length ] bi >= ; + +: alloc-stack-param ( rep -- n reg-class rep ) + stack-params get + [ rep-size cell align stack-params +@ ] dip + stack-params dup ; + +: alloc-fastcall-param ( rep -- n reg-class rep ) + [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ; + +:: alloc-parameter ( rep abi -- reg rep ) + rep dup reg-class-of abi reg-class-full? + [ alloc-stack-param ] [ alloc-fastcall-param ] if + [ abi param-reg ] dip ; + +: reset-fastcall-counts ( -- ) + { int-regs float-regs stack-params } [ 0 swap set ] each ; + +: with-param-regs ( quot -- ) + #! In quot you can call alloc-parameter + [ reset-fastcall-counts call ] with-scope ; inline + +:: move-parameters ( params word -- ) + #! Moves values from C stack to registers (if word is + #! ##load-param-reg) and registers to C stack (if word is + #! ##save-param-reg). + 0 params alien-parameters flatten-c-types [ + [ params abi>> alloc-parameter word execute( offset reg rep -- ) ] + [ rep-size cell align + ] + 2bi + ] each drop ; inline + +: parameter-offsets ( types -- offsets ) + 0 [ stack-size + ] accumulate nip ; + +: each-parameter ( parameters quot -- ) + [ [ parameter-offsets ] keep ] dip 2each ; inline + +: reverse-each-parameter ( parameters quot -- ) + [ [ parameter-offsets ] keep ] dip 2reverse-each ; inline + +: prepare-unbox-parameters ( parameters -- offsets types indices ) + [ parameter-offsets ] [ ] [ length iota ] tri ; + +GENERIC: unbox-parameter ( n c-type -- ) + +M: c-type unbox-parameter + [ rep>> ] [ unboxer>> ] bi ##unbox ; + +M: long-long-type unbox-parameter + unboxer>> ##unbox-long-long ; + +M: struct-c-type unbox-parameter + [ ##unbox-large-struct ] [ base-type unbox-parameter ] if-value-struct ; + +: unbox-parameters ( offset node -- ) + parameters>> swap + '[ + prepare-unbox-parameters + [ ##pop-stack [ _ + ] dip base-type unbox-parameter ] 3each + ] + [ length neg ##inc-d ] + bi ; + +: prepare-box-struct ( node -- offset ) + #! Return offset on C stack where to store unboxed + #! parameters. If the C function is returning a structure, + #! the first parameter is an implicit target area pointer, + #! so we need to use a different offset. + return>> large-struct? + [ ##prepare-box-struct cell ] [ 0 ] if ; + +: objects>registers ( params -- ) + #! Generate code for unboxing a list of C types, then + #! generate code for moving these parameters to registers on + #! architectures where parameters are passed in registers. + [ + [ prepare-box-struct ] keep + [ unbox-parameters ] keep + \ ##load-param-reg move-parameters + ] with-param-regs ; + +GENERIC: box-return ( c-type -- ) + +M: c-type box-return + [ f ] dip [ rep>> ] [ boxer>> ] bi ##box ; + +M: long-long-type box-return + [ f ] dip boxer>> ##box-long-long ; + +M: struct-c-type box-return + [ ##box-small-struct ] [ ##box-large-struct ] if-small-struct ; + +: box-return* ( node -- ) + return>> [ ] [ base-type box-return ##push-stack ] if-void ; + +GENERIC# dlsym-valid? 1 ( symbols dll -- ? ) + +M: string dlsym-valid? dlsym ; + +M: array dlsym-valid? '[ _ dlsym ] any? ; + +: check-dlsym ( symbols dll -- ) + dup dll-valid? [ + dupd dlsym-valid? + [ drop ] [ cfg get word>> no-such-symbol ] if + ] [ dll-path cfg get word>> no-such-library drop ] if ; + +: decorated-symbol ( params -- symbols ) + [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi + { + [ drop ] + [ "@" glue ] + [ "@" glue "_" prepend ] + [ "@" glue "@" prepend ] + } 2cleave + 4array ; + +: alien-invoke-dlsym ( params -- symbols dll ) + [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ] + [ library>> load-library ] + bi 2dup check-dlsym ; + +: return-size ( ctype -- n ) + #! Amount of space we reserve for a return value. + { + { [ dup c-struct? not ] [ drop 0 ] } + { [ dup large-struct? not ] [ drop 2 cells ] } + [ heap-size ] + } cond ; + +: ( params -- stack-frame ) + stack-frame new + swap + [ return>> return-size >>return ] + [ alien-parameters [ stack-size ] map-sum >>params ] bi + t >>calls-vm? ; + +: alien-node-height ( params -- ) + [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; + +: emit-alien-node ( node quot -- ) + '[ + make-kill-block + params>> + [ ##stack-frame ] + _ + [ alien-node-height ] + tri + ] emit-trivial-block ; inline + +M: #alien-invoke emit-node + [ + ! Unbox parameters + dup objects>registers + ! Call function + dup alien-invoke-dlsym ##alien-invoke + ! Box return value + dup ##cleanup + box-return* + ] emit-alien-node ; + +M: #alien-indirect emit-node + [ + ! Save alien at top of stack to temporary storage + ##prepare-alien-indirect + ! Unbox parameters + dup objects>registers + ! Call alien in temporary storage + ##alien-indirect + ! Box return value + dup ##cleanup + box-return* + ] emit-alien-node ; + +M: #alien-assembly emit-node + [ + ! Unbox parameters + dup objects>registers + ! Generate assembly + dup quot>> ##alien-assembly + ! Box return value + box-return* + ] emit-alien-node ; + +GENERIC: box-parameter ( n c-type -- ) + +M: c-type box-parameter + [ rep>> ] [ boxer>> ] bi ##box ; + +M: long-long-type box-parameter + boxer>> ##box-long-long ; + +M: struct-c-type box-parameter + [ ##box-large-struct ] [ base-type box-parameter ] if-value-struct ; + +: box-parameters ( params -- ) + alien-parameters + [ base-type box-parameter ##push-context-stack ] each-parameter ; + +: registers>objects ( node -- ) + ! Generate code for boxing input parameters in a callback. + [ + dup \ ##save-param-reg move-parameters + ##begin-callback + box-parameters + ] with-param-regs ; + +: callback-return-quot ( ctype -- quot ) + return>> { + { [ dup void? ] [ drop [ ] ] } + { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] } + [ c-type c-type-unboxer-quot ] + } cond ; + +: callback-prep-quot ( params -- quot ) + parameters>> [ c-type c-type-boxer-quot ] map spread>quot ; + +: wrap-callback-quot ( params -- quot ) + [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append + yield-hook get + '[ _ _ do-callback ] + >quotation ; + +GENERIC: unbox-return ( c-type -- ) + +M: c-type unbox-return + [ f ] dip [ rep>> ] [ unboxer>> ] bi ##unbox ; + +M: long-long-type unbox-return + [ f ] dip unboxer>> ##unbox-long-long ; + +M: struct-c-type unbox-return + [ ##unbox-small-struct ] [ ##unbox-large-struct ] if-small-struct ; + +M: #alien-callback emit-node + dup params>> xt>> dup + [ + ##prologue + [ + [ registers>objects ] + [ wrap-callback-quot ##alien-callback ] + [ + alien-return [ ##end-callback ] [ + ##pop-context-stack + ##to-nv + ##end-callback + ##from-nv + base-type unbox-return + ] if-void + ] tri + ] emit-alien-node + ##epilogue + ##return + ] with-cfg-builder ; diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor index 8e96255bdd..293c3fe09b 100644 --- a/basis/compiler/cfg/builder/blocks/blocks.factor +++ b/basis/compiler/cfg/builder/blocks/blocks.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays fry kernel make math namespaces sequences compiler.cfg compiler.cfg.instructions compiler.cfg.stacks @@ -31,6 +31,9 @@ IN: compiler.cfg.builder.blocks call ##branch begin-basic-block ; inline +: make-kill-block ( -- ) + basic-block get t >>kill-block? drop ; + : call-height ( #call -- n ) [ out-d>> length ] [ in-d>> length ] bi - ; @@ -38,6 +41,7 @@ IN: compiler.cfg.builder.blocks [ [ word>> ##call ] [ call-height adjust-d ] bi + make-kill-block ] emit-trivial-block ; : begin-branch ( -- ) clone-current-height (begin-basic-block) ; @@ -66,7 +70,7 @@ IN: compiler.cfg.builder.blocks [ ] find nip [ second current-height set ] [ end-basic-block ] if* ; : emit-conditional ( branches -- ) - ! branchies is a sequence of pairs as above + ! branches is a sequence of pairs as above end-basic-block [ merge-heights begin-basic-block ] [ set-successors ] diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index c0ba1144a5..059a7f2215 100644 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -57,6 +57,7 @@ GENERIC: emit-node ( node -- ) [ basic-block get [ emit-node ] [ drop ] if ] each ; : begin-word ( -- ) + make-kill-block ##prologue ##branch begin-basic-block ; @@ -82,8 +83,12 @@ GENERIC: emit-node ( node -- ) : emit-call ( word height -- ) over loops get key? [ drop loops get at emit-loop-call ] - [ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ] - if ; + [ + [ + [ ##call ] [ adjust-d ] bi* + make-kill-block + ] emit-trivial-block + ] if ; ! #recursive : recursive-height ( #recursive -- n ) @@ -195,7 +200,11 @@ M: #shuffle emit-node ! #return : emit-return ( -- ) - ##branch begin-basic-block ##epilogue ##return ; + ##branch + begin-basic-block + make-kill-block + ##epilogue + ##return ; M: #return emit-node drop emit-return ; @@ -205,49 +214,6 @@ M: #return-recursive emit-node ! #terminate M: #terminate emit-node drop ##no-tco end-basic-block ; -! FFI -: return-size ( ctype -- n ) - #! Amount of space we reserve for a return value. - { - { [ dup c-struct? not ] [ drop 0 ] } - { [ dup large-struct? not ] [ drop 2 cells ] } - [ heap-size ] - } cond ; - -: ( params -- stack-frame ) - stack-frame new - swap - [ return>> return-size >>return ] - [ alien-parameters [ stack-size ] map-sum >>params ] bi - t >>calls-vm? ; - -: alien-node-height ( params -- ) - [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; - -: emit-alien-node ( node quot -- ) - [ - [ params>> dup dup ] dip call - alien-node-height - ] emit-trivial-block ; inline - -M: #alien-invoke emit-node - [ ##alien-invoke ] emit-alien-node ; - -M: #alien-indirect emit-node - [ ##alien-indirect ] emit-alien-node ; - -M: #alien-assembly emit-node - [ ##alien-assembly ] emit-alien-node ; - -M: #alien-callback emit-node - dup params>> xt>> dup - [ - ##prologue - [ ##alien-callback ] emit-alien-node - ##epilogue - ##return - ] with-cfg-builder ; - ! No-op nodes M: #introduce emit-node drop ; diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index c49d638509..5f5283bcd5 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/basis/compiler/cfg/cfg.factor @@ -9,6 +9,7 @@ number { instructions vector } { successors vector } { predecessors vector } +{ kill-block? boolean } { unlikely? boolean } ; : ( -- bb ) diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index d7a48a1511..f4fee8b7b2 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -7,50 +7,11 @@ compiler.cfg.utilities compiler.cfg.finalization compiler.utilities ; IN: compiler.cfg.checker -! Check invariants - -ERROR: bad-kill-block bb ; - -: check-kill-block ( bb -- ) - dup instructions>> dup penultimate ##epilogue? [ - { - [ length 2 = ] - [ last { [ ##return? ] [ ##jump? ] } 1|| ] - } 1&& - ] [ last ##branch? ] if - [ drop ] [ bad-kill-block ] if ; - -ERROR: last-insn-not-a-jump bb ; - -: check-last-instruction ( bb -- ) - dup instructions>> last { - [ ##branch? ] - [ ##dispatch? ] - [ conditional-branch-insn? ] - [ ##no-tco? ] - } 1|| [ drop ] [ last-insn-not-a-jump ] if ; - -ERROR: bad-kill-insn bb ; - -: check-kill-instructions ( bb -- ) - dup instructions>> [ kill-vreg-insn? ] any? - [ bad-kill-insn ] [ drop ] if ; - -: check-normal-block ( bb -- ) - [ check-last-instruction ] - [ check-kill-instructions ] - bi ; - ERROR: bad-successors ; : check-successors ( bb -- ) dup successors>> [ predecessors>> member-eq? ] with all? [ bad-successors ] unless ; -: check-basic-block ( bb -- ) - [ dup kill-block? [ check-kill-block ] [ check-normal-block ] if ] - [ check-successors ] - bi ; - : check-cfg ( cfg -- ) - [ check-basic-block ] each-basic-block ; + [ check-successors ] each-basic-block ; diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor index dde44fd15d..553b843833 100644 --- a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -18,27 +18,21 @@ MIXIN: dataflow-analysis : ( cfg dfa -- queue ) block-order [ push-all-front ] keep ; -GENERIC# compute-in-set 2 ( bb out-sets dfa -- set ) - -M: kill-block compute-in-set 3drop f ; - -M:: basic-block compute-in-set ( bb out-sets dfa -- set ) +:: compute-in-set ( bb out-sets dfa -- set ) ! Only consider initialized sets. - bb dfa predecessors - [ out-sets key? ] filter - [ out-sets at ] map - bb dfa join-sets ; + bb kill-block?>> [ f ] [ + bb dfa predecessors + [ out-sets key? ] filter + [ out-sets at ] map + bb dfa join-sets + ] if ; :: update-in-set ( bb in-sets out-sets dfa -- ? ) bb out-sets dfa compute-in-set bb in-sets maybe-set-at ; inline -GENERIC# compute-out-set 2 ( bb out-sets dfa -- set ) - -M: kill-block compute-out-set 3drop f ; - -M:: basic-block compute-out-set ( bb in-sets dfa -- set ) - bb in-sets at bb dfa transfer-set ; +:: compute-out-set ( bb in-sets dfa -- set ) + bb kill-block?>> [ f ] [ bb in-sets at bb dfa transfer-set ] if ; :: update-out-set ( bb in-sets out-sets dfa -- ? ) bb in-sets dfa compute-out-set diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 91d01adb83..87055eb550 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -609,17 +609,73 @@ use: src/tagged-rep literal: offset ; ! FFI -INSN: ##alien-invoke -literal: params stack-frame ; +INSN: ##stack-frame +literal: stack-frame ; -INSN: ##alien-indirect -literal: params stack-frame ; +INSN: ##box +literal: n rep boxer ; + +INSN: ##box-long-long +literal: n boxer ; + +INSN: ##box-small-struct +literal: c-type ; + +INSN: ##box-large-struct +literal: n c-type ; + +INSN: ##unbox +literal: n rep unboxer ; + +INSN: ##unbox-long-long +literal: n unboxer ; + +INSN: ##unbox-large-struct +literal: n c-type ; + +INSN: ##unbox-small-struct +literal: c-type ; + +INSN: ##pop-stack +literal: n ; + +INSN: ##pop-context-stack ; + +INSN: ##prepare-box-struct ; + +INSN: ##load-param-reg +literal: offset reg rep ; + +INSN: ##push-stack ; + +INSN: ##alien-invoke +literal: symbols dll ; + +INSN: ##cleanup +literal: params ; + +INSN: ##prepare-alien-indirect ; + +INSN: ##alien-indirect ; INSN: ##alien-assembly -literal: params stack-frame ; +literal: quot ; + +INSN: ##push-context-stack ; + +INSN: ##save-param-reg +literal: offset reg rep ; + +INSN: ##begin-callback ; INSN: ##alien-callback -literal: params stack-frame ; +literal: quot ; + +INSN: ##end-callback ; + +INSN: ##to-nv ; + +INSN: ##from-nv ; ! Control flow INSN: ##phi @@ -758,15 +814,6 @@ UNION: clobber-insn ##unary-float-function ##binary-float-function ; -! Instructions that kill all live vregs -UNION: kill-vreg-insn -##call -##prologue -##epilogue -##alien-invoke -##alien-indirect -##alien-callback ; - ! Instructions that have complex expansions and require that the ! output registers are not equal to any of the input registers UNION: def-is-use-insn diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index b9cfac3b92..6b87ca8fd6 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -51,7 +51,11 @@ IN: compiler.cfg.intrinsics.fixnum [ ds-drop ds-drop ds-push ] with-branch ; : emit-overflow-case ( word -- final-bb ) - [ ##call -1 adjust-d ] with-branch ; + [ + ##call + -1 adjust-d + make-kill-block + ] with-branch ; : emit-fixnum-overflow-op ( quot word -- ) ! Inputs to the final instruction need to be copied because diff --git a/basis/compiler/cfg/representations/rewrite/rewrite.factor b/basis/compiler/cfg/representations/rewrite/rewrite.factor index b0da0d190a..06444c66f8 100644 --- a/basis/compiler/cfg/representations/rewrite/rewrite.factor +++ b/basis/compiler/cfg/representations/rewrite/rewrite.factor @@ -90,15 +90,14 @@ M: ##copy conversions-for-insn , ; M: insn conversions-for-insn , ; : conversions-for-block ( bb -- ) - dup kill-block? [ drop ] [ + [ [ - [ - H{ } clone alternatives set - [ conversions-for-insn ] each - ] V{ } make - ] change-instructions drop - ] if ; + alternatives get clear-assoc + [ conversions-for-insn ] each + ] V{ } make + ] change-instructions drop ; : insert-conversions ( cfg -- ) + H{ } clone alternatives set V{ } clone renaming-set set [ conversions-for-block ] each-basic-block ; diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index a76beca181..6d449540f2 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -36,8 +36,10 @@ SYMBOL: visited [ reverse-post-order ] dip each ; inline : optimize-basic-block ( bb quot -- ) - [ drop basic-block set ] - [ change-instructions drop ] 2bi ; inline + over kill-block?>> [ 2drop ] [ + over basic-block set + change-instructions drop + ] if ; inline : simple-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... ) '[ _ optimize-basic-block ] each-basic-block ; inline diff --git a/basis/compiler/cfg/scheduling/scheduling.factor b/basis/compiler/cfg/scheduling/scheduling.factor index 1c6c6987f7..04e4142a35 100644 --- a/basis/compiler/cfg/scheduling/scheduling.factor +++ b/basis/compiler/cfg/scheduling/scheduling.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2009, 2010 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs compiler.cfg.def-use -compiler.cfg.dependence compiler.cfg.instructions -compiler.cfg.liveness compiler.cfg.rpo cpu.architecture fry -kernel locals make math namespaces sequences sets ; +USING: accessors arrays assocs fry kernel locals make math +namespaces sequences sets combinators.short-circuit +compiler.cfg.def-use compiler.cfg.dependence +compiler.cfg.instructions compiler.cfg.liveness compiler.cfg.rpo +cpu.architecture ; IN: compiler.cfg.scheduling ! Instruction scheduling to reduce register pressure, from: @@ -128,7 +129,6 @@ ERROR: definition-after-usage vreg old-bb new-bb ; : schedule-instructions ( cfg -- cfg' ) dup [ - dup might-spill? - [ schedule-block ] - [ drop ] if + dup { [ kill-block?>> not ] [ might-spill? ] } 1&& + [ schedule-block ] [ drop ] if ] each-basic-block ; diff --git a/basis/compiler/cfg/stacks/finalize/finalize.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor index 41512f206f..a35d82bbb5 100644 --- a/basis/compiler/cfg/stacks/finalize/finalize.factor +++ b/basis/compiler/cfg/stacks/finalize/finalize.factor @@ -43,7 +43,7 @@ ERROR: bad-peek dst loc ; : visit-edge ( from to -- ) ! If both blocks are subroutine calls, don't bother ! computing anything. - 2dup [ kill-block? ] both? [ 2drop ] [ + 2dup [ kill-block?>> ] both? [ 2drop ] [ 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ##branch ] V{ } make [ 2drop ] [ insert-basic-block ] if-empty ] if ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 0158c0546c..38ca9a950f 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -6,12 +6,6 @@ sets vectors fry arrays compiler.cfg compiler.cfg.instructions compiler.cfg.rpo compiler.utilities ; IN: compiler.cfg.utilities -PREDICATE: kill-block < basic-block - instructions>> { - [ length 2 >= ] - [ penultimate kill-vreg-insn? ] - } 1&& ; - : back-edge? ( from to -- ? ) [ number>> ] bi@ >= ; diff --git a/basis/compiler/codegen/alien/alien.factor b/basis/compiler/codegen/alien/alien.factor deleted file mode 100644 index 3af220376c..0000000000 --- a/basis/compiler/codegen/alien/alien.factor +++ /dev/null @@ -1,207 +0,0 @@ -! Copyright (C) 2008, 2010 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.complex alien.c-types -alien.libraries alien.private alien.strings arrays -classes.struct combinators compiler.alien -compiler.cfg.instructions compiler.codegen -compiler.codegen.fixup compiler.errors compiler.utilities -cpu.architecture fry kernel layouts libc locals make math -math.order math.parser namespaces quotations sequences strings -system ; -FROM: compiler.errors => no-such-symbol ; -IN: compiler.codegen.alien - -! ##alien-invoke -GENERIC: next-fastcall-param ( rep -- ) - -: ?dummy-stack-params ( rep -- ) - dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ; - -: ?dummy-int-params ( rep -- ) - dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ; - -: ?dummy-fp-params ( rep -- ) - drop dummy-fp-params? [ float-regs inc ] when ; - -M: int-rep next-fastcall-param - int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ; - -M: float-rep next-fastcall-param - float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ; - -M: double-rep next-fastcall-param - float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ; - -GENERIC# reg-class-full? 1 ( reg-class abi -- ? ) - -M: stack-params reg-class-full? 2drop t ; - -M: reg-class reg-class-full? - [ get ] swap '[ _ param-regs length ] bi >= ; - -: alloc-stack-param ( rep -- n reg-class rep ) - stack-params get - [ rep-size cell align stack-params +@ ] dip - stack-params dup ; - -: alloc-fastcall-param ( rep -- n reg-class rep ) - [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ; - -:: alloc-parameter ( rep abi -- reg rep ) - rep dup reg-class-of abi reg-class-full? - [ alloc-stack-param ] [ alloc-fastcall-param ] if - [ abi param-reg ] dip ; - -: reset-fastcall-counts ( -- ) - { int-regs float-regs stack-params } [ 0 swap set ] each ; - -: with-param-regs ( quot -- ) - #! In quot you can call alloc-parameter - [ reset-fastcall-counts call ] with-scope ; inline - -:: move-parameters ( params word -- ) - #! Moves values from C stack to registers (if word is - #! %load-param-reg) and registers to C stack (if word is - #! %save-param-reg). - 0 params alien-parameters flatten-c-types [ - [ params abi>> alloc-parameter word execute( offset reg rep -- ) ] - [ rep-size cell align + ] - 2bi - ] each drop ; inline - -: parameter-offsets ( types -- offsets ) - 0 [ stack-size + ] accumulate nip ; - -: each-parameter ( parameters quot -- ) - [ [ parameter-offsets ] keep ] dip 2each ; inline - -: reverse-each-parameter ( parameters quot -- ) - [ [ parameter-offsets ] keep ] dip 2reverse-each ; inline - -: prepare-unbox-parameters ( parameters -- offsets types indices ) - [ parameter-offsets ] [ ] [ length iota ] tri ; - -: unbox-parameters ( offset node -- ) - parameters>> swap - '[ prepare-unbox-parameters [ %pop-stack [ _ + ] dip unbox-parameter ] 3each ] - [ length neg %inc-d ] - bi ; - -: prepare-box-struct ( node -- offset ) - #! Return offset on C stack where to store unboxed - #! parameters. If the C function is returning a structure, - #! the first parameter is an implicit target area pointer, - #! so we need to use a different offset. - return>> large-struct? - [ %prepare-box-struct cell ] [ 0 ] if ; - -: objects>registers ( params -- ) - #! Generate code for unboxing a list of C types, then - #! generate code for moving these parameters to registers on - #! architectures where parameters are passed in registers. - [ - [ prepare-box-struct ] keep - [ unbox-parameters ] keep - \ %load-param-reg move-parameters - ] with-param-regs ; - -: box-return* ( node -- ) - return>> [ ] [ box-return %push-stack ] if-void ; - -GENERIC# dlsym-valid? 1 ( symbols dll -- ? ) - -M: string dlsym-valid? dlsym ; - -M: array dlsym-valid? '[ _ dlsym ] any? ; - -: check-dlsym ( symbols dll -- ) - dup dll-valid? [ - dupd dlsym-valid? - [ drop ] [ compiling-word get no-such-symbol ] if - ] [ - dll-path compiling-word get no-such-library drop - ] if ; - -: decorated-symbol ( params -- symbols ) - [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi - { - [ drop ] - [ "@" glue ] - [ "@" glue "_" prepend ] - [ "@" glue "@" prepend ] - } 2cleave - 4array ; - -: alien-invoke-dlsym ( params -- symbols dll ) - [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ] - [ library>> load-library ] - bi 2dup check-dlsym ; - -M: ##alien-invoke generate-insn - params>> - ! Unbox parameters - dup objects>registers - %prepare-var-args - ! Call function - dup alien-invoke-dlsym %alien-invoke - ! Box return value - dup %cleanup - box-return* ; - -M: ##alien-assembly generate-insn - params>> - ! Unbox parameters - dup objects>registers - %prepare-var-args - ! Generate assembly - dup quot>> call( -- ) - ! Box return value - box-return* ; - -! ##alien-indirect -M: ##alien-indirect generate-insn - params>> - ! Save alien at top of stack to temporary storage - %prepare-alien-indirect - ! Unbox parameters - dup objects>registers - %prepare-var-args - ! Call alien in temporary storage - %alien-indirect - ! Box return value - dup %cleanup - box-return* ; - -! ##alien-callback -: box-parameters ( params -- ) - alien-parameters [ box-parameter %push-context-stack ] each-parameter ; - -: registers>objects ( node -- ) - ! Generate code for boxing input parameters in a callback. - [ - dup \ %save-param-reg move-parameters - %begin-callback - box-parameters - ] with-param-regs ; - -: callback-return-quot ( ctype -- quot ) - return>> { - { [ dup void? ] [ drop [ ] ] } - { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] } - [ c-type c-type-unboxer-quot ] - } cond ; - -: callback-prep-quot ( params -- quot ) - parameters>> [ c-type c-type-boxer-quot ] map spread>quot ; - -: wrap-callback-quot ( params -- quot ) - [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append - yield-hook get - '[ _ _ do-callback ] - >quotation ; - -M: ##alien-callback generate-insn - params>> - [ registers>objects ] - [ wrap-callback-quot %alien-callback ] - [ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ; diff --git a/basis/compiler/codegen/alien/authors.txt b/basis/compiler/codegen/alien/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/basis/compiler/codegen/alien/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index d5e4987ee0..5b2c52ce28 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -91,6 +91,8 @@ M: ##dispatch generate-insn ! Special cases M: ##no-tco generate-insn drop ; +M: ##stack-frame generate-insn drop ; + M: ##prologue generate-insn drop cfg get stack-frame>> @@ -251,6 +253,7 @@ CODEGEN: ##call-gc %call-gc CODEGEN: ##spill %spill CODEGEN: ##reload %reload +! Conditional branches << SYNTAX: CONDITIONAL: @@ -270,3 +273,31 @@ CONDITIONAL: ##check-nursery-branch %check-nursery-branch CONDITIONAL: ##fixnum-add %fixnum-add CONDITIONAL: ##fixnum-sub %fixnum-sub CONDITIONAL: ##fixnum-mul %fixnum-mul + +! FFI +CODEGEN: ##box %box +CODEGEN: ##box-long-long %box-long-long +CODEGEN: ##box-large-struct %box-large-struct +CODEGEN: ##box-small-struct %box-small-struct +CODEGEN: ##unbox %unbox +CODEGEN: ##unbox-long-long %unbox-long-long +CODEGEN: ##unbox-large-struct %unbox-large-struct +CODEGEN: ##unbox-small-struct %unbox-small-struct +CODEGEN: ##pop-stack %pop-stack +CODEGEN: ##pop-context-stack %pop-context-stack +CODEGEN: ##prepare-box-struct %prepare-box-struct +CODEGEN: ##load-param-reg %load-param-reg +CODEGEN: ##push-stack %push-stack +CODEGEN: ##alien-invoke %alien-invoke +CODEGEN: ##cleanup %cleanup +CODEGEN: ##prepare-alien-indirect %prepare-alien-indirect +CODEGEN: ##alien-indirect %alien-indirect +CODEGEN: ##push-context-stack %push-context-stack +CODEGEN: ##save-param-reg %save-param-reg +CODEGEN: ##begin-callback %begin-callback +CODEGEN: ##alien-callback %alien-callback +CODEGEN: ##end-callback %end-callback +CODEGEN: ##to-nv %to-nv +CODEGEN: ##from-nv %from-nv + +M: ##alien-assembly generate-insn quot>> call( -- ) ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 4c8a9ca61d..e4fd64505e 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -15,11 +15,11 @@ compiler.tree.optimizer compiler.cfg compiler.cfg.builder +compiler.cfg.builder.alien compiler.cfg.optimizer compiler.cfg.finalization -compiler.codegen -compiler.codegen.alien ; +compiler.codegen ; IN: compiler SYMBOL: compiled diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 7bbc0a904f..bd770eb8de 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -610,11 +610,6 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ; [ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test [ 100 ] [ "p" get ?promise ] unit-test -! Regression: calling an undefined function would raise a protection fault -FUNCTION: void this_does_not_exist ( ) ; - -[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with - ! More alien-assembly tests are in cpu.* vocabs : assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ; diff --git a/basis/compiler/tests/linkage-errors.factor b/basis/compiler/tests/linkage-errors.factor new file mode 100644 index 0000000000..fc59f6552e --- /dev/null +++ b/basis/compiler/tests/linkage-errors.factor @@ -0,0 +1,21 @@ +USING: tools.test namespaces assocs alien.syntax kernel +compiler.errors accessors alien ; +FROM: alien.libraries => add-library ; +IN: compiler.tests.linkage-errors + +! Regression: calling an undefined function would raise a protection fault +FUNCTION: void this_does_not_exist ( ) ; + +[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with + +[ T{ no-such-symbol { name "this_does_not_exist" } } ] +[ \ this_does_not_exist linkage-errors get at error>> ] unit-test + +<< "no_such_library" "no_such_library" cdecl add-library >> + +LIBRARY: no_such_library + +FUNCTION: void no_such_function ( ) ; + +[ T{ no-such-library { name "no_such_library" } } ] +[ \ no_such_function linkage-errors get at error>> ] unit-test diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 19a9b02785..6657fd8c85 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -624,7 +624,9 @@ HOOK: %alien-callback cpu ( quot -- ) HOOK: %end-callback cpu ( -- ) -HOOK: %end-callback-value cpu ( c-type -- ) +HOOK: %to-nv cpu ( -- ) + +HOOK: %from-nv cpu ( -- ) HOOK: stack-cleanup cpu ( params -- n ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 7e23a0b9c1..ce7a4e13eb 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -836,14 +836,9 @@ M: ppc %end-callback ( -- ) 3 %load-vm-addr "end_callback" f %alien-invoke ; -M: ppc %end-callback-value ( ctype -- ) - ! Save top of data stack - 16 ds-reg 0 LWZ - %end-callback - ! Restore top of data stack - 3 16 MR - ! Unbox former top of data stack to return registers - unbox-return ; +M: ppc %to-nv ( -- ) 16 3 MR ; + +M: ppc %from-nv ( -- ) 3 16 MR ; M: ppc %unbox-small-struct ( size -- ) heap-size cell align cell /i { diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 8618affaed..619f4fcad4 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -283,14 +283,9 @@ M: x86.32 %end-callback ( -- ) 0 save-vm-ptr "end_callback" f %alien-invoke ; -M: x86.32 %end-callback-value ( ctype -- ) - %pop-context-stack - 4 stack@ EAX MOV - %end-callback - ! Place former top of data stack back in EAX - EAX 4 stack@ MOV - ! Unbox EAX - unbox-return ; +M: x86.32 %to-nv ( -- ) 4 stack@ EAX MOV ; + +M: x86.32 %from-nv ( -- ) EAX 4 stack@ MOV ; GENERIC: float-function-param ( stack-slot dst src -- ) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 5baeed81b8..73a4df5b45 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -249,13 +249,9 @@ M: x86.64 %end-callback ( -- ) param-reg-0 %mov-vm-ptr "end_callback" f %alien-invoke ; -M: x86.64 %end-callback-value ( ctype -- ) - %pop-context-stack - nv-reg param-reg-0 MOV - %end-callback - param-reg-0 nv-reg MOV - ! Unbox former top of data stack to return registers - unbox-return ; +M: x86.64 %to-nv ( -- ) nv-reg param-reg-0 MOV ; + +M: x86.64 %from-nv ( -- ) param-reg-0 nv-reg MOV ; : float-function-param ( i src -- ) [ float-regs cdecl param-regs nth ] dip double-rep %copy ; From 839e26de3a947c65bab220f328f6b199752aa4a3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 9 May 2010 21:55:21 -0400 Subject: [PATCH 05/14] cpu.x86.32: fix load error --- basis/cpu/x86/32/32.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 619f4fcad4..0307ba7f98 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -5,8 +5,8 @@ arrays kernel fry math namespaces sequences system layouts io vocabs.loader accessors init classes.struct combinators command-line make words compiler compiler.units compiler.constants compiler.alien compiler.codegen -compiler.codegen.alien compiler.codegen.fixup -compiler.cfg.instructions compiler.cfg.builder +compiler.codegen.fixup compiler.cfg.instructions +compiler.cfg.builder compiler.cfg.builder.alien compiler.cfg.intrinsics compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ; From 2912f21accf3a6b7cbddfb430c766a0b0c108156 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 9 May 2010 22:15:14 -0400 Subject: [PATCH 06/14] cpu.x86.64.unix: fix load error --- basis/cpu/x86/64/unix/unix.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index ce98b53fef..4e81e8ce13 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -3,7 +3,7 @@ USING: accessors arrays sequences math splitting make assocs kernel layouts system alien.c-types classes.struct cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands -cpu.x86 compiler.codegen.alien compiler.cfg.registers ; +cpu.x86 compiler.cfg.builder.alien compiler.cfg.registers ; IN: cpu.x86.64.unix M: int-regs param-regs From 7316d41226ceecb77a575309163becebc48d37dd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 9 May 2010 23:25:46 -0400 Subject: [PATCH 07/14] FFI rewrite part 2: use ##peek and ##replace instructions to access stack --- basis/compiler/cfg/builder/alien/alien.factor | 64 ++++++----- .../cfg/instructions/instructions.factor | 48 +++++--- basis/compiler/codegen/codegen.factor | 5 - basis/compiler/tests/alien.factor | 2 - basis/cpu/architecture/architecture.factor | 40 ++----- basis/cpu/x86/32/32.factor | 103 +++++++----------- basis/cpu/x86/64/64.factor | 66 +++++------ basis/cpu/x86/x86.factor | 18 ++- basis/stack-checker/alien/alien.factor | 13 +-- 9 files changed, 151 insertions(+), 208 deletions(-) diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index 8bdf4ccb46..7ec1bee1a3 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -7,7 +7,8 @@ namespaces kernel strings libc quotations cpu.architecture compiler.alien compiler.utilities compiler.tree compiler.cfg compiler.cfg.builder compiler.cfg.builder.blocks compiler.cfg.instructions compiler.cfg.stack-frame -compiler.cfg.stacks ; +compiler.cfg.stacks compiler.cfg.registers +compiler.cfg.hats ; FROM: compiler.errors => no-such-symbol no-such-library ; IN: compiler.cfg.builder.alien @@ -78,9 +79,9 @@ M: reg-class reg-class-full? [ [ parameter-offsets ] keep ] dip 2reverse-each ; inline : prepare-unbox-parameters ( parameters -- offsets types indices ) - [ parameter-offsets ] [ ] [ length iota ] tri ; + [ length iota ] [ parameter-offsets ] [ ] tri ; -GENERIC: unbox-parameter ( n c-type -- ) +GENERIC: unbox-parameter ( src n c-type -- ) M: c-type unbox-parameter [ rep>> ] [ unboxer>> ] bi ##unbox ; @@ -95,7 +96,10 @@ M: struct-c-type unbox-parameter parameters>> swap '[ prepare-unbox-parameters - [ ##pop-stack [ _ + ] dip base-type unbox-parameter ] 3each + [ + [ ^^peek ] [ _ + ] [ base-type ] tri* + unbox-parameter + ] 3each ] [ length neg ##inc-d ] bi ; @@ -118,19 +122,19 @@ M: struct-c-type unbox-parameter \ ##load-param-reg move-parameters ] with-param-regs ; -GENERIC: box-return ( c-type -- ) +GENERIC: box-return ( c-type -- dst ) M: c-type box-return - [ f ] dip [ rep>> ] [ boxer>> ] bi ##box ; + [ f ] dip [ rep>> ] [ boxer>> ] bi ^^box ; M: long-long-type box-return - [ f ] dip boxer>> ##box-long-long ; + [ f ] dip boxer>> ^^box-long-long ; M: struct-c-type box-return - [ ##box-small-struct ] [ ##box-large-struct ] if-small-struct ; + [ ^^box-small-struct ] [ ^^box-large-struct ] if-small-struct ; : box-return* ( node -- ) - return>> [ ] [ base-type box-return ##push-stack ] if-void ; + return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ; GENERIC# dlsym-valid? 1 ( symbols dll -- ? ) @@ -200,41 +204,37 @@ M: #alien-invoke emit-node M: #alien-indirect emit-node [ - ! Save alien at top of stack to temporary storage - ##prepare-alien-indirect - ! Unbox parameters - dup objects>registers - ! Call alien in temporary storage - ##alien-indirect - ! Box return value - dup ##cleanup - box-return* + D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr + { + [ drop objects>registers ] + [ nip ##alien-indirect ] + [ drop ##cleanup ] + [ drop box-return* ] + } 2cleave ] emit-alien-node ; M: #alien-assembly emit-node [ - ! Unbox parameters - dup objects>registers - ! Generate assembly - dup quot>> ##alien-assembly - ! Box return value - box-return* + [ objects>registers ] + [ quot>> ##alien-assembly ] + [ box-return* ] + tri ] emit-alien-node ; -GENERIC: box-parameter ( n c-type -- ) +GENERIC: box-parameter ( n c-type -- dst ) M: c-type box-parameter - [ rep>> ] [ boxer>> ] bi ##box ; + [ rep>> ] [ boxer>> ] bi ^^box ; M: long-long-type box-parameter - boxer>> ##box-long-long ; + boxer>> ^^box-long-long ; M: struct-c-type box-parameter - [ ##box-large-struct ] [ base-type box-parameter ] if-value-struct ; + [ ^^box-large-struct ] [ base-type box-parameter ] if-value-struct ; : box-parameters ( params -- ) alien-parameters - [ base-type box-parameter ##push-context-stack ] each-parameter ; + [ base-type box-parameter next-vreg ##push-context-stack ] each-parameter ; : registers>objects ( node -- ) ! Generate code for boxing input parameters in a callback. @@ -260,7 +260,7 @@ M: struct-c-type box-parameter '[ _ _ do-callback ] >quotation ; -GENERIC: unbox-return ( c-type -- ) +GENERIC: unbox-return ( src c-type -- ) M: c-type unbox-return [ f ] dip [ rep>> ] [ unboxer>> ] bi ##unbox ; @@ -280,10 +280,8 @@ M: #alien-callback emit-node [ wrap-callback-quot ##alien-callback ] [ alien-return [ ##end-callback ] [ - ##pop-context-stack - ##to-nv + [ ^^pop-context-stack ] dip ##end-callback - ##from-nv base-type unbox-return ] if-void ] tri diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 87055eb550..14681b4777 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -613,55 +613,61 @@ INSN: ##stack-frame literal: stack-frame ; INSN: ##box +def: dst/tagged-rep literal: n rep boxer ; INSN: ##box-long-long +def: dst/tagged-rep literal: n boxer ; INSN: ##box-small-struct +def: dst/tagged-rep literal: c-type ; INSN: ##box-large-struct +def: dst/tagged-rep literal: n c-type ; INSN: ##unbox +use: src/tagged-rep literal: n rep unboxer ; INSN: ##unbox-long-long +use: src/tagged-rep literal: n unboxer ; INSN: ##unbox-large-struct +use: src/tagged-rep literal: n c-type ; INSN: ##unbox-small-struct +use: src/tagged-rep literal: c-type ; -INSN: ##pop-stack -literal: n ; - -INSN: ##pop-context-stack ; +INSN: ##pop-context-stack +def: dst/tagged-rep +temp: temp/int-rep ; INSN: ##prepare-box-struct ; INSN: ##load-param-reg literal: offset reg rep ; -INSN: ##push-stack ; - INSN: ##alien-invoke literal: symbols dll ; INSN: ##cleanup literal: params ; -INSN: ##prepare-alien-indirect ; - -INSN: ##alien-indirect ; +INSN: ##alien-indirect +use: src/int-rep ; INSN: ##alien-assembly literal: quot ; -INSN: ##push-context-stack ; +INSN: ##push-context-stack +use: src/tagged-rep +temp: temp/int-rep ; INSN: ##save-param-reg literal: offset reg rep ; @@ -673,10 +679,6 @@ literal: quot ; INSN: ##end-callback ; -INSN: ##to-nv ; - -INSN: ##from-nv ; - ! Control flow INSN: ##phi def: dst @@ -812,7 +814,23 @@ UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ; UNION: clobber-insn ##call-gc ##unary-float-function -##binary-float-function ; +##binary-float-function +##box +##box-long-long +##box-small-struct +##box-large-struct +##unbox +##unbox-long-long +##unbox-large-struct +##unbox-small-struct +##prepare-box-struct +##load-param-reg +##alien-invoke +##alien-indirect +##alien-assembly +##save-param-reg +##begin-callback +##end-callback ; ! Instructions that have complex expansions and require that the ! output registers are not equal to any of the input registers diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 5b2c52ce28..a106e55e81 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -283,21 +283,16 @@ CODEGEN: ##unbox %unbox CODEGEN: ##unbox-long-long %unbox-long-long CODEGEN: ##unbox-large-struct %unbox-large-struct CODEGEN: ##unbox-small-struct %unbox-small-struct -CODEGEN: ##pop-stack %pop-stack CODEGEN: ##pop-context-stack %pop-context-stack CODEGEN: ##prepare-box-struct %prepare-box-struct CODEGEN: ##load-param-reg %load-param-reg -CODEGEN: ##push-stack %push-stack CODEGEN: ##alien-invoke %alien-invoke CODEGEN: ##cleanup %cleanup -CODEGEN: ##prepare-alien-indirect %prepare-alien-indirect CODEGEN: ##alien-indirect %alien-indirect CODEGEN: ##push-context-stack %push-context-stack CODEGEN: ##save-param-reg %save-param-reg CODEGEN: ##begin-callback %begin-callback CODEGEN: ##alien-callback %alien-callback CODEGEN: ##end-callback %end-callback -CODEGEN: ##to-nv %to-nv -CODEGEN: ##from-nv %from-nv M: ##alien-assembly generate-insn quot>> call( -- ) ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index bd770eb8de..b8c48abfc3 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -99,8 +99,6 @@ FUNCTION: TINY ffi_test_17 int x ; { 1 1 } [ indirect-test-1 ] must-infer-as -[ B{ } indirect-test-1 ] [ { "kernel-error" 3 6 B{ } } = ] must-fail-with - [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test : indirect-test-1' ( ptr -- ) diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 6657fd8c85..337fa04977 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -553,48 +553,40 @@ HOOK: dummy-int-params? cpu ( -- ? ) ! If t, all int parameters are shadowed by dummy FP parameters HOOK: dummy-fp-params? cpu ( -- ? ) -! Load a value (from the data stack in the ds register). -! The value is then passed as a parameter to a VM to_*() function -HOOK: %pop-stack cpu ( n -- ) - ! Store a value (to the data stack in the VM's current context) ! The value is passed to a VM to_*() function -- used for ! callback returns -HOOK: %pop-context-stack cpu ( -- ) - -! Store a value (to the data stack in the ds register). -! The value was returned from a VM from_*() function -HOOK: %push-stack cpu ( -- ) +HOOK: %pop-context-stack cpu ( dst temp -- ) ! Store a value (to the data stack in the VM's current context) ! The value is returned from a VM from_*() function -- used for ! callback parameters -HOOK: %push-context-stack cpu ( -- ) +HOOK: %push-context-stack cpu ( src temp -- ) ! Call a function to convert a tagged pointer returned by ! %pop-stack or %pop-context-stack into a value that can be ! passed to a C function, or returned from a callback -HOOK: %unbox cpu ( n rep func -- ) +HOOK: %unbox cpu ( src n rep func -- ) -HOOK: %unbox-long-long cpu ( n func -- ) +HOOK: %unbox-long-long cpu ( src n func -- ) -HOOK: %unbox-small-struct cpu ( c-type -- ) +HOOK: %unbox-small-struct cpu ( src c-type -- ) -HOOK: %unbox-large-struct cpu ( n c-type -- ) +HOOK: %unbox-large-struct cpu ( src n c-type -- ) ! Call a function to convert a value into a tagged pointer, ! possibly allocating a bignum, float, or alien instance, ! which is then pushed on the data stack by %push-stack or ! %push-context-stack -HOOK: %box cpu ( n rep func -- ) +HOOK: %box cpu ( dst n rep func -- ) -HOOK: %box-long-long cpu ( n func -- ) +HOOK: %box-long-long cpu ( dst n func -- ) HOOK: %prepare-box-struct cpu ( -- ) -HOOK: %box-small-struct cpu ( c-type -- ) +HOOK: %box-small-struct cpu ( dst c-type -- ) -HOOK: %box-large-struct cpu ( n c-type -- ) +HOOK: %box-large-struct cpu ( dst n c-type -- ) HOOK: %save-param-reg cpu ( stack reg rep -- ) @@ -604,19 +596,13 @@ HOOK: %restore-context cpu ( temp1 temp2 -- ) HOOK: %save-context cpu ( temp1 temp2 -- ) -HOOK: %prepare-var-args cpu ( -- ) - -M: object %prepare-var-args ; - HOOK: %alien-invoke cpu ( function library -- ) HOOK: %cleanup cpu ( params -- ) M: object %cleanup ( params -- ) drop ; -HOOK: %prepare-alien-indirect cpu ( -- ) - -HOOK: %alien-indirect cpu ( -- ) +HOOK: %alien-indirect cpu ( src -- ) HOOK: %begin-callback cpu ( -- ) @@ -624,10 +610,6 @@ HOOK: %alien-callback cpu ( quot -- ) HOOK: %end-callback cpu ( -- ) -HOOK: %to-nv cpu ( -- ) - -HOOK: %from-nv cpu ( -- ) - HOOK: stack-cleanup cpu ( params -- n ) M: object stack-cleanup drop 0 ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 0307ba7f98..9734ea5dd3 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -151,11 +151,12 @@ M: x86.32 %load-param-reg [ swap local@ ] dip %copy ; #! parameter being passed to a callback from C. over [ [ local@ ] dip load-return-reg ] [ 2drop ] if ; -M:: x86.32 %box ( n rep func -- ) +M:: x86.32 %box ( dst n rep func -- ) n rep (%box) rep rep-size save-vm-ptr 0 stack@ rep store-return-reg - func f %alien-invoke ; + func f %alien-invoke + dst EAX tagged-rep %copy ; : (%box-long-long) ( n -- ) [ @@ -163,19 +164,21 @@ M:: x86.32 %box ( n rep func -- ) EAX swap cell - next-stack@ MOV ] when* ; -M: x86.32 %box-long-long ( n func -- ) - [ (%box-long-long) ] dip +M:: x86.32 %box-long-long ( dst n func -- ) + n (%box-long-long) 8 save-vm-ptr 4 stack@ EDX MOV 0 stack@ EAX MOV - f %alien-invoke ; + func f %alien-invoke + dst EAX tagged-rep %copy ; -M:: x86.32 %box-large-struct ( n c-type -- ) +M:: x86.32 %box-large-struct ( dst n c-type -- ) EDX n struct-return@ LEA 8 save-vm-ptr 4 stack@ c-type heap-size MOV 0 stack@ EDX MOV - "from_value_struct" f %alien-invoke ; + "from_value_struct" f %alien-invoke + dst EAX tagged-rep %copy ; M: x86.32 %prepare-box-struct ( -- ) ! Compute target address for value struct return @@ -183,38 +186,36 @@ M: x86.32 %prepare-box-struct ( -- ) ! Store it as the first parameter 0 local@ EAX MOV ; -M: x86.32 %box-small-struct ( c-type -- ) +M: x86.32 %box-small-struct ( dst c-type -- ) #! Box a <= 8-byte struct returned in EAX:EDX. OS X only. 12 save-vm-ptr 8 stack@ swap heap-size MOV 4 stack@ EDX MOV 0 stack@ EAX MOV - "from_small_struct" f %alien-invoke ; + "from_small_struct" f %alien-invoke + dst EAX tagged-rep %copy ; -M: x86.32 %pop-stack ( n -- ) - EAX swap ds-reg reg-stack MOV ; +M:: x86.32 %pop-context-stack ( dst temp -- ) + temp %context + dst temp "datastack" context-field-offset [+] MOV + dst dst [] MOV + temp "datastack" context-field-offset [+] bootstrap-cell SUB ; -M: x86.32 %pop-context-stack ( -- ) - temp-reg %context - EAX temp-reg "datastack" context-field-offset [+] MOV - EAX EAX [] MOV - temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ; - -: call-unbox-func ( func -- ) +: call-unbox-func ( src func -- ) + EAX src tagged-rep %copy 4 save-vm-ptr 0 stack@ EAX MOV f %alien-invoke ; -M: x86.32 %unbox ( n rep func -- ) - #! The value being unboxed must already be in EAX. - #! If n is f, we're unboxing a return value about to be - #! returned by the callback. Otherwise, we're unboxing - #! a parameter to a C function about to be called. - call-unbox-func +M:: x86.32 %unbox ( src n rep func -- ) + ! If n is f, we're unboxing a return value about to be + ! returned by the callback. Otherwise, we're unboxing + ! a parameter to a C function about to be called. + src func call-unbox-func ! Store the return value on the C stack - over [ [ local@ ] dip store-return-reg ] [ 2drop ] if ; + n [ n local@ rep store-return-reg ] when ; -M: x86.32 %unbox-long-long ( n func -- ) +M:: x86.32 %unbox-long-long ( src n func -- ) call-unbox-func ! Store the return value on the C stack [ @@ -222,33 +223,15 @@ M: x86.32 %unbox-long-long ( n func -- ) [ 4 + local@ EDX MOV ] bi ] when* ; -: %unbox-struct-1 ( -- ) - #! Alien must be in EAX. - 4 save-vm-ptr - 0 stack@ EAX MOV - "alien_offset" f %alien-invoke - ! Load first cell - EAX EAX [] MOV ; +M: x86 %unbox-small-struct ( src size -- ) + [ "alien_offset" call-unbox-func ] + [ + heap-size 4 > [ EDX EAX 4 [+] MOV ] when + EAX EAX [] MOV + ] bi* ; -: %unbox-struct-2 ( -- ) - #! Alien must be in EAX. - 4 save-vm-ptr - 0 stack@ EAX MOV - "alien_offset" f %alien-invoke - ! Load second cell - EDX EAX 4 [+] MOV - ! Load first cell - EAX EAX [] MOV ; - -M: x86 %unbox-small-struct ( size -- ) - #! Alien must be in EAX. - heap-size cell align cell /i { - { 1 [ %unbox-struct-1 ] } - { 2 [ %unbox-struct-2 ] } - } case ; - -M:: x86.32 %unbox-large-struct ( n c-type -- ) - ! Alien must be in EAX. +M:: x86.32 %unbox-large-struct ( src n c-type -- ) + EAX src tagged-rep %copy ! Compute destination address EDX n local@ LEA 12 save-vm-ptr @@ -257,16 +240,8 @@ M:: x86.32 %unbox-large-struct ( n c-type -- ) 0 stack@ EAX MOV "to_value_struct" f %alien-invoke ; -M: x86.32 %prepare-alien-indirect ( -- ) - EAX ds-reg [] MOV - ds-reg 4 SUB - 4 save-vm-ptr - 0 stack@ EAX MOV - "pinned_alien_offset" f %alien-invoke - EBP EAX MOV ; - -M: x86.32 %alien-indirect ( -- ) - EBP CALL ; +M: x86.32 %alien-indirect ( src -- ) + ?spill-slot CALL ; M: x86.32 %begin-callback ( -- ) 0 save-vm-ptr @@ -283,10 +258,6 @@ M: x86.32 %end-callback ( -- ) 0 save-vm-ptr "end_callback" f %alien-invoke ; -M: x86.32 %to-nv ( -- ) 4 stack@ EAX MOV ; - -M: x86.32 %from-nv ( -- ) EAX 4 stack@ MOV ; - GENERIC: float-function-param ( stack-slot dst src -- ) M:: spill-slot float-function-param ( stack-slot dst src -- ) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 73a4df5b45..2036b3f855 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -117,16 +117,14 @@ M: x86.64 %load-param-reg [ swap param@ ] dip %copy ; call ] with-scope ; inline -M: x86.64 %pop-stack ( n -- ) - param-reg-0 swap ds-reg reg-stack MOV ; +M:: x86.64 %pop-context-stack ( dst temp -- ) + temp %context + dst temp "datastack" context-field-offset [+] MOV + dst dst [] MOV + temp "datastack" context-field-offset [+] bootstrap-cell SUB ; -M: x86.64 %pop-context-stack ( -- ) - temp-reg %context - param-reg-0 temp-reg "datastack" context-field-offset [+] MOV - param-reg-0 param-reg-0 [] MOV - temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ; - -M:: x86.64 %unbox ( n rep func -- ) +M:: x86.64 %unbox ( src n rep func -- ) + param-reg-0 src tagged-rep %copy param-reg-1 %mov-vm-ptr ! Call the unboxer func f %alien-invoke @@ -136,25 +134,25 @@ M:: x86.64 %unbox ( n rep func -- ) n [ n rep reg-class-of return-reg rep %save-param-reg ] when ; : %unbox-struct-field ( rep i -- ) - ! Alien must be in param-reg-0. R11 swap cells [+] swap reg-class-of { { int-regs [ int-regs get pop swap MOV ] } { float-regs [ float-regs get pop swap MOVSD ] } } case ; -M: x86.64 %unbox-small-struct ( c-type -- ) - ! Alien must be in param-reg-0. +M:: x86.64 %unbox-small-struct ( src c-type -- ) + param-reg-0 src tagged-rep %copy param-reg-1 %mov-vm-ptr "alien_offset" f %alien-invoke ! Move alien_offset() return value to R11 so that we don't ! clobber it. R11 RAX MOV [ - flatten-struct-type [ %unbox-struct-field ] each-index + c-type flatten-struct-type + [ %unbox-struct-field ] each-index ] with-return-regs ; -M:: x86.64 %unbox-large-struct ( n c-type -- ) - ! Source is in param-reg-0 +M:: x86.64 %unbox-large-struct ( src n c-type -- ) + param-reg-0 src tagged-rep %copy ! Load destination address into param-reg-1 param-reg-1 n param@ LEA ! Load structure size into param-reg-2 @@ -169,7 +167,7 @@ M:: x86.64 %unbox-large-struct ( n c-type -- ) [ ] tri %copy ; -M:: x86.64 %box ( n rep func -- ) +M:: x86.64 %box ( dst n rep func -- ) n [ n 0 rep reg-class-of cdecl param-reg @@ -178,7 +176,8 @@ M:: x86.64 %box ( n rep func -- ) rep load-return-value ] if rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr - func f %alien-invoke ; + func f %alien-invoke + dst RAX tagged-rep %copy ; : box-struct-field@ ( i -- operand ) 1 + cells param@ ; @@ -188,28 +187,30 @@ M:: x86.64 %box ( n rep func -- ) { float-regs [ float-regs get pop MOVSD ] } } case ; -M: x86.64 %box-small-struct ( c-type -- ) +M:: x86.64 %box-small-struct ( dst c-type -- ) #! Box a <= 16-byte struct. [ - [ flatten-struct-type [ %box-struct-field ] each-index ] - [ param-reg-2 swap heap-size MOV ] bi + c-type flatten-struct-type [ %box-struct-field ] each-index + param-reg-2 c-type heap-size MOV param-reg-0 0 box-struct-field@ MOV param-reg-1 1 box-struct-field@ MOV param-reg-3 %mov-vm-ptr "from_small_struct" f %alien-invoke + dst RAX tagged-rep %copy ] with-return-regs ; : struct-return@ ( n -- operand ) [ stack-frame get params>> ] unless* param@ ; -M: x86.64 %box-large-struct ( n c-type -- ) +M:: x86.64 %box-large-struct ( dst n c-type -- ) ! Struct size is parameter 2 - param-reg-1 swap heap-size MOV + param-reg-1 c-type heap-size MOV ! Compute destination address - param-reg-0 swap struct-return@ LEA + param-reg-0 n struct-return@ LEA param-reg-2 %mov-vm-ptr ! Copy the struct from the C stack - "from_value_struct" f %alien-invoke ; + "from_value_struct" f %alien-invoke + dst RAX tagged-rep %copy ; M: x86.64 %prepare-box-struct ( -- ) ! Compute target address for value struct return @@ -217,22 +218,13 @@ M: x86.64 %prepare-box-struct ( -- ) ! Store it as the first parameter 0 param@ RAX MOV ; -M: x86.64 %prepare-var-args RAX RAX XOR ; - M: x86.64 %alien-invoke R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ; -M: x86.64 %prepare-alien-indirect ( -- ) - param-reg-0 ds-reg [] MOV - ds-reg 8 SUB - param-reg-1 %mov-vm-ptr - "pinned_alien_offset" f %alien-invoke - nv-reg RAX MOV ; - -M: x86.64 %alien-indirect ( -- ) - nv-reg CALL ; +M: x86.64 %alien-indirect ( src -- ) + ?spill-slot CALL ; M: x86.64 %begin-callback ( -- ) param-reg-0 %mov-vm-ptr @@ -249,10 +241,6 @@ M: x86.64 %end-callback ( -- ) param-reg-0 %mov-vm-ptr "end_callback" f %alien-invoke ; -M: x86.64 %to-nv ( -- ) nv-reg param-reg-0 MOV ; - -M: x86.64 %from-nv ( -- ) param-reg-0 nv-reg MOV ; - : float-function-param ( i src -- ) [ float-regs cdecl param-regs nth ] dip double-rep %copy ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index aa802c76fc..de39c233c9 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -180,9 +180,11 @@ M: object copy-memory* copy-register* ; M: float-rep copy-memory* drop MOVSS ; M: double-rep copy-memory* drop MOVSD ; +: ?spill-slot ( obj -- obj ) dup spill-slot? [ n>> spill@ ] when ; + M: x86 %copy ( dst src rep -- ) 2over eq? [ 3drop ] [ - [ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip + [ [ ?spill-slot ] bi@ ] dip 2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if ] if ; @@ -502,15 +504,11 @@ M:: x86 %check-nursery-branch ( label size cc temp1 temp2 -- ) M: x86 %alien-global ( dst symbol library -- ) [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ; -M: x86 %push-stack ( -- ) - ds-reg cell ADD - ds-reg [] int-regs return-reg MOV ; - -M: x86 %push-context-stack ( -- ) - temp-reg %context - temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD - temp-reg temp-reg "datastack" context-field-offset [+] MOV - temp-reg [] int-regs return-reg MOV ; +M:: x86 %push-context-stack ( src temp -- ) + temp %context + temp "datastack" context-field-offset [+] bootstrap-cell ADD + temp temp "datastack" context-field-offset [+] MOV + temp [] src MOV ; M: x86 %epilogue ( n -- ) cell - incr-stack-reg ; diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index 1c6b37b7df..1a14ea4297 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -20,9 +20,6 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; : param-prep-quot ( params -- quot ) parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ; -: infer-params ( params -- ) - param-prep-quot infer-quot-here ; - : alien-stack ( params extra -- ) over parameters>> length + consume-d >>in-d dup return>> void? 0 1 ? produce-d >>out-d @@ -62,7 +59,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; ! Set ABI dup library>> library-abi >>abi ! Quotation which coerces parameters to required types - dup infer-params + dup param-prep-quot infer-quot-here ! Magic #: consume exactly the number of inputs dup 0 alien-stack ! Add node to IR @@ -76,10 +73,8 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; pop-abi pop-params pop-return - ! Quotation which coerces parameters to required types - 1 infer->r - dup infer-params - 1 infer-r> + ! Coerce parameters to required types + dup param-prep-quot '[ _ [ >c-ptr ] bi* ] infer-quot-here ! Magic #: consume the function pointer, too dup 1 alien-stack ! Add node to IR @@ -95,7 +90,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; pop-params pop-return ! Quotation which coerces parameters to required types - dup infer-params + dup param-prep-quot infer-quot-here ! Magic #: consume exactly the number of inputs dup 0 alien-stack ! Add node to IR From 7450dcf9ff56ff234fbd5c9e1c4752536431b62c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 9 May 2010 23:36:57 -0400 Subject: [PATCH 08/14] cpu.x86.32: fix load error --- basis/cpu/x86/32/32.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 9734ea5dd3..42c2a67e9d 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -160,8 +160,8 @@ M:: x86.32 %box ( dst n rep func -- ) : (%box-long-long) ( n -- ) [ - EDX over next-stack@ MOV - EAX swap cell - next-stack@ MOV + [ EDX swap next-stack@ MOV ] + [ EAX swap cell - next-stack@ MOV ] bi ] when* ; M:: x86.32 %box-long-long ( dst n func -- ) @@ -186,10 +186,10 @@ M: x86.32 %prepare-box-struct ( -- ) ! Store it as the first parameter 0 local@ EAX MOV ; -M: x86.32 %box-small-struct ( dst c-type -- ) +M:: x86.32 %box-small-struct ( dst c-type -- ) #! Box a <= 8-byte struct returned in EAX:EDX. OS X only. 12 save-vm-ptr - 8 stack@ swap heap-size MOV + 8 stack@ c-type heap-size MOV 4 stack@ EDX MOV 0 stack@ EAX MOV "from_small_struct" f %alien-invoke @@ -201,11 +201,11 @@ M:: x86.32 %pop-context-stack ( dst temp -- ) dst dst [] MOV temp "datastack" context-field-offset [+] bootstrap-cell SUB ; -: call-unbox-func ( src func -- ) +:: call-unbox-func ( src func -- ) EAX src tagged-rep %copy 4 save-vm-ptr 0 stack@ EAX MOV - f %alien-invoke ; + func f %alien-invoke ; M:: x86.32 %unbox ( src n rep func -- ) ! If n is f, we're unboxing a return value about to be @@ -216,9 +216,9 @@ M:: x86.32 %unbox ( src n rep func -- ) n [ n local@ rep store-return-reg ] when ; M:: x86.32 %unbox-long-long ( src n func -- ) - call-unbox-func + src func call-unbox-func ! Store the return value on the C stack - [ + n [ [ local@ EAX MOV ] [ 4 + local@ EDX MOV ] bi ] when* ; From 73ff8ffed11bf495a91fc579988355a910707cfa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 10 May 2010 00:24:13 -0400 Subject: [PATCH 09/14] compiler.graphviz: fix load error --- extra/compiler/graphviz/graphviz.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/compiler/graphviz/graphviz.factor b/extra/compiler/graphviz/graphviz.factor index 79a72b33ea..3e9dbc2849 100644 --- a/extra/compiler/graphviz/graphviz.factor +++ b/extra/compiler/graphviz/graphviz.factor @@ -58,7 +58,7 @@ IN: compiler.graphviz : cfg-vertex, ( bb -- ) [ number>> number>string ] - [ kill-block? { "color=grey" "style=filled" } { } ? ] + [ kill-block?>> { "color=grey" "style=filled" } { } ? ] bi node-style, ; : cfgs ( cfgs -- ) From acfbea386589431f1af4b55cad4a8251d62fb3af Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 10 May 2010 00:42:03 -0400 Subject: [PATCH 10/14] compiler.codegen.fixup: remove unused variable --- basis/compiler/codegen/codegen-tests.factor | 14 +++++++------- basis/compiler/codegen/codegen.factor | 2 +- basis/compiler/codegen/fixup/fixup.factor | 8 ++------ 3 files changed, 10 insertions(+), 14 deletions(-) diff --git a/basis/compiler/codegen/codegen-tests.factor b/basis/compiler/codegen/codegen-tests.factor index 43473ebcbb..a02462dc08 100644 --- a/basis/compiler/codegen/codegen-tests.factor +++ b/basis/compiler/codegen/codegen-tests.factor @@ -2,13 +2,13 @@ USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make compiler.constants words ; IN: compiler.codegen.tests -[ ] [ gensym [ ] with-fixup drop ] unit-test -[ ] [ gensym [ \ + %call ] with-fixup drop ] unit-test +[ ] [ [ ] with-fixup drop ] unit-test +[ ] [ [ \ + %call ] with-fixup drop ] unit-test -[ ] [ gensym [