102 lines
3.9 KiB
Scheme
102 lines
3.9 KiB
Scheme
|
;;; reloc.ss
|
||
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||
|
|
;;;
|
||
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||
|
|
;;; you may not use this file except in compliance with the License.
|
||
|
|
;;; You may obtain a copy of the License at
|
||
|
|
;;;
|
||
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||
|
|
;;;
|
||
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
||
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||
|
|
;;; See the License for the specific language governing permissions and
|
||
|
|
;;; limitations under the License.
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define $reloc
|
||
|
|
(lambda (type item-offset code-offset)
|
||
|
|
(make-reloc type item-offset code-offset
|
||
|
|
(or (> item-offset (constant reloc-item-offset-mask))
|
||
|
|
(> code-offset (constant reloc-code-offset-mask))))))
|
||
|
|
|
||
|
|
(define $make-relocation-table!
|
||
|
|
(let ()
|
||
|
|
(define link-code-object!
|
||
|
|
(foreign-procedure "(cs)link_code_object"
|
||
|
|
(scheme-object scheme-object)
|
||
|
|
void))
|
||
|
|
(define set-reloc!
|
||
|
|
(foreign-procedure "(cs)s_set_reloc"
|
||
|
|
(scheme-object scheme-object scheme-object)
|
||
|
|
scheme-object))
|
||
|
|
(define make-reloc-table
|
||
|
|
(foreign-procedure "(cs)s_make_reloc_table"
|
||
|
|
(scheme-object scheme-object)
|
||
|
|
scheme-object))
|
||
|
|
(lambda (p r* objs)
|
||
|
|
(make-reloc-table p (fold-left (lambda (m r) (fx+ m (if (reloc-long? r) 3 1))) 0 r*))
|
||
|
|
(let mkc1 ([r* r*] [n 0])
|
||
|
|
(if (null? r*)
|
||
|
|
(link-code-object! p objs)
|
||
|
|
(let ([r (car r*)] [r* (cdr r*)])
|
||
|
|
(if (reloc-long? r)
|
||
|
|
(begin
|
||
|
|
(set-reloc! p n
|
||
|
|
(logor
|
||
|
|
(bitwise-arithmetic-shift-left (reloc-type r) (constant reloc-type-offset))
|
||
|
|
(constant reloc-extended-format)))
|
||
|
|
(set-reloc! p (fx+ n 1) (reloc-item-offset r))
|
||
|
|
(set-reloc! p (fx+ n 2) (reloc-code-offset r))
|
||
|
|
(mkc1 r* (fx+ n 3)))
|
||
|
|
(begin
|
||
|
|
(set-reloc! p n
|
||
|
|
(logor
|
||
|
|
(bitwise-arithmetic-shift-left (reloc-type r) (constant reloc-type-offset))
|
||
|
|
(bitwise-arithmetic-shift-left (reloc-code-offset r) (constant reloc-code-offset-offset))
|
||
|
|
(bitwise-arithmetic-shift-left (reloc-item-offset r) (constant reloc-item-offset-offset))))
|
||
|
|
(mkc1 r* (fx+ n 1))))))))))
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(set! $make-cinst
|
||
|
|
(lambda (build-sinst vtable)
|
||
|
|
(critical-section
|
||
|
|
(let ([p ($make-code-object
|
||
|
|
(if (eq? (subset-mode) 'system) (constant code-flag-system) 0)
|
||
|
|
0
|
||
|
|
"cinst"
|
||
|
|
(* 2 (constant ptr-bytes))
|
||
|
|
#f
|
||
|
|
'())])
|
||
|
|
($make-relocation-table! p
|
||
|
|
(list ($reloc (constant reloc-abs) 0 (constant ptr-bytes))
|
||
|
|
($reloc (constant reloc-abs) (constant code-data-disp)
|
||
|
|
(constant code-data-disp)))
|
||
|
|
(list vtable (build-sinst p)))
|
||
|
|
p))))
|
||
|
|
|
||
|
|
(set! $make-vtable
|
||
|
|
(lambda (foreign-entries)
|
||
|
|
(let ([n (length foreign-entries)])
|
||
|
|
(let loop ([i n] [r '()] [offset (constant code-data-disp)])
|
||
|
|
(if (fx= i 0)
|
||
|
|
(critical-section
|
||
|
|
(let ([p ($make-code-object
|
||
|
|
(if (eq? (subset-mode) 'system) (constant code-flag-system) 0)
|
||
|
|
0
|
||
|
|
"vtable"
|
||
|
|
(* n (constant ptr-bytes))
|
||
|
|
#f
|
||
|
|
'())])
|
||
|
|
($make-relocation-table! p r foreign-entries)
|
||
|
|
p))
|
||
|
|
(loop (fx- i 1)
|
||
|
|
(cons ($reloc
|
||
|
|
(constant reloc-abs)
|
||
|
|
(constant code-data-disp)
|
||
|
|
offset)
|
||
|
|
r)
|
||
|
|
(constant ptr-bytes)))))))
|
||
|
|
)
|
||
|
|
)
|