diff --git a/.gitignore b/.gitignore index 2c4f281f17..dc1e206ccd 100644 --- a/.gitignore +++ b/.gitignore @@ -16,6 +16,10 @@ /ti3le/ /ti3nt/ /ti3osx/ +/arm32le/ +/tarm32le/ +/ppc32le/ +/tppc32le/ /xc-*/ *.*run /csug/math/csug/ diff --git a/c/Mf-tarm32le b/c/Mf-tarm32le new file mode 100644 index 0000000000..c5960916df --- /dev/null +++ b/c/Mf-tarm32le @@ -0,0 +1,46 @@ +# Mf-arm32le +# 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. + +m = tarm32le +Cpu = ARMV6 + +mdclib = -lm -ldl ${ncursesLib} -lpthread -lrt -luuid +C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS} +o = o +mdsrc = arm32le.c +mdobj = arm32le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; ${MAKE} liblz4.a) diff --git a/c/vfasl.c b/c/vfasl.c index 94b425b752..f313470b69 100644 --- a/c/vfasl.c +++ b/c/vfasl.c @@ -541,7 +541,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) ptr sym_base = vspaces[vspace_symbol]; ptr code = TYPE(vspaces[vspace_code], type_typed_object); ptr code_end = TYPE(VSPACE_END(vspace_code), type_typed_object); - S_record_code_mod(tc, (uptr)code, (uptr)code_end - (uptr)code); + S_record_code_mod(tc, (uptr)vspaces[vspace_code], (uptr)code_end - (uptr)code); while (code != code_end) { relink_code(code, sym_base, vspaces, vspace_offsets, to_static); code = ptr_add(code, size_code(CODELEN(code))); diff --git a/mats/Mf-tarm32le b/mats/Mf-tarm32le new file mode 100644 index 0000000000..c045adc159 --- /dev/null +++ b/mats/Mf-tarm32le @@ -0,0 +1,27 @@ +# Mf-tarm32le +# 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. + +m = tarm32le + +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c +fobj = foreign1.so + +include Mf-base + +foreign1.so: ${fsrc} ../boot/$m/scheme.h + cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} + +cat_flush: cat_flush.c + cc -o cat_flush cat_flush.c diff --git a/s/Mf-tarm32le b/s/Mf-tarm32le new file mode 100644 index 0000000000..655c04a279 --- /dev/null +++ b/s/Mf-tarm32le @@ -0,0 +1,19 @@ +# Mf-tarm32le +# 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. + +m = tarm32le +archincludes = arm32.ss + +include Mf-base diff --git a/s/arm32.ss b/s/arm32.ss index 64df2a6ab8..10373e0698 100644 --- a/s/arm32.ss +++ b/s/arm32.ss @@ -842,6 +842,32 @@ `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill)) `(set! ,(make-live-info) ,z (asm ,info ,asm-get-tc ,u ,ulr))))]) + (define-instruction value activate-thread + [(op (z ur)) + (safe-assert (eq? z %Cretval)) + (let ([u (make-tmp 'u)] [ulr (make-precolored-unspillable 'ulr %lr)]) + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) + `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill)) + `(set! ,(make-live-info) ,z (asm ,info ,asm-activate-thread ,u ,ulr))))]) + + (define-instruction effect deactivate-thread + [(op) + (let ([u (make-tmp 'u)] [ulr (make-precolored-unspillable 'ulr %lr)]) + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) + `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill)) + `(asm ,info ,asm-deactivate-thread ,u ,ulr)))]) + + (define-instruction effect unactivate-thread + [(op (x ur)) + (safe-assert (eq? x %r2)) + (let ([u (make-tmp 'u)] [ulr (make-precolored-unspillable 'ulr %lr)]) + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) + `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill)) + `(asm ,info ,asm-unactivate-thread ,x ,u ,ulr)))]) + (define-instruction value (asmlibcall) [(op (z ur)) (let ([u (make-tmp 'u)]) @@ -959,6 +985,10 @@ `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill)) `(asm ,info ,asm-cas ,r ,old ,new ,u1 ,u2)))))])) + (define-instruction effect (write-write-fence) + [(op) + `(asm ,info ,asm-write-write-fence)]) + (define-instruction effect (pause) ; NB: user sqrt or something like that? [(op) '()]) @@ -1003,7 +1033,7 @@ asm-rp-header asm-rp-compact-header asm-indirect-call asm-condition-code asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc - asm-lock asm-lock+/- asm-cas + asm-lock asm-lock+/- asm-cas asm-write-write-fence asm-fpop-2 asm-fpsqrt asm-c-simple-call asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size asm-enter asm-foreign-call asm-foreign-callable @@ -1013,6 +1043,7 @@ shift-count? unsigned8? unsigned12? ; threaded version specific asm-get-tc + asm-activate-thread asm-deactivate-thread asm-unactivate-thread ; machine dependent exports asm-kill info-vpush-reg info-vpush-n) @@ -1155,6 +1186,8 @@ (define-op ldrex ldrex-op #b00011001) (define-op strex strex-op #b00011000) + (define-op dmbishst dmb-op #b1010) + (define-op bnei branch-imm-op (ax-cond 'ne)) (define-op brai branch-imm-op (ax-cond 'al)) @@ -1397,6 +1430,12 @@ [4 #b1001] [0 (ax-ea-reg-code opnd0-ea)]))) + (define dmb-op + (lambda (op opcode code*) + (emit-code (op code*) + [4 #b1111010101111111111100000101] + [0 opcode]))) + (define branch-imm-op (lambda (op cond-bits disp code*) (emit-code (op disp code*) @@ -2098,6 +2137,7 @@ [else (sorry! who "unexpected asm-swap type argument ~s" type)])))))) (define asm-lock + ; tmp = 1 # in case load result is not 0 ; tmp2 = ldrex src ; cmp tmp2, 0 ; bne L1 (+2) @@ -2106,11 +2146,12 @@ ;L1: (lambda (code* src tmp tmp2) (Trivit (src tmp tmp2) - (emit ldrex tmp2 src - (emit cmpi tmp2 0 - (emit bnei 1 - (emit movi1 tmp2 1 - (emit strex tmp tmp2 src code*)))))))) + (emit movi1 tmp 1 + (emit ldrex tmp2 src + (emit cmpi tmp2 0 + (emit bnei 1 + (emit movi1 tmp2 1 + (emit strex tmp tmp2 src code*))))))))) (define-who asm-lock+/- ; L: @@ -2149,6 +2190,10 @@ (emit cmpi tmp2 0 code*)))))))) + (define asm-write-write-fence + (lambda (code*) + (emit dmbishst code*))) + (define asm-fp-relop (lambda (info) (lambda (l1 l2 offset x y) @@ -2292,6 +2337,21 @@ (lambda (code* dest jmp-tmp . ignore) ; dest is ignored, since it is always Cretval (asm-helper-call code* target #f jmp-tmp)))) + (define asm-activate-thread + (let ([target `(arm32-call 0 (entry ,(lookup-c-entry activate-thread)))]) + (lambda (code* dest jmp-tmp . ignore) + (asm-helper-call code* target #t jmp-tmp)))) + + (define asm-deactivate-thread + (let ([target `(arm32-call 0 (entry ,(lookup-c-entry deactivate-thread)))]) + (lambda (code* jmp-tmp . ignore) + (asm-helper-call code* target #f jmp-tmp)))) + + (define asm-unactivate-thread + (let ([target `(arm32-call 0 (entry ,(lookup-c-entry unactivate-thread)))]) + (lambda (code* arg-reg jmp-tmp . ignore) + (asm-helper-call code* target #f jmp-tmp)))) + (define-who asm-return-address (lambda (dest l incr-offset next-addr) (make-rachunk dest l incr-offset next-addr @@ -2552,6 +2612,35 @@ (define num-dbl-regs 8) ; number of `double` registers normally usd by the ABI (define sgl-regs (lambda () (list %Cfparg1 %Cfparg1b %Cfparg2 %Cfparg2b %Cfparg3 %Cfparg3b %Cfparg4 %Cfparg4b %Cfparg5 %Cfparg5b %Cfparg6 %Cfparg6b %Cfparg7 %Cfparg7b %Cfparg8 %Cfparg8b))) + (define save-and-restore + (lambda (regs e) + (safe-assert (andmap reg? regs)) + (with-output-language (L13 Effect) + (let ([save-and-restore-gp + (lambda (regs e) + (let* ([regs (filter (lambda (r) (not (eq? (reg-type r) 'fp))) regs)] + [regs (if (fxodd? (length regs)) + (cons %tc regs) ; keep doubleword aligned + regs)]) + (cond + [(null? regs) e] + [else + (%seq + (inline ,(make-info-kill*-live* '() regs) ,%push-multiple) + ,e + (inline ,(make-info-kill*-live* regs '()) ,%pop-multiple))])))] + [save-and-restore-fp + (lambda (regs e) + (let ([fp-regs (filter (lambda (r) (eq? (reg-type r) 'fp)) regs)]) + (cond + [(null? fp-regs) e] + [else + (let ([info (make-info-vpush (car fp-regs) (length fp-regs))]) + (%seq + (inline ,info ,%vpush-multiple) + ,e + (inline ,info ,%vpop-multiple)))])))]) + (save-and-restore-gp regs (save-and-restore-fp regs e)))))) (define-who asm-foreign-call (with-output-language (L13 Effect) (define int-regs (lambda () (list %Carg1 %Carg2 %Carg3 %Carg4))) @@ -2708,12 +2797,12 @@ [(and doubles? (fx>= (length sgl*) (fx* 2 num-members))) ;; Allocate each double to a register - (let dbl-loop ([size size] [offset 0] [sgl* sgl*] [loc #f]) + (let dbl-loop ([size size] [offset 0] [live* live*] [sgl* sgl*] [loc #f]) (cond [(fx= size 0) (loop (cdr types) (cons loc locs) live* int* sgl* #f isp)] [else - (dbl-loop (fx- size 8) (fx+ offset 8) (cddr sgl*) + (dbl-loop (fx- size 8) (fx+ offset 8) (cons (car sgl*) live*) (cddr sgl*) (combine-loc loc (load-boxed-double-reg (car sgl*) offset)))]))] [else ;; General case; for non-doubles, use integer registers while available, @@ -2853,14 +2942,49 @@ (case bits [(64) (list %r1 %Cretval)] [else (list %Cretval)])] - [else (list %r0)]))]) + [(fp-ftd& ,ftd) + (let* ([members ($ftd->members ftd)] + [num-members (length members)]) + (cond + [(and (fx<= num-members 4) + (or (andmap double-member? members) + (andmap float-member? members))) + ;; double/float results are in floating-point registers + (let ([double? (and (pair? members) (double-member? (car members)))]) + (let loop ([members members] [sgl* (sgl-regs)]) + (cond + [(null? members) '()] + [double? + (cons (car sgl*) (loop (cdr members) (cddr sgl*)))] + [else + (cons (car sgl*) (if (null? (cdr members)) + '() + (loop (cddr members) (cddr sgl*))))])))] + [else + ;; result is in %Cretval and maybe %r1 + (case ($ftd-size ftd) + [(8) (list %Cretval %r1)] + [else (list %Cretval)])]))] + [else (list %r0)]))] + [add-deactivate + (lambda (adjust-active? t0 live* result-live* k) + (cond + [adjust-active? + (%seq + (set! ,%ac0 ,t0) + ,(save-and-restore live* (%inline deactivate-thread)) + ,(k %ac0) + ,(save-and-restore result-live* `(set! ,%Cretval ,(%inline activate-thread))))] + [else (k t0)]))]) (lambda (info) (safe-assert (reg-callee-save? %tc)) ; no need to save-restore (let* ([arg-type* (info-foreign-arg-type* info)] - [varargs? (memq 'varargs (info-foreign-conv* info))] + [conv* (info-foreign-conv* info)] + [varargs? (memq 'varargs conv*)] [result-type (info-foreign-result-type info)] [result-reg* (get-result-regs result-type varargs?)] - [fill-result-here? (indirect-result-that-fits-in-registers? result-type)]) + [fill-result-here? (indirect-result-that-fits-in-registers? result-type)] + [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]) (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*) varargs?) (lambda (args-frame-size locs live*) @@ -2883,7 +3007,9 @@ [else locs])) (lambda (t0 not-varargs?) (add-fill-result fill-result-here? result-type args-frame-size - `(inline ,(make-info-kill*-live* (add-caller-save-registers result-reg*) live*) ,%c-call ,t0))) + (add-deactivate adjust-active? t0 live* result-reg* + (lambda (t0) + `(inline ,(make-info-kill*-live* (add-caller-save-registers result-reg*) live*) ,%c-call ,t0))))) (nanopass-case (Ltype Type) result-type [(fp-double-float) (if varargs? @@ -2948,9 +3074,9 @@ | &-return space | up to 8 words sp+52+R: | | +---------------------------+<- 8-byte boundary - | | - | pad word if necessary | 0-1 words - sp+52: | | + | activatation state | + | and/or | 0-2 words + sp+52: | pad word if necessary | +---------------------------+ | | | callee-save regs + lr | 13 words @@ -3233,7 +3359,14 @@ `(set! ,(car sgl*) ,(%mref ,%sp ,%zero ,offset fp)) `(set! ,(car sgl*) ,(%inline load-single ,(%mref ,%sp ,%zero ,offset fp))))]) (if e `(seq ,e ,new-e) new-e)))])))) - '() + (let ([double? (and (pair? members) (double-member? (car members)))]) + (let loop ([members members] [sgl* (sgl-regs)] [aligned? #t]) + (cond + [(null? members) '()] + [else (let ([regs (loop (cdr members) + (if double? (cddr sgl*) (cdr sgl*)) + (or double? (not aligned?)))]) + (if aligned? (cons (car sgl*) regs) regs))]))) ($ftd-size ftd))] [else (case ($ftd-size ftd) @@ -3316,12 +3449,16 @@ (memq r callee-save-regs+lr)))) (vector->list regvec))) (let* ([arg-type* (info-foreign-arg-type* info)] - [varargs? (memq 'varargs (info-foreign-conv* info))] + [conv* (info-foreign-conv* info)] + [varargs? (memq 'varargs conv*)] [result-type (info-foreign-result-type info)] - [synthesize-first? (indirect-result-that-fits-in-registers? result-type)]) + [synthesize-first? (indirect-result-that-fits-in-registers? result-type)] + [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]) (let-values ([(iint idbl) (count-reg-args arg-type* synthesize-first? varargs?)]) (let ([saved-reg-bytes (fx+ (fx* isaved 4) (fx* fpsaved 8))] - [pre-pad-bytes (if (fxeven? isaved) 0 4)] + [pre-pad-bytes (if (fxeven? isaved) + (if adjust-active? 8 0) + 4)] [int-reg-bytes (fx* iint 4)] [post-pad-bytes (if (fxeven? iint) 0 4)] [float-reg-bytes (fx* idbl 8)]) @@ -3343,6 +3480,12 @@ ; save the callee save registers & return address (inline ,(make-info-kill*-live* '() callee-save-regs+lr) ,%push-multiple) (inline ,(make-info-vpush (car callee-save-fpregs) fpsaved) ,%vpush-multiple) + ; maybe activate + ,(if adjust-active? + `(seq + (set! ,%Cretval ,(%inline activate-thread)) + (set! ,(%mref ,%sp ,saved-reg-bytes) ,%Cretval)) + `(nop)) ; set up tc for benefit of argument-conversion code, which might allocate ,(if-feature pthreads (%seq @@ -3357,6 +3500,11 @@ (lambda () (in-context Tail (%seq + ,(if adjust-active? + `(seq + (set! ,%r2 ,(%mref ,%sp ,saved-reg-bytes)) + ,(save-and-restore result-regs (%inline unactivate-thread ,%r2))) + `(nop)) ; restore the callee save registers (inline ,(make-info-vpush (car callee-save-fpregs) fpsaved) ,%vpop-multiple) (inline ,(make-info-kill* callee-save-regs+lr) ,%pop-multiple) diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 4cbacea4f4..6d59dec6c4 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -3702,12 +3702,19 @@ ,(%inline sll ,e (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset)))) ,(%constant type-char)))) + (define add-write-fence + (lambda (e) + (if-feature pthreads + (constant-case architecture + [(arm32) `(seq ,(%inline write-write-fence) ,e)] + [else e]) + e))) (define build-dirty-store (case-lambda [(base offset e) (build-dirty-store base %zero offset e)] [(base index offset e) (build-dirty-store base index offset e (lambda (base index offset e) `(set! ,(%mref ,base ,index ,offset) ,e)) - (lambda (s r) `(seq ,s ,r)))] + (lambda (s r) (add-write-fence `(seq ,s ,r))))] [(base index offset e build-assign build-seq) (if (nanopass-case (L7 Expr) e [(quote ,d) (ptr->imm d)] @@ -3730,7 +3737,7 @@ (bind #t ([e e]) ; eval a second so the address is not live across any calls (bind #t ([a a]) - (build-seq + (build-seq (build-assign a %zero 0 e) `(if ,(%type-check mask-fixnum type-fixnum ,e) ,(%constant svoid) @@ -3743,9 +3750,10 @@ (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code))))) (define build-cas-seq (lambda (cas remember) - `(if ,cas - (seq ,remember ,(%constant strue)) - ,(%constant sfalse)))) + (add-write-fence + `(if ,cas + (seq ,remember ,(%constant strue)) + ,(%constant sfalse))))) (define build-$record (lambda (tag args) (bind #f (tag) diff --git a/s/np-languages.ss b/s/np-languages.ss index eb2c322cdd..2ded5794a0 100644 --- a/s/np-languages.ss +++ b/s/np-languages.ss @@ -561,7 +561,8 @@ (declare-primitive vpush-multiple effect #f) ; arm (declare-primitive vpop-multiple effect #f) ; arm (declare-primitive cas effect #f) - + (declare-primitive write-write-fence effect #f) + (declare-primitive < pred #t) (declare-primitive <= pred #t) (declare-primitive > pred #t) diff --git a/s/tarm32le.def b/s/tarm32le.def new file mode 100644 index 0000000000..1b83d08799 --- /dev/null +++ b/s/tarm32le.def @@ -0,0 +1,52 @@ +;;; arm32le.def +;;; 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. + +(define-constant machine-type (constant machine-type-tarm32le)) +(define-constant architecture 'arm32) +(define-constant address-bits 32) +(define-constant ptr-bits 32) +(define-constant int-bits 32) +(define-constant short-bits 16) +(define-constant long-bits 32) +(define-constant long-long-bits 64) +(define-constant size_t-bits 32) +(define-constant ptrdiff_t-bits 32) +(define-constant wchar-bits 32) +(define-constant time-t-bits 32) +(define-constant max-float-alignment 8) +(define-constant max-integer-alignment 8) +(define-constant asm-arg-reg-max 5) +(define-constant asm-arg-reg-cnt 3) +(define-constant asm-fpreg-max 2) +(define-constant typedef-ptr "void *") +(define-constant typedef-iptr "int") +(define-constant typedef-uptr "unsigned int") +(define-constant typedef-i8 "char") +(define-constant typedef-u8 "unsigned char") +(define-constant typedef-i16 "short") +(define-constant typedef-u16 "unsigned short") +(define-constant typedef-i32 "int") +(define-constant typedef-u32 "unsigned int") +(define-constant typedef-i64 "long long") +(define-constant typedef-u64 "unsigned long long") +(define-constant typedef-string-char "unsigned int") +(define-constant native-endianness 'little) +(define-constant unaligned-floats #f) +(define-constant unaligned-integers #t) +(define-constant integer-divide-instruction #f) +(define-constant popcount-instruction #f) +(define-constant software-floating-point #f) +(define-constant segment-table-levels 1) +(features iconv expeditor pthreads)