1 ! Copyright (C) 2007, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays byte-arrays byte-vectors generic assocs hashtables
4 io.binary kernel kernel.private math namespaces make sequences
5 words quotations strings alien.accessors alien.strings layouts
6 system combinators math.bitwise math.order
7 accessors growable fry generalizations compiler.constants ;
8 IN: compiler.codegen.fixup
11 SYMBOL: compiling-word
16 : add-literal ( obj -- ) literal-table get push ;
23 : <label> ( -- label ) label new ;
24 : define-label ( name -- ) <label> swap set ;
26 : compiled-offset ( -- n ) building get length ;
28 : resolve-label ( label/name -- )
29 dup label? [ get ] unless
30 compiled-offset >>offset drop ;
32 : offset-for-class ( class -- n )
33 rc-absolute-cell = cell 4 ? compiled-offset swap - ;
35 TUPLE: label-fixup { label label } { class integer } { offset integer } ;
37 : label-fixup ( label class -- )
38 dup offset-for-class \ label-fixup boa label-table get push ;
41 SYMBOL: relocation-table
43 : push-4 ( value vector -- )
44 [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
45 swap set-alien-unsigned-4 ;
47 : add-relocation-entry ( type class offset -- )
48 { 0 24 28 } bitfield relocation-table get push-4 ;
50 : rel-fixup ( class type -- )
51 swap dup offset-for-class add-relocation-entry ;
53 : add-dlsym-literals ( symbol dll -- )
54 [ string>symbol add-literal ] [ add-literal ] bi* ;
56 : rel-dlsym ( name dll class -- )
57 [ add-dlsym-literals ] dip rt-dlsym rel-fixup ;
59 : rel-word ( word class -- )
60 [ add-literal ] dip rt-xt rel-fixup ;
62 : rel-word-pic ( word class -- )
63 [ add-literal ] dip rt-xt-pic rel-fixup ;
65 : rel-word-pic-tail ( word class -- )
66 [ add-literal ] dip rt-xt-pic-tail rel-fixup ;
68 : rel-primitive ( word class -- )
69 [ def>> first add-literal ] dip rt-primitive rel-fixup ;
71 : rel-immediate ( literal class -- )
72 [ add-literal ] dip rt-immediate rel-fixup ;
74 : rel-this ( class -- )
77 : rel-here ( offset class -- )
78 [ add-literal ] dip rt-here rel-fixup ;
80 : rel-vm ( offset class -- )
81 [ add-literal ] dip rt-vm rel-fixup ;
83 : rel-cards-offset ( class -- )
84 rt-cards-offset rel-fixup ;
86 : rel-decks-offset ( class -- )
87 rt-decks-offset rel-fixup ;
90 : resolve-offset ( label-fixup -- offset )
91 label>> offset>> [ "Unresolved label" throw ] unless* ;
93 : resolve-absolute-label ( label-fixup -- )
94 dup resolve-offset neg add-literal
95 [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
97 : resolve-relative-label ( label-fixup -- label )
98 [ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
100 : resolve-labels ( label-fixups -- labels' )
101 [ class>> rc-absolute? ] partition
102 [ [ resolve-absolute-label ] each ]
103 [ [ resolve-relative-label ] map concat ]
106 : init-fixup ( word -- )
108 V{ } clone literal-table set
109 V{ } clone label-table set
110 BV{ } clone relocation-table set ;
112 : with-fixup ( word quot -- code )
116 label-table [ resolve-labels ] change
118 literal-table get >array
119 relocation-table get >byte-array
121 ] B{ } make 5 narray ; inline