This repository has been archived on 2022-08-10. You can view files and clone it, but cannot push or open issues or pull requests.
chez-openbsd/s/reloc.ss
2022-07-29 15:12:07 +02:00

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)))))))
)
)