]> gitweb.factorcode.org Git - factor.git/commitdiff
Split up compiler.codegen.fixup into compiler.codegen.{gc-maps,labels,relocation}
authorSlava Pestov <slava@factorcode.org>
Wed, 14 Sep 2011 04:38:03 +0000 (21:38 -0700)
committerSlava Pestov <slava@factorcode.org>
Mon, 3 Oct 2011 07:25:47 +0000 (00:25 -0700)
20 files changed:
basis/compiler/codegen/codegen-tests.factor
basis/compiler/codegen/codegen.factor
basis/compiler/codegen/fixup/authors.txt [deleted file]
basis/compiler/codegen/fixup/fixup-tests.factor [deleted file]
basis/compiler/codegen/fixup/fixup.factor [deleted file]
basis/compiler/codegen/fixup/summary.txt [deleted file]
basis/compiler/codegen/gc-maps/authors.txt [new file with mode: 0644]
basis/compiler/codegen/gc-maps/gc-maps-tests.factor [new file with mode: 0644]
basis/compiler/codegen/gc-maps/gc-maps.factor [new file with mode: 0644]
basis/compiler/codegen/labels/authors.txt [new file with mode: 0644]
basis/compiler/codegen/labels/labels.factor [new file with mode: 0644]
basis/compiler/codegen/labels/summary.txt [new file with mode: 0644]
basis/compiler/codegen/relocation/authors.txt [new file with mode: 0644]
basis/compiler/codegen/relocation/relocation.factor [new file with mode: 0644]
basis/cpu/x86/32/32.factor
basis/cpu/x86/64/64.factor
basis/cpu/x86/features/features.factor
basis/cpu/x86/sse/sse.factor
basis/cpu/x86/x86.factor
basis/cpu/x86/x87/x87.factor

index a02462dc084a8c30ae34cf0a91f789c8460ddd53..c81164bff2278c43fd98f1c48c38fcd72d7da734 100644 (file)
@@ -1,5 +1,6 @@
-USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
-compiler.constants words ;
+USING: compiler.codegen compiler.codegen.labels
+compiler.codegen.relocation tools.test cpu.architecture math
+kernel make compiler.constants words ;
 IN: compiler.codegen.tests
 
 [ ] [ [ ] with-fixup drop ] unit-test
index 6e7e2e0fabe153303bc448a40664dc1ad6231107..69fd37abb8f9284ad6f01fd5ae72c212b798f9bb 100755 (executable)
@@ -1,10 +1,10 @@
-! Copyright (C) 2008, 2010 Slava Pestov.
+! Copyright (C) 2008, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces make math math.order math.parser sequences
-accessors kernel layouts assocs words summary arrays combinators
-classes.algebra sets continuations.private fry cpu.architecture
-classes classes.struct locals slots parser generic.parser
-strings quotations hashtables
+USING: byte-arrays namespaces make math math.order math.parser
+sequences accessors kernel layouts assocs words summary arrays
+combinators combinators.smart sets continuations.private fry
+cpu.architecture classes classes.struct locals slots parser
+generic.parser strings quotations hashtables
 compiler.constants
 compiler.cfg
 compiler.cfg.linearization
@@ -13,7 +13,9 @@ compiler.cfg.comparisons
 compiler.cfg.stack-frame
 compiler.cfg.registers
 compiler.cfg.builder
-compiler.codegen.fixup
+compiler.codegen.gc-maps
+compiler.codegen.labels
+compiler.codegen.relocation
 compiler.utilities ;
 FROM: namespaces => set ;
 IN: compiler.codegen
@@ -81,6 +83,31 @@ M: ##dispatch generate-insn
         ] each
     ] tri ;
 
+: init-fixup ( -- )
+    V{ } clone label-table set
+    V{ } clone binary-literal-table set ;
+
+: check-fixup ( seq -- )
+    length data-alignment get mod 0 assert= ;
+
+: with-fixup ( quot -- code )
+    '[
+        init-relocation
+        init-gc-maps
+        init-fixup
+        [
+            @
+            emit-binary-literals
+            emit-gc-maps
+            label-table [ compute-labels ] change
+            parameter-table get >array
+            literal-table get >array
+            relocation-table get >byte-array
+            label-table get
+        ] B{ } make
+        dup check-fixup
+    ] output>array ; inline
+
 : generate ( cfg -- code )
     [
         H{ } clone labels set
diff --git a/basis/compiler/codegen/fixup/authors.txt b/basis/compiler/codegen/fixup/authors.txt
deleted file mode 100644 (file)
index 1901f27..0000000
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/compiler/codegen/fixup/fixup-tests.factor b/basis/compiler/codegen/fixup/fixup-tests.factor
deleted file mode 100644 (file)
index 70dcdf8..0000000
+++ /dev/null
@@ -1,77 +0,0 @@
-USING: namespaces byte-arrays make compiler.codegen.fixup
-bit-arrays accessors classes.struct tools.test kernel math
-sequences alien.c-types specialized-arrays boxes
-compiler.cfg.instructions system cpu.architecture ;
-SPECIALIZED-ARRAY: uint
-IN: compiler.codegen.fixup.tests
-
-STRUCT: gc-info
-{ scrub-d-count uint }
-{ scrub-r-count uint }
-{ gc-root-count uint }
-{ derived-root-count uint }
-{ return-address-count uint } ;
-
-SINGLETON: fake-cpu
-
-fake-cpu \ cpu set
-
-M: fake-cpu gc-root-offset ;
-
-[ ] [
-    [
-        init-fixup
-
-        50 <byte-array> %
-
-        T{ gc-map f B{ } B{ } V{ } } gc-map-here
-
-        50 <byte-array> %
-
-        T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } V{ { 2 4 } } } gc-map-here
-
-        emit-gc-info
-    ] B{ } make
-    "result" set
-] unit-test
-
-[ 0 ] [ "result" get length 16 mod ] unit-test
-
-[ ] [
-    [
-        100 <byte-array> %
-
-        ! The below data is 22 bytes -- 6 bytes padding needed to
-        ! align
-        6 <byte-array> %
-
-        ! Bitmap - 2 bytes
-        ?{
-            ! scrub-d
-            t f f f t
-            ! scrub-r
-            f t
-            ! gc-roots
-            f t f t
-        } underlying>> %
-
-        ! Derived pointers
-        uint-array{ -1 -1 4 } underlying>> %
-
-        ! Return addresses
-        uint-array{ 100 } underlying>> %
-
-        ! GC info footer - 16 bytes
-        S{ gc-info
-            { scrub-d-count 5 }
-            { scrub-r-count 2 }
-            { gc-root-count 4 }
-            { derived-root-count 3 }
-            { return-address-count 1 }
-        } (underlying)>> %
-    ] B{ } make
-    "expect" set
-] unit-test
-
-[ ] [ "result" get length "expect" get length assert= ] unit-test
-[ ] [ "result" get "expect" get assert= ] unit-test
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
deleted file mode 100644 (file)
index af59ca2..0000000
+++ /dev/null
@@ -1,275 +0,0 @@
-! Copyright (C) 2007, 2010 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays bit-arrays byte-arrays byte-vectors generic assocs
-hashtables io.binary kernel kernel.private math namespaces make
-sequences words quotations strings sorting alien.accessors
-alien.strings layouts system combinators math.bitwise math.order
-combinators.short-circuit combinators.smart accessors growable
-fry memoize compiler.constants compiler.cfg.instructions
-cpu.architecture ;
-IN: compiler.codegen.fixup
-
-! Utilities
-: push-uint ( value vector -- )
-    [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
-    swap set-alien-unsigned-4 ;
-
-! Parameter table
-SYMBOL: parameter-table
-
-: add-parameter ( obj -- ) parameter-table get push ;
-
-! Literal table
-SYMBOL: literal-table
-
-: add-literal ( obj -- ) literal-table get push ;
-
-! Labels
-SYMBOL: label-table
-
-TUPLE: label offset ;
-
-: <label> ( -- label ) label new ;
-: define-label ( name -- ) <label> swap set ;
-
-: compiled-offset ( -- n ) building get length ;
-
-: resolve-label ( label/name -- )
-    dup label? [ get ] unless
-    compiled-offset >>offset drop ;
-
-TUPLE: label-fixup { label label } { class integer } { offset integer } ;
-
-: label-fixup ( label class -- )
-    compiled-offset \ label-fixup boa label-table get push ;
-
-! Relocation table
-SYMBOL: relocation-table
-
-: add-relocation-entry ( type class offset -- )
-    { 0 24 28 } bitfield relocation-table get push-uint ;
-
-: rel-fixup ( class type -- )
-    swap compiled-offset add-relocation-entry ;
-
-! Binary literal table
-SYMBOL: binary-literal-table
-
-: add-binary-literal ( obj -- label )
-    <label> [ 2array binary-literal-table get push ] keep ;
-
-! Caching common symbol names reduces image size a bit
-MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
-
-: add-dlsym-parameters ( symbol dll -- )
-    [ cached-string>symbol add-parameter ] [ add-parameter ] bi* ;
-
-: rel-dlsym ( name dll class -- )
-    [ add-dlsym-parameters ] dip rt-dlsym rel-fixup ;
-
-: rel-dlsym-toc ( name dll class -- )
-    [ add-dlsym-parameters ] dip rt-dlsym-toc rel-fixup ;
-
-: rel-word ( word class -- )
-    [ add-literal ] dip rt-entry-point rel-fixup ;
-
-: rel-word-pic ( word class -- )
-    [ add-literal ] dip rt-entry-point-pic rel-fixup ;
-
-: rel-word-pic-tail ( word class -- )
-    [ add-literal ] dip rt-entry-point-pic-tail rel-fixup ;
-
-: rel-literal ( literal class -- )
-    [ add-literal ] dip rt-literal rel-fixup ;
-
-: rel-binary-literal ( literal class -- )
-    [ add-binary-literal ] dip label-fixup ;
-
-: rel-this ( class -- )
-    rt-this rel-fixup ;
-
-: rel-here ( offset class -- )
-    [ add-literal ] dip rt-here rel-fixup ;
-
-: rel-vm ( offset class -- )
-    [ add-parameter ] dip rt-vm rel-fixup ;
-
-: rel-cards-offset ( class -- )
-    rt-cards-offset rel-fixup ;
-
-: rel-decks-offset ( class -- )
-    rt-decks-offset rel-fixup ;
-
-! Labels
-: compute-target ( label-fixup -- offset )
-    label>> offset>> [ "Unresolved label" throw ] unless* ;
-
-: compute-relative-label ( label-fixup -- label )
-    [ class>> ] [ offset>> ] [ compute-target ] tri 3array ;
-
-: compute-absolute-label ( label-fixup -- )
-    [ compute-target neg add-literal ]
-    [ [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ] bi ;
-
-: compute-labels ( label-fixups -- labels' )
-    [ class>> rc-absolute? ] partition
-    [ [ compute-absolute-label ] each ]
-    [ [ compute-relative-label ] map concat ]
-    bi* ;
-
-! Binary literals
-: alignment ( align -- n )
-    [ compiled-offset dup ] dip align swap - ;
-
-: (align-code) ( n -- )
-    0 <repetition> % ;
-
-: align-code ( n -- )
-    alignment (align-code) ;
-
-: emit-data ( obj label -- )
-    over length align-code
-    resolve-label
-    building get push-all ;
-
-: emit-binary-literals ( -- )
-    binary-literal-table get [ emit-data ] assoc-each ;
-
-! GC info
-
-! Every code block either ends with
-!
-! uint 0
-!
-! or
-!
-! bitmap, byte aligned, three subsequences:
-! - <scrubbed data stack locations>
-! - <scrubbed retain stack locations>
-! - <GC root spill slots>
-! uint[] <base pointers>
-! uint[] <return addresses>
-! uint <largest scrubbed data stack location>
-! uint <largest scrubbed retain stack location>
-! uint <largest GC root spill slot>
-! uint <largest derived root spill slot>
-! int <number of return addresses>
-!
-SYMBOLS: return-addresses gc-maps ;
-
-: gc-map-needed? ( gc-map -- ? )
-    ! If there are no stack locations to scrub and no GC roots,
-    ! there's no point storing the GC map.
-    dup [
-        {
-            [ scrub-d>> empty? ]
-            [ scrub-r>> empty? ]
-            [ gc-roots>> empty? ]
-            [ derived-roots>> empty? ]
-        } 1&& not
-    ] when ;
-
-: gc-map-here ( gc-map -- )
-    dup gc-map-needed? [
-        gc-maps get push
-        compiled-offset return-addresses get push
-    ] [ drop ] if ;
-
-: longest ( seqs -- n )
-    [ length ] [ max ] map-reduce ;
-
-: emit-scrub ( seqs -- n )
-    ! seqs is a sequence of sequences of 0/1
-    dup longest
-    [ '[ [ 0 = ] ?{ } map-as _ f pad-tail % ] each ] keep ;
-
-: integers>bits ( seq n -- bit-array )
-    <bit-array> [ '[ [ t ] dip _ set-nth ] each ] keep ;
-
-: largest-spill-slot ( seqs -- n )
-    [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce ;
-
-: emit-gc-roots ( seqs -- n )
-    ! seqs is a sequence of sequences of integers 0..n-1
-    dup largest-spill-slot
-    [ '[ _ integers>bits % ] each ] keep ;
-
-: emit-uint ( n -- )
-    building get push-uint ;
-
-: emit-uints ( n -- )
-    [ emit-uint ] each ;
-
-: gc-root-offsets ( gc-map -- offsets )
-    gc-roots>> [ gc-root-offset ] map ;
-
-: emit-gc-info-bitmaps ( -- scrub-d-count scrub-r-count gc-root-count )
-    [
-        gc-maps get {
-            [ [ scrub-d>> ] map emit-scrub ]
-            [ [ scrub-r>> ] map emit-scrub ]
-            [ [ gc-root-offsets ] map emit-gc-roots ]
-        } cleave
-    ] ?{ } make underlying>> % ;
-
-: emit-base-table ( alist longest -- )
-    -1 <array> <enum> swap assoc-union! seq>> emit-uints ;
-
-: derived-root-offsets ( gc-map -- offsets )
-    derived-roots>> [ [ gc-root-offset ] bi@ ] assoc-map ;
-
-: emit-base-tables ( -- count )
-    gc-maps get [ derived-root-offsets ] map
-    dup [ keys ] map largest-spill-slot
-    [ '[ _ emit-base-table ] each ] keep ;
-
-: emit-return-addresses ( -- )
-    return-addresses get emit-uints ;
-
-: gc-info ( -- byte-array )
-    [
-        return-addresses get empty? [ 0 emit-uint ] [
-            emit-gc-info-bitmaps
-            emit-base-tables
-            emit-return-addresses
-            4array emit-uints
-            return-addresses get length emit-uint
-        ] if
-    ] B{ } make ;
-
-: emit-gc-info ( -- )
-    ! We want to place the GC info so that the end is aligned
-    ! on a 16-byte boundary.
-    gc-info [
-        length compiled-offset +
-        [ data-alignment get align ] keep -
-        (align-code)
-    ] [ % ] bi ;
-
-: init-fixup ( -- )
-    V{ } clone parameter-table set
-    V{ } clone literal-table set
-    V{ } clone label-table set
-    BV{ } clone relocation-table set
-    V{ } clone binary-literal-table set
-    V{ } clone return-addresses set
-    V{ } clone gc-maps set ;
-
-: check-fixup ( seq -- )
-    length data-alignment get mod 0 assert= ;
-
-: with-fixup ( quot -- code )
-    '[
-        init-fixup
-        [
-            @
-            emit-binary-literals
-            emit-gc-info
-            label-table [ compute-labels ] change
-            parameter-table get >array
-            literal-table get >array
-            relocation-table get >byte-array
-            label-table get
-        ] B{ } make
-        dup check-fixup
-    ] output>array ; inline
diff --git a/basis/compiler/codegen/fixup/summary.txt b/basis/compiler/codegen/fixup/summary.txt
deleted file mode 100644 (file)
index ce83e6d..0000000
+++ /dev/null
@@ -1 +0,0 @@
-Support for generation of relocatable code
diff --git a/basis/compiler/codegen/gc-maps/authors.txt b/basis/compiler/codegen/gc-maps/authors.txt
new file mode 100644 (file)
index 0000000..1901f27
--- /dev/null
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/codegen/gc-maps/gc-maps-tests.factor b/basis/compiler/codegen/gc-maps/gc-maps-tests.factor
new file mode 100644 (file)
index 0000000..ae0e437
--- /dev/null
@@ -0,0 +1,77 @@
+USING: namespaces byte-arrays make compiler.codegen.gc-maps
+bit-arrays accessors classes.struct tools.test kernel math
+sequences alien.c-types specialized-arrays boxes
+compiler.cfg.instructions system cpu.architecture ;
+SPECIALIZED-ARRAY: uint
+IN: compiler.codegen.gc-maps.tests
+
+STRUCT: gc-info
+{ scrub-d-count uint }
+{ scrub-r-count uint }
+{ gc-root-count uint }
+{ derived-root-count uint }
+{ return-address-count uint } ;
+
+SINGLETON: fake-cpu
+
+fake-cpu \ cpu set
+
+M: fake-cpu gc-root-offset ;
+
+[ ] [
+    [
+        init-gc-maps
+
+        50 <byte-array> %
+
+        T{ gc-map f B{ } B{ } V{ } } gc-map-here
+
+        50 <byte-array> %
+
+        T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } V{ { 2 4 } } } gc-map-here
+
+        emit-gc-maps
+    ] B{ } make
+    "result" set
+] unit-test
+
+[ 0 ] [ "result" get length 16 mod ] unit-test
+
+[ ] [
+    [
+        100 <byte-array> %
+
+        ! The below data is 22 bytes -- 6 bytes padding needed to
+        ! align
+        6 <byte-array> %
+
+        ! Bitmap - 2 bytes
+        ?{
+            ! scrub-d
+            t f f f t
+            ! scrub-r
+            f t
+            ! gc-roots
+            f t f t
+        } underlying>> %
+
+        ! Derived pointers
+        uint-array{ -1 -1 4 } underlying>> %
+
+        ! Return addresses
+        uint-array{ 100 } underlying>> %
+
+        ! GC info footer - 16 bytes
+        S{ gc-info
+            { scrub-d-count 5 }
+            { scrub-r-count 2 }
+            { gc-root-count 4 }
+            { derived-root-count 3 }
+            { return-address-count 1 }
+        } (underlying)>> %
+    ] B{ } make
+    "expect" set
+] unit-test
+
+[ ] [ "result" get length "expect" get length assert= ] unit-test
+[ ] [ "result" get "expect" get assert= ] unit-test
diff --git a/basis/compiler/codegen/gc-maps/gc-maps.factor b/basis/compiler/codegen/gc-maps/gc-maps.factor
new file mode 100644 (file)
index 0000000..1f12b7a
--- /dev/null
@@ -0,0 +1,122 @@
+! Copyright (C) 2011 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs bit-arrays combinators
+combinators.short-circuit compiler.cfg.instructions
+compiler.codegen.relocation cpu.architecture fry kernel layouts
+make math math.order namespaces sequences ;
+IN: compiler.codegen.gc-maps
+
+! GC maps                                                       
+
+! Every code block either ends with
+!
+! uint 0
+!
+! or
+!
+! bitmap, byte aligned, three subsequences:
+! - <scrubbed data stack locations>
+! - <scrubbed retain stack locations>
+! - <GC root spill slots>
+! uint[] <base pointers>
+! uint[] <return addresses>
+! uint <largest scrubbed data stack location>
+! uint <largest scrubbed retain stack location>
+! uint <largest GC root spill slot>
+! uint <largest derived root spill slot>
+! int <number of return addresses>
+
+SYMBOLS: return-addresses gc-maps ;
+
+: gc-map-needed? ( gc-map -- ? )
+    ! If there are no stack locations to scrub and no GC roots,
+    ! there's no point storing the GC map.
+    dup [
+        {
+            [ scrub-d>> empty? ]
+            [ scrub-r>> empty? ]
+            [ gc-roots>> empty? ]
+            [ derived-roots>> empty? ]
+        } 1&& not
+    ] when ;
+
+: gc-map-here ( gc-map -- )
+    dup gc-map-needed? [
+        gc-maps get push
+        compiled-offset return-addresses get push
+    ] [ drop ] if ;
+
+: longest ( seqs -- n )
+    [ length ] [ max ] map-reduce ;
+
+: emit-scrub ( seqs -- n )
+    ! seqs is a sequence of sequences of 0/1
+    dup longest
+    [ '[ [ 0 = ] ?{ } map-as _ f pad-tail % ] each ] keep ;
+
+: integers>bits ( seq n -- bit-array )
+    <bit-array> [ '[ [ t ] dip _ set-nth ] each ] keep ;
+
+: largest-spill-slot ( seqs -- n )
+    [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce ;
+
+: emit-gc-roots ( seqs -- n )
+    ! seqs is a sequence of sequences of integers 0..n-1
+    dup largest-spill-slot
+    [ '[ _ integers>bits % ] each ] keep ;
+
+: emit-uint ( n -- )
+    building get push-uint ;
+
+: emit-uints ( n -- )
+    [ emit-uint ] each ;
+
+: gc-root-offsets ( gc-map -- offsets )
+    gc-roots>> [ gc-root-offset ] map ;
+
+: emit-gc-info-bitmaps ( -- scrub-d-count scrub-r-count gc-root-count )
+    [
+        gc-maps get {
+            [ [ scrub-d>> ] map emit-scrub ]
+            [ [ scrub-r>> ] map emit-scrub ]
+            [ [ gc-root-offsets ] map emit-gc-roots ]
+        } cleave
+    ] ?{ } make underlying>> % ;
+
+: emit-base-table ( alist longest -- )
+    -1 <array> <enum> swap assoc-union! seq>> emit-uints ;
+
+: derived-root-offsets ( gc-map -- offsets )
+    derived-roots>> [ [ gc-root-offset ] bi@ ] assoc-map ;
+
+: emit-base-tables ( -- count )
+    gc-maps get [ derived-root-offsets ] map
+    dup [ keys ] map largest-spill-slot
+    [ '[ _ emit-base-table ] each ] keep ;
+
+: emit-return-addresses ( -- )
+    return-addresses get emit-uints ;
+
+: serialize-gc-maps ( -- byte-array )
+    [
+        return-addresses get empty? [ 0 emit-uint ] [
+            emit-gc-info-bitmaps
+            emit-base-tables
+            emit-return-addresses
+            4array emit-uints
+            return-addresses get length emit-uint
+        ] if
+    ] B{ } make ;
+
+: init-gc-maps ( -- )
+    V{ } clone return-addresses set
+    V{ } clone gc-maps set ;
+
+: emit-gc-maps ( -- )
+    ! We want to place the GC maps so that the end is aligned
+    ! on a 16-byte boundary.
+    serialize-gc-maps [
+        length compiled-offset +
+        [ data-alignment get align ] keep -
+        (align-code)
+    ] [ % ] bi ;
diff --git a/basis/compiler/codegen/labels/authors.txt b/basis/compiler/codegen/labels/authors.txt
new file mode 100644 (file)
index 0000000..1901f27
--- /dev/null
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/codegen/labels/labels.factor b/basis/compiler/codegen/labels/labels.factor
new file mode 100644 (file)
index 0000000..c3eacfd
--- /dev/null
@@ -0,0 +1,55 @@
+! Copyright (C) 2007, 2011 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs compiler.codegen.relocation
+compiler.constants kernel make math namespaces sequences ;
+IN: compiler.codegen.labels
+
+! Labels
+SYMBOL: label-table
+
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+: define-label ( name -- ) <label> swap set ;
+
+: resolve-label ( label/name -- )
+    dup label? [ get ] unless
+    compiled-offset >>offset drop ;
+
+TUPLE: label-fixup { label label } { class integer } { offset integer } ;
+
+: label-fixup ( label class -- )
+    compiled-offset \ label-fixup boa label-table get push ;
+
+: compute-target ( label-fixup -- offset )
+    label>> offset>> [ "Unresolved label" throw ] unless* ;
+
+: compute-relative-label ( label-fixup -- label )
+    [ class>> ] [ offset>> ] [ compute-target ] tri 3array ;
+
+: compute-absolute-label ( label-fixup -- )
+    [ compute-target neg add-literal ]
+    [ [ class>> rt-here ] [ offset>> ] bi add-relocation-at ] bi ;
+
+: compute-labels ( label-fixups -- labels' )
+    [ class>> rc-absolute? ] partition
+    [ [ compute-absolute-label ] each ]
+    [ [ compute-relative-label ] map concat ]
+    bi* ;
+
+! Binary literals
+SYMBOL: binary-literal-table
+
+: add-binary-literal ( obj -- label )
+    <label> [ 2array binary-literal-table get push ] keep ;
+
+: rel-binary-literal ( literal class -- )
+    [ add-binary-literal ] dip label-fixup ;
+
+: emit-data ( obj label -- )
+    over length align-code
+    resolve-label
+    building get push-all ;
+
+: emit-binary-literals ( -- )
+    binary-literal-table get [ emit-data ] assoc-each ;
diff --git a/basis/compiler/codegen/labels/summary.txt b/basis/compiler/codegen/labels/summary.txt
new file mode 100644 (file)
index 0000000..ce83e6d
--- /dev/null
@@ -0,0 +1 @@
+Support for generation of relocatable code
diff --git a/basis/compiler/codegen/relocation/authors.txt b/basis/compiler/codegen/relocation/authors.txt
new file mode 100644 (file)
index 0000000..1901f27
--- /dev/null
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/codegen/relocation/relocation.factor b/basis/compiler/codegen/relocation/relocation.factor
new file mode 100644 (file)
index 0000000..2baaaa5
--- /dev/null
@@ -0,0 +1,90 @@
+! Copyright (C) 2011 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.accessors alien.strings
+compiler.constants kernel make math math.bitwise memoize
+namespaces sequences ;
+IN: compiler.codegen.relocation
+
+! Common code shared by optimizing and non-optimizing compilers.
+! Should not have too many dependencies on the rest of the
+! optimizing compiler.
+
+! Code is compiled into the 'make' vector.
+
+: compiled-offset ( -- n ) building get length ;
+
+: alignment ( align -- n )
+    [ compiled-offset dup ] dip align swap - ;
+
+: (align-code) ( n -- )
+    0 <repetition> % ;
+
+: align-code ( n -- )
+    alignment (align-code) ;
+
+! Parameter table
+SYMBOL: parameter-table
+
+: add-parameter ( obj -- ) parameter-table get push ;
+
+! Literal table
+SYMBOL: literal-table
+
+: add-literal ( obj -- ) literal-table get push ;
+
+! Relocation table
+SYMBOL: relocation-table
+
+: push-uint ( value vector -- )
+    [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
+    swap set-alien-unsigned-4 ;
+
+: add-relocation-at ( class type offset -- )
+    { 0 28 24 } bitfield relocation-table get push-uint ;
+
+: add-relocation ( class type -- )
+    compiled-offset add-relocation-at ;
+
+! Caching common symbol names reduces image size a bit
+MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
+
+: add-dlsym-parameters ( symbol dll -- )
+    [ cached-string>symbol add-parameter ] [ add-parameter ] bi* ;
+
+: rel-dlsym ( name dll class -- )
+    [ add-dlsym-parameters ] dip rt-dlsym add-relocation ;
+
+: rel-dlsym-toc ( name dll class -- )
+    [ add-dlsym-parameters ] dip rt-dlsym-toc add-relocation ;
+
+: rel-word ( word class -- )
+    [ add-literal ] dip rt-entry-point add-relocation ;
+
+: rel-word-pic ( word class -- )
+    [ add-literal ] dip rt-entry-point-pic add-relocation ;
+
+: rel-word-pic-tail ( word class -- )
+    [ add-literal ] dip rt-entry-point-pic-tail add-relocation ;
+
+: rel-literal ( literal class -- )
+    [ add-literal ] dip rt-literal add-relocation ;
+
+: rel-this ( class -- )
+    rt-this add-relocation ;
+
+: rel-here ( offset class -- )
+    [ add-literal ] dip rt-here add-relocation ;
+
+: rel-vm ( offset class -- )
+    [ add-parameter ] dip rt-vm add-relocation ;
+
+: rel-cards-offset ( class -- )
+    rt-cards-offset add-relocation ;
+
+: rel-decks-offset ( class -- )
+    rt-decks-offset add-relocation ;
+
+: init-relocation ( -- )
+    V{ } clone parameter-table set
+    V{ } clone literal-table set
+    BV{ } clone relocation-table set ;
index b1f96726e8154f52dfd40d1fc8543f2c0b8dfaa7..b177a8ed31594f5db32c280c9f345f3fe558167a 100755 (executable)
@@ -1,9 +1,10 @@
-! Copyright (C) 2005, 2010 Slava Pestov.
+! Copyright (C) 2005, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: locals alien alien.c-types alien.libraries alien.syntax
 arrays kernel fry math namespaces sequences system layouts io
 vocabs.loader accessors init classes.struct combinators make
-words compiler.constants compiler.codegen.fixup
+words compiler.constants compiler.codegen.gc-maps
+compiler.codegen.labels compiler.codegen.relocation
 compiler.cfg.instructions compiler.cfg.builder
 compiler.cfg.builder.alien.boxing compiler.cfg.intrinsics
 compiler.cfg.stack-frame cpu.x86.assembler
index e7582e627cc334f418f17c72ce7713f850b305d3..b675107bce4e0991091b999a0bae99efb27ed6c5 100644 (file)
@@ -1,13 +1,14 @@
-! Copyright (C) 2005, 2010 Slava Pestov.
+! Copyright (C) 2005, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel math namespaces make sequences
-system layouts alien alien.c-types alien.accessors alien.libraries
-slots splitting assocs combinators fry locals compiler.constants
-classes.struct compiler.codegen compiler.codegen.fixup
-compiler.cfg.instructions compiler.cfg.builder
-compiler.cfg.intrinsics compiler.cfg.stack-frame
-cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
-cpu.architecture vm ;
+system layouts alien alien.c-types alien.accessors
+alien.libraries slots splitting assocs combinators fry locals
+compiler.constants classes.struct compiler.codegen
+compiler.codegen.gc-maps compiler.codegen.labels
+compiler.codegen.relocation compiler.cfg.instructions
+compiler.cfg.builder compiler.cfg.intrinsics
+compiler.cfg.stack-frame cpu.x86.assembler
+cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ;
 FROM: layouts => cell cells ;
 IN: cpu.x86.64
 
index d62429f4f05684eea58082221976b29412fd351a..e333c8c6b5f065a454a2e9d33abd4528a6de8f99 100644 (file)
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs sequences alien alien.c-types
-combinators compiler compiler.codegen.fixup compiler.units
+combinators compiler compiler.codegen.labels compiler.units
 cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands
 init io kernel locals math math.order math.parser memoize
 namespaces system ;
index 0b71681d0d6929ad8197ef5ea85e0f362f5dc80d..f0866cb897707ca1eb264503c71076c4c37aea9e 100644 (file)
@@ -3,8 +3,9 @@
 USING: alien.data arrays assocs combinators fry kernel locals
 macros math math.vectors namespaces quotations sequences system
 compiler.cfg.comparisons compiler.cfg.intrinsics
-compiler.codegen.fixup cpu.architecture cpu.x86
-cpu.x86.assembler cpu.x86.assembler.operands cpu.x86.features ;
+compiler.codegen.labels compiler.codegen.relocation
+cpu.architecture cpu.x86 cpu.x86.assembler
+cpu.x86.assembler.operands cpu.x86.features ;
 QUALIFIED-WITH: alien.c-types c
 IN: cpu.x86.sse
 
index 01a224791c0a9437767608a5361eecb02de42577..b631d2d11c047ab7d6a2a42c2caf38aca4a5a211 100644 (file)
@@ -12,7 +12,9 @@ compiler.cfg.instructions
 compiler.cfg.intrinsics
 compiler.cfg.comparisons
 compiler.cfg.stack-frame
-compiler.codegen.fixup ;
+compiler.codegen.gc-maps
+compiler.codegen.labels
+compiler.codegen.relocation ;
 QUALIFIED-WITH: alien.c-types c
 FROM: layouts => cell ;
 FROM: math => float ;
index 9ba707709bbea05a873843621cd3e1b95cfb8258..739399b5814c3c76fe81375d2893988c64410ca5 100644 (file)
@@ -1,10 +1,10 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types alien.data combinators kernel locals system
-namespaces compiler.codegen.fixup compiler.constants
-compiler.cfg.comparisons compiler.cfg.intrinsics
-cpu.architecture cpu.x86 cpu.x86.assembler
-cpu.x86.assembler.operands ;
+namespaces compiler.codegen.labels compiler.codegen.relocation
+compiler.constants compiler.cfg.comparisons
+compiler.cfg.intrinsics cpu.architecture cpu.x86
+cpu.x86.assembler cpu.x86.assembler.operands ;
 IN: cpu.x86.x87
 
 ! x87 unit is only used if SSE2 is not available.