: ?register ( obj -- operand )
dup vreg? [ register ] when ;
-: generate-insns ( insns -- code )
- [
- [
- dup regs>> registers set
- generate-insn
- ] each
- ] { } make fixup ;
-
TUPLE: asm label code calls ;
SYMBOL: calls
: init-generator ( word -- )
H{ } clone labels set
- V{ } clone literal-table set
V{ } clone calls set
compiling-word set
compiled-stack-traces? [ compiling-word get add-literal ] when ;
-: generate ( mr -- asm )
+: generate-insns ( asm -- code )
[
- [ label>> ]
[ word>> init-generator ]
- [ instructions>> generate-insns ] tri
- calls get
+ [
+ instructions>>
+ [ [ regs>> registers set ] [ generate-insn ] bi ] each
+ ] bi
+ ] with-fixup ;
+
+: generate ( mr -- asm )
+ [
+ [ label>> ] [ generate-insns ] bi calls get
asm boa
] with-scope ;
stack-frame>> total-size>> %epilogue ;
M: _label generate-insn
- id>> lookup-label , ;
+ id>> lookup-label resolve-label ;
M: _branch generate-insn
label>> lookup-label %jump-label ;
io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts
system combinators math.bitwise math.order
-accessors growable cpu.architecture compiler.constants ;
+accessors growable compiler.constants ;
IN: compiler.codegen.fixup
-GENERIC: fixup* ( obj -- )
+! Literal table
+SYMBOL: literal-table
-: compiled-offset ( -- n ) building get length ;
+: add-literal ( obj -- ) literal-table get push ;
-SYMBOL: relocation-table
+! Labels
SYMBOL: label-table
-M: label fixup* compiled-offset >>offset drop ;
+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 ;
: offset-for-class ( class -- n )
rc-absolute-cell = cell 4 ? compiled-offset swap - ;
-TUPLE: label-fixup { label label } { class integer } ;
+TUPLE: label-fixup { label label } { class integer } { offset integer } ;
+
+: label-fixup ( label class -- )
+ dup offset-for-class \ label-fixup boa label-table get push ;
-: label-fixup ( label class -- ) \ label-fixup boa , ;
+! Relocation table
+SYMBOL: relocation-table
: push-4 ( value vector -- )
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
: add-relocation-entry ( type class offset -- )
- { 0 24 28 } bitfield relocation-table get push-4 ;
-
-M: label-fixup fixup*
- [ class>> dup offset-for-class ] [ label>> ] bi
- [ drop [ rt-here ] 2dip add-relocation-entry ]
- [ 3array label-table get push ]
- 3bi ;
-
-TUPLE: rel-fixup { class integer } { type integer } ;
+ { 0 24 28 } bitfield relocation-table get push-4 ;
-: rel-fixup ( class type -- ) \ rel-fixup boa , ;
-
-M: rel-fixup fixup*
- [ type>> ] [ class>> dup offset-for-class ] bi
- add-relocation-entry ;
-
-M: integer fixup* , ;
-
-SYMBOL: literal-table
-
-: add-literal ( obj -- ) literal-table get push ;
+: rel-fixup ( class type -- )
+ swap dup offset-for-class add-relocation-entry ;
: add-dlsym-literals ( symbol dll -- )
[ string>symbol add-literal ] [ add-literal ] bi* ;
: rel-here ( offset class -- )
[ add-literal ] dip rt-here rel-fixup ;
-: init-fixup ( -- )
- BV{ } clone relocation-table set
- V{ } clone label-table set ;
+! And the rest
+: resolve-offset ( label-fixup -- offset )
+ label>> offset>> [ "Unresolved label" throw ] unless* ;
-: resolve-labels ( labels -- labels' )
- [
- first3 offset>>
- [ "Unresolved label" throw ] unless*
- 3array
- ] map concat ;
+: resolve-absolute-label ( label-fixup -- )
+ dup resolve-offset neg add-literal
+ [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
+
+: resolve-relative-label ( label-fixup -- )
+ [ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
+
+: resolve-labels ( label-fixups -- labels' )
+ [ class>> rc-absolute? ] partition
+ [ [ resolve-absolute-label ] each ]
+ [ [ resolve-relative-label ] map concat ]
+ bi* ;
+
+: init-fixup ( -- )
+ V{ } clone literal-table set
+ V{ } clone label-table set
+ BV{ } clone relocation-table set ;
-: fixup ( fixup-directives -- code )
+: with-fixup ( quot -- code )
[
init-fixup
- [ fixup* ] each
+ call
+ label-table [ resolve-labels ] change
literal-table get >array
relocation-table get >byte-array
- label-table get resolve-labels
- ] B{ } make 4array ;
+ label-table get
+ ] B{ } make 4array ; inline