1 ! Copyright (C) 2007, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays byte-arrays generic assocs hashtables io.binary
4 kernel kernel.private math namespaces sequences words
5 quotations strings alien.accessors alien.strings layouts system
6 combinators math.bitfields words.private cpu.architecture
7 math.order accessors growable ;
10 : no-stack-frame -1 ; inline
12 TUPLE: frame-required n ;
14 : frame-required ( n -- ) \ frame-required boa , ;
16 : stack-frame-size ( code -- n )
18 dup frame-required? [ frame-required-n max ] [ drop ] if
21 GENERIC: fixup* ( frame-size obj -- frame-size )
23 : code-format 22 getenv ;
25 : compiled-offset ( -- n ) building get length code-format * ;
29 : <label> ( -- label ) label new ;
32 compiled-offset swap set-label-offset ;
34 : define-label ( name -- ) <label> swap set ;
36 : resolve-label ( label/name -- ) dup label? [ get ] unless , ;
38 : if-stack-frame ( frame-size quot -- )
39 swap dup no-stack-frame =
40 [ 2drop ] [ stack-frame swap call ] if ; inline
44 { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
45 { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
48 SYMBOL: relocation-table
52 : rc-absolute-cell 0 ;
55 : rc-absolute-ppc-2/2 3 ;
56 : rc-relative-ppc-2 4 ;
57 : rc-relative-ppc-3 5 ;
58 : rc-relative-arm-3 6 ;
60 : rc-indirect-arm-pc 8 ;
62 : rc-absolute? ( n -- ? )
63 dup rc-absolute-cell =
65 rot rc-absolute-ppc-2/2 = or or ;
76 TUPLE: label-fixup label class ;
78 : label-fixup ( label class -- ) \ label-fixup boa , ;
81 dup class>> rc-absolute?
82 [ "Absolute labels not supported" throw ] when
83 dup label>> swap class>> compiled-offset 4 - rot
84 3array label-table get push ;
86 TUPLE: rel-fixup arg class type ;
88 : rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
90 : push-4 ( value vector -- )
91 [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
92 swap set-alien-unsigned-4 ;
95 [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
96 [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
97 [ relocation-table get push-4 ] bi@ ;
99 M: frame-required fixup* drop ;
101 M: integer fixup* , ;
103 : adjoin* ( obj table -- n )
104 2dup swap [ eq? ] curry find drop
105 [ 2nip ] [ dup length >r push r> ] if* ;
107 SYMBOL: literal-table
109 : add-literal ( obj -- n ) literal-table get adjoin* ;
111 : add-dlsym-literals ( symbol dll -- )
112 >r string>symbol r> 2array literal-table get push-all ;
114 : rel-dlsym ( name dll class -- )
115 >r literal-table get length >r
117 r> r> rt-dlsym rel-fixup ;
119 : rel-word ( word class -- )
120 >r add-literal r> rt-xt rel-fixup ;
122 : rel-primitive ( word class -- )
123 >r def>> first r> rt-primitive rel-fixup ;
125 : rel-literal ( literal class -- )
126 >r add-literal r> rt-literal rel-fixup ;
128 : rel-this ( class -- )
129 0 swap rt-label rel-fixup ;
131 : rel-here ( class -- )
132 0 swap rt-here rel-fixup ;
135 BV{ } clone relocation-table set
136 V{ } clone label-table set ;
138 : resolve-labels ( labels -- labels' )
141 [ "Unresolved label" throw ] unless*
145 : fixup ( code -- literals relocation labels code )
148 dup stack-frame-size swap [ fixup* ] each drop
150 literal-table get >array
151 relocation-table get >byte-array
152 label-table get resolve-labels